diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 7348d914fd..fbe12277c1 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -155,10 +155,6 @@ jobs: name: Test hls-eval-plugin run: cabal test hls-eval-plugin --test-options="$TEST_OPTS" || cabal test hls-eval-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2' && matrix.ghc != '9.4' && matrix.ghc != '9.6' - name: Test hls-haddock-comments-plugin - run: cabal test hls-haddock-comments-plugin --test-options="$TEST_OPTS" || cabal test hls-haddock-comments-plugin --test-options="$TEST_OPTS" - - if: matrix.test name: Test hls-splice-plugin run: cabal test hls-splice-plugin --test-options="$TEST_OPTS" || cabal test hls-splice-plugin --test-options="$TEST_OPTS" @@ -175,10 +171,6 @@ jobs: name: Test hls-fourmolu-plugin run: cabal test hls-fourmolu-plugin --test-options="$TEST_OPTS" || cabal test hls-fourmolu-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2' && matrix.ghc != '9.4' && matrix.ghc != '9.6' - name: Test hls-tactics-plugin test suite - run: cabal test hls-tactics-plugin --test-options="$TEST_OPTS" || cabal test hls-tactics-plugin --test-options="$TEST_OPTS" - - if: matrix.test name: Test hls-explicit-imports-plugin test suite run: cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" || cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" @@ -195,10 +187,6 @@ jobs: name: Test hls-hlint-plugin test suite run: cabal test hls-hlint-plugin --test-options="$TEST_OPTS" || cabal test hls-hlint-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.0' && matrix.ghc != '9.2' && matrix.ghc != '9.4' && matrix.ghc != '9.6' - name: Test hls-stan-plugin test suite - run: cabal test hls-stan-plugin --test-options="$TEST_OPTS" || cabal test hls-stan-plugin --test-options="$TEST_OPTS" - - if: matrix.test name: Test hls-module-name-plugin test suite run: cabal test hls-module-name-plugin --test-options="$TEST_OPTS" || cabal test hls-module-name-plugin --test-options="$TEST_OPTS" diff --git a/CODEOWNERS b/CODEOWNERS index 747b0cd140..9450a53ec1 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -17,7 +17,6 @@ /plugins/hls-floskell-plugin @Ailrun /plugins/hls-fourmolu-plugin @georgefst /plugins/hls-gadt-plugin @July541 -/plugins/hls-haddock-comments-plugin @berberman @kokobd /plugins/hls-hlint-plugin @eddiemundo /plugins/hls-module-name-plugin /plugins/hls-ormolu-plugin @georgefst @@ -29,8 +28,6 @@ /plugins/hls-code-range-plugin @kokobd /plugins/hls-splice-plugin @konn /plugins/hls-stylish-haskell-plugin @Ailrun -/plugins/hls-tactics-plugin -/plugins/hls-stan-plugin @uhbif19 /plugins/hls-explicit-record-fields-plugin @ozkutuk /plugins/hls-overloaded-record-dot-plugin @joyfulmantis diff --git a/bench/config.yaml b/bench/config.yaml index d0433ff2ba..04106b32b9 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -205,7 +205,6 @@ configurations: # # - ghcide-core # implicitly included in all configurations # # - ghcide-hover-and-symbols # implicitly included in all configurations # - ghcide-type-lenses -# - haddockComments # - hlint # - importLens # - moduleName @@ -215,6 +214,4 @@ configurations: # - rename # - retrie # - splice -# - stan # # - stylish-haskell -# - tactics diff --git a/cabal.project b/cabal.project index 6033bbf504..0c6bfba565 100644 --- a/cabal.project +++ b/cabal.project @@ -10,7 +10,6 @@ packages: ./hls-test-utils ./plugins/hls-cabal-plugin ./plugins/hls-cabal-fmt-plugin - ./plugins/hls-tactics-plugin ./plugins/hls-stylish-haskell-plugin ./plugins/hls-fourmolu-plugin ./plugins/hls-class-plugin @@ -19,7 +18,6 @@ packages: ./plugins/hls-hlint-plugin ./plugins/hls-rename-plugin ./plugins/hls-retrie-plugin - ./plugins/hls-haddock-comments-plugin ./plugins/hls-splice-plugin ./plugins/hls-floskell-plugin ./plugins/hls-pragmas-plugin @@ -30,7 +28,6 @@ packages: ./plugins/hls-qualify-imported-names-plugin ./plugins/hls-code-range-plugin ./plugins/hls-change-type-signature-plugin - ./plugins/hls-stan-plugin ./plugins/hls-gadt-plugin ./plugins/hls-explicit-fixity-plugin ./plugins/hls-explicit-record-fields-plugin diff --git a/docs/configuration.md b/docs/configuration.md index 18aa4717eb..074efd4217 100644 --- a/docs/configuration.md +++ b/docs/configuration.md @@ -50,19 +50,13 @@ Here is a list of the additional settings currently supported by `haskell-langua Plugins have a generic config to control their behaviour. The schema of such config is: - `haskell.plugin.${pluginName}.globalOn`: usually with default true. Whether the plugin is enabled at runtime or it is not. That is the option you might use if you want to disable completely a plugin. - - Actual plugin names are: `ghcide-code-actions-fill-holes`, `ghcide-completions`, `ghcide-hover-and-symbols`, `ghcide-type-lenses`, `ghcide-code-actions-type-signatures`, `ghcide-code-actions-bindings`, `ghcide-code-actions-imports-exports`, `eval`, `moduleName`, `pragmas`, `importLens`, `class`, `tactics` (aka wingman), `hlint`, `haddockComments`, `retrie`, `rename`, `splice`, `stan`. + - Actual plugin names are: `ghcide-code-actions-fill-holes`, `ghcide-completions`, `ghcide-hover-and-symbols`, `ghcide-type-lenses`, `ghcide-code-actions-type-signatures`, `ghcide-code-actions-bindings`, `ghcide-code-actions-imports-exports`, `eval`, `moduleName`, `pragmas`, `importLens`, `class`, `hlint`, `retrie`, `rename`, `splice`. - So to disable the import lens with an explicit list of module definitions you could set `haskell.plugin.importLens.globalOn: false` - `haskell.plugin.${pluginName}.${lspCapability}On`: usually with default true. Whether a concrete plugin capability is enabled. - Capabilities are the different ways a lsp server can interact with the editor. The current available capabilities of the server are: `callHierarchy`, `codeActions`, `codeLens`, `diagnostics`, `hover`, `symbols`, `completion`, `rename`. - Note that usually plugins don't provide all capabilities but some of them or even only one. - So to disable code changes suggestions from the `hlint` plugin (but no diagnostics) you could set `haskell.plugin.hlint.codeActionsOn: false` - Plugin specific configuration: - - `tactic` (aka wingman): - - `haskell.plugin.tactics.config.auto_gas`, default 4: The depth of the search tree when performing "Attempt to fill hole". Bigger values will be able to derive more solutions, but will take exponentially more time. - - `haskell.plugin.tactics.config.timeout_duration`, default 2: The timeout for Wingman actions, in seconds. - - `haskell.plugin.tactics.config.hole_severity`, default empty: The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities. One of `error`, `warning`, `info`, `hint`, `none`. - - `haskell.plugin.tactics.config.max_use_ctor_actions`, default 5: Maximum number of `Use constructor ` code actions that can appear. - - `haskell.plugin.tactics.config.proofstate_styling`, default true: Should Wingman emit styling markup when showing metaprogram proof states? - `eval`: - `haskell.plugin.eval.config.diff`, default true: When reloading haddock test results in changes, mark it with WAS/NOW. - `haskell.plugin.eval.config.exception`, default false: When the command results in an exception, mark it with `*** Exception:`. diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index 1eae381892..8f4aaaceb9 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -198,7 +198,6 @@ pre-commit install - `test/testdata` and `test/data` are there as we want to test formatting plugins. - `hie-compat` is there as we want to keep its code as close to GHC as possible. -- `hls-tactics-plugin` is there as the main contributor of the plugin (@isovector) does not want auto-formatting. ## Introduction tutorial diff --git a/docs/contributing/plugin-tutorial.md b/docs/contributing/plugin-tutorial.md index 81608122ed..3939e7720c 100644 --- a/docs/contributing/plugin-tutorial.md +++ b/docs/contributing/plugin-tutorial.md @@ -381,7 +381,7 @@ generateLens pId uri minImports (L src imp) ## Wrapping up There's only one haskell code change left to do at this point: "link" the plugin in the `HlsPlugins` HLS module. -However integrating the plugin in haskell-language-server itself will need some changes in config files. The best way is looking for the id (f.e. `hls-tactics-plugin`) of an existing plugin: +However integrating the plugin in haskell-language-server itself will need some changes in config files. The best way is looking for the id (f.e. `hls-class-plugin`) of an existing plugin: - `./cabal*.project` and `./stack*.yaml`: add the plugin package in the `packages` field - `./haskell-language-server.cabal`: add a conditional block with the plugin package dependency - `./.github/workflows/test.yml`: add a block to run the test suite of the plugin diff --git a/docs/features.md b/docs/features.md index 1b26dff066..05b5de40f8 100644 --- a/docs/features.md +++ b/docs/features.md @@ -38,12 +38,6 @@ Provided by: `hls-hlint-plugin` Provides hlint hints as diagnostics. -### Stan hints - -Provided by: `hls-stan-plugin` - -Provides Stan hints as diagnostics. - ### Cabal parse errors and warnings Provided by: `hls-cabal-plugin` @@ -244,24 +238,6 @@ Converts numeric literals to different formats. ![Alternate Number Format Demo](../plugins/hls-alternate-number-format-plugin/HLSAll.gif) -### Add Haddock comments - -Provided by: `hls-haddock-comments-plugin` - -Code action kind: `quickfix` - -Adds Haddock comments for function arguments. - -### Wingman - -Status: Not supported on GHC 9.2 - -Provided by: `hls-tactics-plugin` - -Provides a variety of code actions for interactive code development, see for more details. - -![Wingman Demo](https://user-images.githubusercontent.com/307223/92657198-3d4be400-f2a9-11ea-8ad3-f541c8eea891.gif) - ### Change Type Signature Provided by: `hls-change-type-signature-plugin` diff --git a/docs/support/plugin-support.md b/docs/support/plugin-support.md index 2c9477cd22..aa16132943 100644 --- a/docs/support/plugin-support.md +++ b/docs/support/plugin-support.md @@ -60,10 +60,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-ormolu-plugin` | 2 | | | `hls-rename-plugin` | 2 | | | `hls-stylish-haskell-plugin` | 2 | | -| `hls-tactics-plugin` | 2 | 9.2, 9.4, 9.6 | | `hls-overloaded-record-dot-plugin` | 2 | 8.10, 9.0 | | `hls-floskell-plugin` | 3 | 9.6 | -| `hls-haddock-comments-plugin` | 3 | 9.2, 9.4, 9.6 | -| `hls-stan-plugin` | 3 | 8.6, 9.0, 9.2, 9.4, 9.6 | | `hls-retrie-plugin` | 3 | | | `hls-splice-plugin` | 3 | | diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 99b2462b79..61977c2843 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -79,11 +79,6 @@ flag callHierarchy default: True manual: True -flag haddockComments - description: Enable haddockComments plugin - default: True - manual: True - flag eval description: Enable eval plugin default: True @@ -104,21 +99,11 @@ flag retrie default: True manual: True -flag tactic - description: Enable tactic plugin - default: True - manual: True - flag hlint description: Enable hlint plugin default: True manual: True -flag stan - description: Enable stan plugin - default: True - manual: True - flag moduleName description: Enable moduleName plugin default: True @@ -231,11 +216,6 @@ common callHierarchy build-depends: hls-call-hierarchy-plugin == 2.2.0.0 cpp-options: -Dhls_callHierarchy -common haddockComments - if flag(haddockComments) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-haddock-comments-plugin == 2.2.0.0 - cpp-options: -Dhls_haddockComments - common eval if flag(eval) build-depends: hls-eval-plugin == 2.2.0.0 @@ -256,21 +236,11 @@ common retrie build-depends: hls-retrie-plugin == 2.2.0.0 cpp-options: -Dhls_retrie -common tactic - if flag(tactic) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-tactics-plugin == 2.2.0.0 - cpp-options: -Dhls_tactic - common hlint if flag(hlint) build-depends: hls-hlint-plugin == 2.2.0.0 cpp-options: -Dhls_hlint -common stan - if flag(stan) && (impl(ghc >= 8.10) && impl(ghc < 9.0)) - build-depends: hls-stan-plugin == 2.2.0.0 - cpp-options: -Dhls_stan - common moduleName if flag(moduleName) build-depends: hls-module-name-plugin == 2.2.0.0 @@ -364,14 +334,11 @@ library , cabalfmt , changeTypeSignature , class - , haddockComments , eval , importLens , rename , retrie - , tactic , hlint - , stan , moduleName , pragmas , splice diff --git a/plugins/hls-haddock-comments-plugin/LICENSE b/plugins/hls-haddock-comments-plugin/LICENSE deleted file mode 100644 index 261eeb9e9f..0000000000 --- a/plugins/hls-haddock-comments-plugin/LICENSE +++ /dev/null @@ -1,201 +0,0 @@ - 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-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal deleted file mode 100644 index c8eadd6ad7..0000000000 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ /dev/null @@ -1,72 +0,0 @@ -cabal-version: 2.4 -name: hls-haddock-comments-plugin -version: 2.2.0.0 -synopsis: Haddock comments plugin for Haskell Language Server -description: - Please see the README on GitHub at - -license: Apache-2.0 -license-file: LICENSE -author: Potato Hatsue -maintainer: berberman@yandex.com -category: Development -build-type: Simple -homepage: https://github.com/haskell/haskell-language-server -bug-reports: https://github.com/haskell/haskell-language-server/issues -extra-source-files: - LICENSE - test/testdata/*.hs - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server.git - -library - if impl(ghc >= 9.2) - buildable: False - else - buildable: True - exposed-modules: - Ide.Plugin.HaddockComments - Ide.Plugin.HaddockComments.Data - Ide.Plugin.HaddockComments.Prelude - hs-source-dirs: src - ghc-options: - -Wall -Wno-name-shadowing -Wredundant-constraints - -Wno-unticked-promoted-constructors - - build-depends: - , base >=4.12 && <5 - , containers - , ghc - , ghc-exactprint < 1 - , ghcide == 2.2.0.0 - , hls-plugin-api == 2.2.0.0 - , hls-refactor-plugin - , lsp-types - , text - , unordered-containers - , transformers - , mtl - - default-language: Haskell2010 - default-extensions: - DataKinds - TypeOperators - -test-suite tests - if impl(ghc >= 9.2) - buildable: False - else - buildable: True - 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-haddock-comments-plugin - , hls-test-utils == 2.2.0.0 - , text diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs deleted file mode 100644 index d542f1d0c4..0000000000 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.HaddockComments (descriptor, E.Log) where - -import Control.Monad (join, when) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import qualified Data.Map as Map -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.ExactPrint -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..)) -import qualified Development.IDE.GHC.ExactPrint as E -import Development.IDE.Plugin.CodeAction -import Ide.Plugin.HaddockComments.Data (genForDataDecl) -import Ide.Plugin.HaddockComments.Prelude -import Ide.Types -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) -import Language.Haskell.GHC.ExactPrint.Utils -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types - ------------------------------------------------------------------------------ -descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = mkExactprintPluginDescriptor recorder $ - (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider - } - -codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = diags}) = - do - let noErr = and $ (/= Just DiagnosticSeverity_Error) . _severity <$> diags - nfp = uriToNormalizedFilePath $ toNormalizedUri uri - (join -> pm) <- liftIO $ runAction "HaddockComments.GetAnnotatedParsedSource" ideState $ use GetAnnotatedParsedSource `traverse` nfp - let locDecls = hsmodDecls . unLoc . astA <$> pm - anns = annsA <$> pm - edits = [gen locDecls anns range | noErr, gen <- genList] - pure $ InL [InR $ toAction title uri edit | (Just (title, edit)) <- edits] - -genList :: [Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)] -genList = - [ runGenCommentsSimple genForSig, - runGenComments genForDataDecl - ] - ------------------------------------------------------------------------------ - -runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) -runGenComments GenComments{..} mLocDecls mAnns range - | Just locDecls <- mLocDecls, - Just anns <- mAnns, - [(locDecl, src)] <- [(locDecl, l) | locDecl@(L l _) <- locDecls, range `isIntersectWith` l], - Just range' <- toRange src, - Just (_, (anns', _), _) <- runTransformT anns (updateAnns locDecl), - result <- T.strip . T.pack $ exactPrint locDecl anns' - = Just (title, TextEdit range' result) - | otherwise = Nothing - -runGenCommentsSimple :: GenCommentsSimple -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) -runGenCommentsSimple GenCommentsSimple {..} = runGenComments GenComments { - title = title, - updateAnns = updateAnns - } - where - updateAnns :: LHsDecl GhcPs -> TransformT Maybe () - updateAnns locDecl@(L _ decl) = do - x <- lift $ fromDecl decl - let annKeys = collectKeys x - anns <- getAnnsT - when (null annKeys || not (and $ maybe False isFresh . flip Map.lookup anns <$> annKeys)) $ - lift Nothing - let declKey = mkAnnKey locDecl - anns' = Map.adjust updateDeclAnn declKey $ foldr (Map.adjust updateAnn) anns annKeys - putAnnsT anns' - ------------------------------------------------------------------------------ - -genForSig :: GenCommentsSimple -genForSig = GenCommentsSimple {..} - where - title = "Generate signature comments" - - fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x - fromDecl _ = Nothing - - updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} - updateDeclAnn = cleanPriorComments - - isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] - collectKeys = keyFromTyVar 0 - -#if MIN_VERSION_ghc(9,2,0) - comment = mkComment "-- ^ " (spanAsAnchor noSrcSpan) -#elif MIN_VERSION_ghc(9,0,0) - comment = mkComment "-- ^ " badRealSrcSpan -#else - comment = mkComment "-- ^ " noSrcSpan -#endif - dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] - ------------------------------------------------------------------------------ - -toAction :: T.Text -> Uri -> TextEdit -> CodeAction -toAction title uri edit = CodeAction {..} - where - _title = title - _kind = Just CodeActionKind_QuickFix - _diagnostics = Nothing - _command = Nothing - _changes = Just $ Map.singleton uri [edit] - _documentChanges = Nothing - _edit = Just WorkspaceEdit {..} - _isPreferred = Nothing - _disabled = Nothing - _data_ = Nothing - _changeAnnotations = Nothing - - -toRange :: SrcSpan -> Maybe Range -toRange src - | (RealSrcSpan s _) <- src, - range' <- realSrcSpanToRange s = - Just range' - | otherwise = Nothing - -isIntersectWith :: Range -> SrcSpan -> Bool -isIntersectWith Range {_start, _end} x = isInsideSrcSpan _start x || isInsideSrcSpan _end x - --- clean prior comments, since src span we get from 'LHsDecl' does not include them -cleanPriorComments :: Annotation -> Annotation -cleanPriorComments x = x {annPriorComments = []} - ------------------------------------------------------------------------------ - -keyFromTyVar :: Int -> LHsType GhcPs -> [AnnKey] -#if MIN_VERSION_ghc(9,0,0) --- GHC9 HsFunTy has 4 arguments, we could extract this -keyFromTyVar dep c@(L _ (HsFunTy _ _ x y)) -#else -keyFromTyVar dep c@(L _ (HsFunTy _ x y)) -#endif - | dep < 1 = mkAnnKey c : keyFromTyVar dep x ++ keyFromTyVar dep y - | otherwise = [] -keyFromTyVar dep (L _ t@HsForAllTy {}) = keyFromTyVar dep (hst_body t) -keyFromTyVar dep (L _ t@HsQualTy {}) = keyFromTyVar dep (hst_body t) -keyFromTyVar dep (L _ (HsKindSig _ x _)) = keyFromTyVar dep x -keyFromTyVar dep (L _ (HsParTy _ x)) = keyFromTyVar (succ dep) x -keyFromTyVar dep (L _ (HsBangTy _ _ x)) = keyFromTyVar dep x -keyFromTyVar _ _ = [] - ------------------------------------------------------------------------------ diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs deleted file mode 100644 index 373f2d84ea..0000000000 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Ide.Plugin.HaddockComments.Data - ( genForDataDecl - ) where - -import Control.Monad (unless, when) -import Control.Monad.Trans.Class (lift) -import Data.Data (Data) -import Data.Foldable (for_) -import Data.List (isPrefixOf) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust) -import Development.IDE (realSpan) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Ide.Plugin.HaddockComments.Prelude -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) -import Language.Haskell.GHC.ExactPrint.Utils (mkComment) - -genForDataDecl :: GenComments -genForDataDecl = - GenComments { - title = "Generate haddock comments", - updateAnns = updateDataAnns - } - -updateDataAnns :: LHsDecl GhcPs -> TransformT Maybe () -updateDataAnns decl@(L declLoc (TyClD _ DataDecl {tcdDataDefn = HsDataDefn { dd_cons = cons }})) = do - -- skip if all constructors and fields already have a haddock comment - getAnnsT >>= (\anns -> unless (missingSomeHaddock anns cons) (lift Nothing)) - - -- visit each constructor and field - addHaddockCommentsToList True declLoc (G AnnVbar) cons - for_ cons $ \case - L conLoc ConDeclH98 { con_args = RecCon (L _ fields) } -> addHaddockCommentsToList False conLoc (G AnnComma) fields - _ -> pure () - modifyAnnsT $ Map.adjust (\ann -> ann {annPriorComments = []}) (mkAnnKey decl) -updateDataAnns _ = lift Nothing - --- | Add haddock comments to a list of nodes -addHaddockCommentsToList - :: (Data a, Monad m) - => Bool -- ^ If true, for each node, use previous node in the list as the anchor. Otherwise, use the outer node - -> SrcSpan -- ^ The outer node - -> KeywordId -- ^ The separator between adjacent nodes - -> [Located a] -- ^ The list of nodes. Haddock comments will be added to each of them - -> TransformT m () -addHaddockCommentsToList usePrevNodeAsAnchor outerLoc separator nodes = - -- If you want to understand this function, please first read this page carefully: - -- https://hackage.haskell.org/package/ghc-exactprint-0.6.4/docs/Language-Haskell-GHC-ExactPrint-Delta.html - -- The important part is that for DP(r,c), if r is zero, c is the offset start from the end of the previous node. - -- However, if r is greater than zero, c is the offset start from the 'anchor'. - -- Generally speaking, the 'anchor' is the node that "enclose" the current node. But it's not always the case. - -- Sometimes 'anchor' is just the previous node. It depends on the the syntactic structure. - -- For constructors, the anchor is the previous node (if there is any). - -- For record fields, the anchor is always the constructor they belong to. - for_ (zip nodes (Nothing: fmap Just nodes)) $ \(node, prevNode) -> do - addHaddockCommentToCurrentNode <- fmap (not . fromMaybe True . flip hasHaddock node) getAnnsT - -- We don't add new haddock comments to nodes with existing ones. - when addHaddockCommentToCurrentNode $ do - -- 'sameLineAsPrev' is a flag to determine the inline case, for example: - -- data T = A { a :: Int, b :: String } | B { b :: Double } - -- Note that it's a 'Maybe (Located a)', containing the previous node if the current node - -- and the previous node are on the same line. - -- - -- For the multiline case (which is the most common), we keep the original indentation of each constructor - -- and field. - -- - -- For the inline case, we use the first constructor/field as the base, and align all following items - -- to them. - let sameLineAsPrev = prevNode >>= ( - \prevNode' -> if notSeparatedByLineEnding prevNode' node - then pure prevNode' - else Nothing - ) - -- For the inline case, we need to move the separator to the next line. - -- For constructors, it's vertical bar; for fields, it's comma. - -- The separator is passed in as function argument. - when (isJust sameLineAsPrev) $ modifyAnnsT $ \anns -> - let newSepCol :: Annotation -> Int - newSepCol ann = - if usePrevNodeAsAnchor then 0 else deltaColumn (annEntryDelta ann) - updateSepAnn :: Annotation -> Annotation - updateSepAnn ann = ann {annsDP = - Map.toList . Map.adjust (const $ DP (1, newSepCol ann)) separator . Map.fromList $ annsDP ann} - in flip (maybe anns) prevNode $ \prevNode' -> Map.adjust updateSepAnn (mkAnnKey prevNode') anns - -- Calculate the real column of the anchor - let anchorCol = maybe 0 srcSpanStartCol . realSpan . maybe outerLoc getLoc $ - if usePrevNodeAsAnchor then prevNode else Nothing - -- 'dpCol' is what we will use for the current node's entry delta's column - dpCol <- flip fmap getAnnsT $ \anns -> - case sameLineAsPrev of - Just prevNode' -> - -- If the previous node is the anchor, using 0 as column will make current code align with - -- the previous one. - -- Otherwise, use the column of entry delta of the previous node. - -- The map lookup should not fail. '2' is used as a fallback value to make sure the syntax - -- is correct after the changes. - if usePrevNodeAsAnchor then 0 else maybe 2 (deltaColumn . annEntryDelta) - $ anns Map.!? mkAnnKey prevNode' - -- We subtract the real column to get dp column. - Nothing -> (maybe 2 srcSpanStartCol . realSpan $ getLoc node) - anchorCol - -- Modify the current node - modifyAnnsT $ - let updateCurrent :: Annotation -> Annotation - updateCurrent ann = ann { - -- If there exist non-haddock comments, we simply inherit the first one's delta pos, - -- and move them two lines below, to separate them from our newly added haddock comments - -- Otherwise, inherit the node's entry delta pos. - annPriorComments = case annPriorComments ann of - (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem - _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], - annEntryDelta = DP (1, dpCol) - } - in Map.adjust updateCurrent (mkAnnKey node) - --- | Determine if a list of constructor declarations is missing some haddock comments. -missingSomeHaddock :: Anns -> [LConDecl GhcPs] -> Bool -missingSomeHaddock anns = any $ \lcon@(L _ conDecl) -> case conDecl of - ConDeclH98 { con_args = RecCon (L _ fields) } -> - elem (Just False) $ hasHaddock anns lcon : fmap (hasHaddock anns) fields - _ -> False -- GADT is not supported yet - --- | Returns 'True' if the end of the first node and the start of the second node are on the same line. -notSeparatedByLineEnding :: Located a - -> Located a - -> Bool -notSeparatedByLineEnding (L (RealSrcSpan x _) _) (L (RealSrcSpan y _) _) = - srcLocLine (realSrcSpanEnd x) == srcLocLine (realSrcSpanStart y) -notSeparatedByLineEnding _ _ = False - --- | Empty haddock, suitable for being added to 'annPriorComments' -emptyPriorHaddockComment :: Comment -emptyPriorHaddockComment = mkComment "-- |" -#if MIN_VERSION_ghc(9,0,0) - badRealSrcSpan -#else - noSrcSpan -#endif - --- | Determines the given node has haddock comments attached to it. -hasHaddock :: Data a => Anns -> Located a -> Maybe Bool -hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) - where - key = mkAnnKey node - annHasHaddock ann = - any (matchCommentPrefix priorCommentPrefix . fst) (annPriorComments ann) - || any (matchCommentPrefix followingCommentPrefix . fst) (annFollowingComments ann) - || any (keywordIdIsHaddockComment . fst) (annsDP ann) - --- | Checks if the given 'KeywordId' is a comment, and specifically, a haddock comment. -keywordIdIsHaddockComment :: KeywordId -> Bool -keywordIdIsHaddockComment (AnnComment comment) = any (`isPrefixOf` commentContents comment) (priorCommentPrefix ++ followingCommentPrefix) -keywordIdIsHaddockComment _ = False - -priorCommentPrefix :: [String] -priorCommentPrefix = ["-- |", "{-|", "{- |"] - -followingCommentPrefix :: [String] -followingCommentPrefix = ["-- ^", "{-^", "{- ^"] - -matchCommentPrefix :: [String] -> Comment -> Bool -matchCommentPrefix prefix comment = any (`isPrefixOf` commentContents comment) prefix diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs deleted file mode 100644 index 3bf56e2b61..0000000000 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} - -module Ide.Plugin.HaddockComments.Prelude where -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey, Annotation) - --- | A more generic comments generator -data GenComments = GenComments - { title :: T.Text, - -- | Use 'Maybe' monad to exit early. 'Nothing' means a code action for haddock comments - -- in the given context is not possible. - updateAnns :: LHsDecl GhcPs -> TransformT Maybe () - } - --- | Defines how to generate haddock comments by tweaking annotations of AST --- --- This is left here for compatibility reason, so that we don't break the existing code. -data GenCommentsSimple = forall a. - GenCommentsSimple - { title :: T.Text, - fromDecl :: HsDecl GhcPs -> Maybe a, - collectKeys :: a -> [AnnKey], - isFresh :: Annotation -> Bool, - updateAnn :: Annotation -> Annotation, - updateDeclAnn :: Annotation -> Annotation - } diff --git a/plugins/hls-haddock-comments-plugin/test/Main.hs b/plugins/hls-haddock-comments-plugin/test/Main.hs deleted file mode 100644 index db530d4dd3..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/Main.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -module Main - ( main - ) where - -import Data.Foldable (find) -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import qualified Ide.Plugin.HaddockComments as HaddockComments -import System.FilePath ((<.>), ()) -import Test.Hls - -main :: IO () -main = defaultTestRunner tests - -haddockCommentsPlugin :: PluginTestDescriptor HaddockComments.Log -haddockCommentsPlugin = mkPluginTestDescriptor HaddockComments.descriptor "haddockComments" - -tests :: TestTree -tests = - testGroup - "haddock comments" - [ goldenWithHaddockComments "HigherRankFunction" Signature 4 6, - goldenWithHaddockComments "KindSigFunction" Signature 9 10, - goldenWithHaddockComments "MultivariateFunction" Signature 4 8, - goldenWithHaddockComments "QualFunction" Signature 2 10, - goldenWithHaddockComments "Record" Record 7 2, - goldenWithHaddockComments "Record2" Record 3 6, - goldenWithHaddockComments "InlineRecord" Record 3 20, - expectedNothing "ConstFunction" Signature 2 2, - expectedNothing "StaleFunction" Signature 3 3, - expectedNothing "StaleRecord" Record 4 9 - ] - -goldenWithHaddockComments :: FilePath -> GenCommentsType -> UInt -> UInt -> TestTree -goldenWithHaddockComments fp (toTitle -> expectedTitle) l c = - goldenWithHaskellDoc def haddockCommentsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do - actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c)) - case find ((== Just expectedTitle) . caTitle) actions of - Just (InR x) -> executeCodeAction x - _ -> liftIO $ assertFailure "Unable to find CodeAction" - -expectedNothing :: FilePath -> GenCommentsType -> UInt -> UInt -> TestTree -expectedNothing fp (toTitle -> expectedTitle) l c = testCase fp $ - runSessionWithServer def haddockCommentsPlugin testDataDir $ do - doc <- openDoc (fp <.> "hs") "haskell" - titles <- mapMaybe caTitle <$> getCodeActions doc (Range (Position l c) (Position l $ succ c)) - liftIO $ expectedTitle `notElem` titles @? "Unexpected CodeAction" - -data GenCommentsType = Signature | Record - -toTitle :: GenCommentsType -> Text -toTitle Signature = "Generate signature comments" -toTitle Record = "Generate haddock comments" - -caTitle :: (Command |? CodeAction) -> Maybe Text -caTitle (InR CodeAction {_title}) = Just _title -caTitle _ = Nothing - -testDataDir :: String -testDataDir = "test" "testdata" - diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/ConstFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/ConstFunction.hs deleted file mode 100644 index b5cc0d8246..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/ConstFunction.hs +++ /dev/null @@ -1,4 +0,0 @@ -module ConstFunction where - -f :: Int -f = 233 diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.expected.hs deleted file mode 100644 index 30aa4db284..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module HigherRankFunction where - -f :: (forall a. [a] -> Int) -- ^ - -> [b] -- ^ - -> [c] -- ^ - -> (Int, Int) -f l xs ys = (l xs, l ys) diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.hs deleted file mode 100644 index 7ed1de1e1b..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/HigherRankFunction.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module HigherRankFunction where - -f :: (forall a. [a] -> Int) -> [b] -> [c] -> (Int, Int) -f l xs ys = (l xs, l ys) diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs deleted file mode 100644 index cff893ddcb..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Record2 where - --- | A record -data Record = -- | - A { -- | - a :: Int - , -- | - b :: String } - | -- | - B { -- | - bb :: Double } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs deleted file mode 100644 index c2f48dd98e..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Record2 where - --- | A record -data Record = A { a :: Int , b :: String } | B { bb :: Double } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.expected.hs deleted file mode 100644 index de82c9bf7a..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} - -module KindSigFunction where - -import GHC.TypeLits - -f :: KnownSymbol k => (proxy :: k -> *) k -- ^ - -> String -f = symbolVal diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.hs deleted file mode 100644 index e4ea78c83c..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/KindSigFunction.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} - -module KindSigFunction where - -import GHC.TypeLits - -f :: KnownSymbol k => (proxy :: k -> *) k -> String -f = symbolVal diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.expected.hs deleted file mode 100644 index 73bd53da1c..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -module MultivariateFunction where - --- | some --- docs -f :: a -- ^ - -> b -- ^ - -> c -- ^ - -> d -- ^ - -> e -- ^ - -> f -- ^ - -> g -- ^ - -> g -f _ _ _ _ _ _ x = x diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.hs deleted file mode 100644 index a487d05ec9..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/MultivariateFunction.hs +++ /dev/null @@ -1,6 +0,0 @@ -module MultivariateFunction where - --- | some --- docs -f :: a -> b -> c -> d -> e -> f -> g -> g -f _ _ _ _ _ _ x = x diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.expected.hs deleted file mode 100644 index e91170424b..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module QualFunction where - -f :: (Show a, Show b) => a -- ^ - -> b -- ^ - -> String -f x y = show x <> show y diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.hs deleted file mode 100644 index a50ba560bc..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/QualFunction.hs +++ /dev/null @@ -1,4 +0,0 @@ -module QualFunction where - -f :: (Show a, Show b) => a -> b -> String -f x y = show x <> show y diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs deleted file mode 100644 index 9ac5afcf73..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Record where - --- | A record -data Record a b c d e f - = -- | - RecordA - { -- | - a :: a, - -- | - b :: b - } - | -- | - Pair c d - | -- | - RecordB - { -- | - c :: e, - -- | - d :: f - } - | -- | - Void diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record.hs deleted file mode 100644 index 9071b8363c..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/Record.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Record where - --- | A record -data Record a b c d e f - = RecordA - { a :: a, - b :: b - } - | Pair c d - | RecordB - { c :: e, - d :: f - } - | Void diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs deleted file mode 100644 index c5968e5353..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Record2 where - --- | A record -data Record = -- | - RecordA - { -- | - a :: Int - , -- | - b :: String - } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs deleted file mode 100644 index 49ee7ba383..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Record2 where - --- | A record -data Record = RecordA - { a :: Int - , b :: String - } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/StaleFunction.hs b/plugins/hls-haddock-comments-plugin/test/testdata/StaleFunction.hs deleted file mode 100644 index 266a23403e..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/StaleFunction.hs +++ /dev/null @@ -1,6 +0,0 @@ -module StaleFunction where - -f :: a - -> b -- ^ ... - -> c -> c -f _ _ c = c diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs b/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs deleted file mode 100644 index 3b639bafae..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs +++ /dev/null @@ -1,9 +0,0 @@ -module StaleRecord where - -data Record = - -- | ... - Record - { a :: Int -- ^ aaa - , -- | bbb - b :: String - } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/hie.yaml b/plugins/hls-haddock-comments-plugin/test/testdata/hie.yaml deleted file mode 100644 index 824558147d..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/hie.yaml +++ /dev/null @@ -1,3 +0,0 @@ -cradle: - direct: - arguments: [] diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/test/testdata/QualFunction.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/test/testdata/QualFunction.expected.hs deleted file mode 100644 index e91170424b..0000000000 --- a/plugins/hls-haddock-comments-plugin/test/testdata/test/testdata/QualFunction.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module QualFunction where - -f :: (Show a, Show b) => a -- ^ - -> b -- ^ - -> String -f x y = show x <> show y diff --git a/plugins/hls-stan-plugin/LICENSE b/plugins/hls-stan-plugin/LICENSE deleted file mode 100644 index 261eeb9e9f..0000000000 --- a/plugins/hls-stan-plugin/LICENSE +++ /dev/null @@ -1,201 +0,0 @@ - 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-stan-plugin/hls-stan-plugin.cabal b/plugins/hls-stan-plugin/hls-stan-plugin.cabal deleted file mode 100644 index a9dfad2634..0000000000 --- a/plugins/hls-stan-plugin/hls-stan-plugin.cabal +++ /dev/null @@ -1,83 +0,0 @@ -cabal-version: 2.4 -name: hls-stan-plugin -version: 2.2.0.0 -synopsis: Stan integration plugin with Haskell Language Server -description: - Please see the README on GitHub at - -license: Apache-2.0 -license-file: LICENSE -author: The Haskell IDE Team -maintainer: uhbif19@gmail.com -copyright: The Haskell IDE Team -category: Development -build-type: Simple -extra-source-files: - LICENSE - test/testdata/*.hs - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server.git - -flag pedantic - description: Enable -Werror - default: False - manual: True - -library - if impl(ghc < 8.10) || impl(ghc >= 9.0) - buildable: False - else - buildable: True - exposed-modules: Ide.Plugin.Stan - hs-source-dirs: src - build-depends: - base - , containers - , data-default - , deepseq - , hashable - , hls-plugin-api - , ghc - , ghcide - , lsp-types - , text - , transformers - , unordered-containers - , stan - - default-language: Haskell2010 - default-extensions: - LambdaCase - NamedFieldPuns - DeriveGeneric - TypeFamilies - StandaloneDeriving - DuplicateRecordFields - OverloadedStrings - -test-suite test - if impl(ghc < 8.10) || impl(ghc >= 9.0) - buildable: False - else - buildable: True - 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: - aeson - , base - , containers - , filepath - , hls-stan-plugin - , hls-plugin-api - , hls-test-utils == 2.2.0.0 - , lens - , lsp-types - , text - default-extensions: - NamedFieldPuns - OverloadedStrings diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs deleted file mode 100644 index 732d94066e..0000000000 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Ide.Plugin.Stan (descriptor, Log) where - -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) -import Data.Default -import Data.Foldable (toList) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as Map -import Data.Maybe (fromJust, mapMaybe) -import qualified Data.Text as T -import Development.IDE -import Development.IDE (Diagnostic (_codeDescription)) -import Development.IDE.Core.Rules (getHieFile, - getSourceFileSource) -import Development.IDE.Core.RuleTypes (HieAstResult (..)) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HieASTs (HieASTs), - RealSrcSpan (..), mkHieFile', - mkRealSrcLoc, mkRealSrcSpan, - runHsc, srcSpanEndCol, - srcSpanEndLine, - srcSpanStartCol, - srcSpanStartLine, tcg_exports) -import Development.IDE.GHC.Error (realSrcSpanToRange) -import GHC.Generics (Generic) -import HieTypes (HieASTs, HieFile) -import Ide.Plugin.Config -import Ide.Types (PluginDescriptor (..), - PluginId, configHasDiagnostics, - defaultConfigDescriptor, - defaultPluginDescriptor, - pluginEnabledConfig) -import qualified Language.LSP.Protocol.Types as LSP -import Stan.Analysis (Analysis (..), runAnalysis) -import Stan.Category (Category (..)) -import Stan.Core.Id (Id (..)) -import Stan.Inspection (Inspection (..)) -import Stan.Inspection.All (inspectionsIds, inspectionsMap) -import Stan.Observation (Observation (..)) - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginRules = rules recorder plId - , pluginConfigDescriptor = defaultConfigDescriptor - { configHasDiagnostics = True - } - } - -newtype Log = LogShake Shake.Log deriving (Show) - -instance Pretty Log where - pretty = \case - LogShake log -> pretty log - -data GetStanDiagnostics = GetStanDiagnostics - deriving (Eq, Show, Generic) - -instance Hashable GetStanDiagnostics - -instance NFData GetStanDiagnostics - -type instance RuleResult GetStanDiagnostics = () - -rules :: Recorder (WithPriority Log) -> PluginId -> Rules () -rules recorder plId = do - define (cmapWithPrio LogShake recorder) $ - \GetStanDiagnostics file -> do - config <- getPluginConfigAction plId - if pluginEnabledConfig plcDiagnosticsOn config then do - maybeHie <- getHieFile file - case maybeHie of - Nothing -> return ([], Nothing) - Just hie -> do - let enabledInspections = HM.fromList [(LSP.fromNormalizedFilePath file, inspectionsIds)] - -- This should use Cabal config for extensions and Stan config for inspection preferences is the future - let analysis = runAnalysis Map.empty enabledInspections [] [hie] - return (analysisToDiagnostics file analysis, Just ()) - else return ([], Nothing) - - action $ do - files <- getFilesOfInterestUntracked - void $ uses GetStanDiagnostics $ HM.keys files - where - analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic] - analysisToDiagnostics file = mapMaybe (observationToDianostic file) . toList . analysisObservations - observationToDianostic :: NormalizedFilePath -> Observation -> Maybe FileDiagnostic - observationToDianostic file Observation {observationSrcSpan, observationInspectionId} = - do - inspection <- HM.lookup observationInspectionId inspectionsMap - let - -- Looking similar to Stan CLI output - -- We do not use `prettyShowInspection` cuz Id is redundant here - -- `prettyShowSeverity` and `prettyShowCategory` would contain color - -- codes and are replaced, too - message :: T.Text - message = - T.unlines $ - [ " ✲ Name: " <> inspectionName inspection, - " ✲ Description: " <> inspectionDescription inspection, - " ✲ Severity: " <> (T.pack $ show $ inspectionSeverity inspection), - " ✲ Category: " <> T.intercalate " " - (map (("#" <>) . unCategory) $ toList $ inspectionCategory inspection), - "Possible solutions:" - ] - ++ map (" - " <>) (inspectionSolution inspection) - return ( file, - ShowDiag, - LSP.Diagnostic - { _range = realSrcSpanToRange observationSrcSpan, - _severity = Just LSP.DiagnosticSeverity_Hint, - _code = Just (LSP.InR $ unId (inspectionId inspection)), - _source = Just "stan", - _message = message, - _relatedInformation = Nothing, - _tags = Nothing, - _codeDescription = Nothing, - _data_ = Nothing - } - ) diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs deleted file mode 100644 index 6c27e399d3..0000000000 --- a/plugins/hls-stan-plugin/test/Main.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Main - ( main, - ) -where - -import Control.Lens ((^.)) -import Control.Monad (void) -import Data.List (find) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Ide.Plugin.Stan as Stan -import qualified Language.LSP.Protocol.Lens as L -import System.FilePath -import Test.Hls - -main :: IO () -main = defaultTestRunner tests - -tests :: TestTree -tests = - testGroup - "stan suggestions" - [ testCase "provides diagnostics" $ - runStanSession "" $ do - doc <- openDoc "test.hs" "haskell" - diags@(reduceDiag : _) <- waitForDiagnosticsFromSource doc "stan" - liftIO $ do - length diags @?= 1 - reduceDiag ^. L.range @?= Range (Position 0 0) (Position 3 19) - reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Hint - let expectedPrefix = " ✲ Name: " - assertBool "" $ T.isPrefixOf expectedPrefix (reduceDiag ^. L.message) - reduceDiag ^. L.source @?= Just "stan" - return () - ] - -testDir :: FilePath -testDir = "test/testdata" - -stanPlugin :: PluginTestDescriptor Stan.Log -stanPlugin = mkPluginTestDescriptor Stan.descriptor "stan" - -runStanSession :: FilePath -> Session a -> IO a -runStanSession subdir = - failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) diff --git a/plugins/hls-stan-plugin/test/testdata/.hie/Main.hie b/plugins/hls-stan-plugin/test/testdata/.hie/Main.hie deleted file mode 100644 index 0c7367ab46..0000000000 Binary files a/plugins/hls-stan-plugin/test/testdata/.hie/Main.hie and /dev/null differ diff --git a/plugins/hls-stan-plugin/test/testdata/hie.yaml b/plugins/hls-stan-plugin/test/testdata/hie.yaml deleted file mode 100644 index 577238428b..0000000000 --- a/plugins/hls-stan-plugin/test/testdata/hie.yaml +++ /dev/null @@ -1,4 +0,0 @@ -cradle: - direct: - arguments: - - test.hs \ No newline at end of file diff --git a/plugins/hls-stan-plugin/test/testdata/test.hs b/plugins/hls-stan-plugin/test/testdata/test.hs deleted file mode 100644 index 7a184b01f0..0000000000 --- a/plugins/hls-stan-plugin/test/testdata/test.hs +++ /dev/null @@ -1,4 +0,0 @@ -orderPair x y - | x < y = 1 - | x > y = 2 - | otherwise = 3 diff --git a/plugins/hls-tactics-plugin/COMMANDS.md b/plugins/hls-tactics-plugin/COMMANDS.md deleted file mode 100644 index 7bdda86cef..0000000000 --- a/plugins/hls-tactics-plugin/COMMANDS.md +++ /dev/null @@ -1,673 +0,0 @@ -# Wingman Metaprogram Command Reference - -## application - -arguments: none. -non-deterministic. - -> Apply any function in the hypothesis that returns the correct type. - - -### Example - -Given: - -```haskell -f :: a -> b - -_ :: b -``` - -running `application` will produce: - -```haskell -f (_ :: a) -``` - -## apply - -arguments: single reference. -deterministic. - -> Apply the given function from *local* scope. - - -### Example - -Given: - -```haskell -f :: a -> b - -_ :: b -``` - -running `apply f` will produce: - -```haskell -f (_ :: a) -``` - -## assume - -arguments: single reference. -deterministic. - -> Use the given term from the hypothesis, unifying it with the current goal - - -### Example - -Given: - -```haskell -some_a_val :: a - -_ :: a -``` - -running `assume some_a_val` will produce: - -```haskell -some_a_val -``` - -## assumption - -arguments: none. -non-deterministic. - -> Use any term in the hypothesis that can unify with the current goal. - - -### Example - -Given: - -```haskell -some_a_val :: a - -_ :: a -``` - -running `assumption` will produce: - -```haskell -some_a_val -``` - -## auto - -arguments: none. -non-deterministic. - -> Repeatedly attempt to split, destruct, apply functions, and recurse in an attempt to fill the hole. - - -### Example - -Given: - -```haskell -f :: a -> b -g :: b -> c - -_ :: a -> c -``` - -running `auto` will produce: - -```haskell -g . f -``` - -## binary - -arguments: none. -deterministic. - -> Produce a hole for a two-parameter function, as well as holes for its arguments. The argument holes have the same type but are otherwise unconstrained, and will be solved before the function. - - -### Example - -> In the example below, the variable `a` is free, and will unify to the resulting extract from any subsequent tactic. - -Given: - -```haskell -_ :: Int -``` - -running `binary` will produce: - -```haskell -(_3 :: a -> a -> Int) (_1 :: a) (_2 :: a) -``` - -## cata - -arguments: single reference. -deterministic. - -> Destruct the given term, recursing on every resulting binding. - - -### Example - -> Assume we're called in the context of a function `f.` - -Given: - -```haskell -x :: (a, a) - -_ -``` - -running `cata x` will produce: - -```haskell -case x of - (a1, a2) -> - let a1_c = f a1 - a2_c = f a2 - in _ -``` - -## collapse - -arguments: none. -deterministic. - -> Collapse every term in scope with the same type as the goal. - - -### Example - -Given: - -```haskell -a1 :: a -a2 :: a -a3 :: a - -_ :: a -``` - -running `collapse` will produce: - -```haskell -(_ :: a -> a -> a -> a) a1 a2 a3 -``` - -## ctor - -arguments: single reference. -deterministic. - -> Use the given data constructor. - - -### Example - -Given: - -```haskell -_ :: Maybe a -``` - -running `ctor Just` will produce: - -```haskell -Just (_ :: a) -``` - -## destruct - -arguments: single reference. -deterministic. - -> Pattern match on the argument. - - -### Example - -Given: - -```haskell -a :: Bool - -_ -``` - -running `destruct a` will produce: - -```haskell -case a of - False -> _ - True -> _ -``` - -## destruct_all - -arguments: none. -deterministic. - -> Pattern match on every function parameter, in original binding order. - - -### Example - -> Assume `a` and `b` were bound via `f a b = _`. - -Given: - -```haskell -a :: Bool -b :: Maybe Int - -_ -``` - -running `destruct_all` will produce: - -```haskell -case a of - False -> case b of - Nothing -> _ - Just i -> _ - True -> case b of - Nothing -> _ - Just i -> _ -``` - -## homo - -arguments: single reference. -deterministic. - -> Pattern match on the argument, and fill the resulting hole in with the same data constructor. - - -### Example - -> Only applicable when the type constructor of the argument is the same as that of the hole. - -Given: - -```haskell -e :: Either a b - -_ :: Either x y -``` - -running `homo e` will produce: - -```haskell -case e of - Left a -> Left (_ :: x) - Right b -> Right (_ :: y) -``` - -## idiom - -arguments: tactic. -deterministic. - -> Lift a tactic into idiom brackets. - - -### Example - -Given: - -```haskell -f :: a -> b -> Int - -_ :: Maybe Int -``` - -running `idiom (apply f)` will produce: - -```haskell -f <$> (_ :: Maybe a) <*> (_ :: Maybe b) -``` - -## intro - -arguments: single binding. -deterministic. - -> Construct a lambda expression, binding an argument with the given name. - - -### Example - -Given: - -```haskell -_ :: a -> b -> c -> d -``` - -running `intro aye` will produce: - -```haskell -\aye -> (_ :: b -> c -> d) -``` - -## intros - -arguments: variadic binding. -deterministic. - -> Construct a lambda expression, using the specific names if given, generating unique names otherwise. When no arguments are given, all of the function arguments will be bound; otherwise, this tactic will bind only enough to saturate the given names. Extra names are ignored. - - -### Example - -Given: - -```haskell -_ :: a -> b -> c -> d -``` - -running `intros` will produce: - -```haskell -\a b c -> (_ :: d) -``` - -### Example - -Given: - -```haskell -_ :: a -> b -> c -> d -``` - -running `intros aye` will produce: - -```haskell -\aye -> (_ :: b -> c -> d) -``` - -### Example - -Given: - -```haskell -_ :: a -> b -> c -> d -``` - -running `intros x y z w` will produce: - -```haskell -\x y z -> (_ :: d) -``` - -## let - -arguments: variadic binding. -deterministic. - -> Create let-bindings for each binder given to this tactic. - - -### Example - -Given: - -```haskell -_ :: x -``` - -running `let a b c` will produce: - -```haskell -let a = _1 :: a - b = _2 :: b - c = _3 :: c - in (_4 :: x) - -``` - -## nested - -arguments: single reference. -non-deterministic. - -> Nest the given function (in module scope) with itself arbitrarily many times. NOTE: The resulting function is necessarily unsaturated, so you will likely need `with_arg` to use this tactic in a saturated context. - - -### Example - -Given: - -```haskell -_ :: [(Int, Either Bool a)] -> [(Int, Either Bool b)] -``` - -running `nested fmap` will produce: - -```haskell -fmap (fmap (fmap _)) -``` - -## obvious - -arguments: none. -non-deterministic. - -> Produce a nullary data constructor for the current goal. - - -### Example - -Given: - -```haskell -_ :: [a] -``` - -running `obvious` will produce: - -```haskell -[] -``` - -## pointwise - -arguments: tactic. -deterministic. - -> Restrict the hypothesis in the holes of the given tactic to align up with the top-level bindings. This will ensure, eg, that the first hole can see only terms that came from the first position in any terms destructed from the top-level bindings. - - -### Example - -> In the context of `f (a1, b1) (a2, b2) = _`. The resulting first hole can see only 'a1' and 'a2', and the second, only 'b1' and 'b2'. - -Given: - -```haskell -_ -``` - -running `pointwise (use mappend)` will produce: - -```haskell -mappend _ _ -``` - -## recursion - -arguments: none. -deterministic. - -> Fill the current hole with a call to the defining function. - - -### Example - -> In the context of `foo (a :: Int) (b :: b) = _`: - -Given: - -```haskell -_ -``` - -running `recursion` will produce: - -```haskell -foo (_ :: Int) (_ :: b) -``` - -## sorry - -arguments: none. -deterministic. - -> "Solve" the goal by leaving a hole. - - -### Example - -Given: - -```haskell -_ :: b -``` - -running `sorry` will produce: - -```haskell -_ :: b -``` - -## split - -arguments: none. -non-deterministic. - -> Produce a data constructor for the current goal. - - -### Example - -Given: - -```haskell -_ :: Either a b -``` - -running `split` will produce: - -```haskell -Right (_ :: b) -``` - -## try - -arguments: tactic. -non-deterministic. - -> Simultaneously run and do not run a tactic. Subsequent tactics will bind on both states. - - -### Example - -Given: - -```haskell -f :: a -> b - -_ :: b -``` - -running `try (apply f)` will produce: - -```haskell --- BOTH of: - -f (_ :: a) - --- and - -_ :: b - -``` - -## unary - -arguments: none. -deterministic. - -> Produce a hole for a single-parameter function, as well as a hole for its argument. The argument holes are completely unconstrained, and will be solved before the function. - - -### Example - -> In the example below, the variable `a` is free, and will unify to the resulting extract from any subsequent tactic. - -Given: - -```haskell -_ :: Int -``` - -running `unary` will produce: - -```haskell -(_2 :: a -> Int) (_1 :: a) -``` - -## use - -arguments: single reference. -deterministic. - -> Apply the given function from *module* scope. - - -### Example - -> `import Data.Char (isSpace)` - -Given: - -```haskell -_ :: Bool -``` - -running `use isSpace` will produce: - -```haskell -isSpace (_ :: Char) -``` - -## with_arg - -arguments: none. -deterministic. - -> Fill the current goal with a function application. This can be useful when you'd like to fill in the argument before the function, or when you'd like to use a non-saturated function in a saturated context. - - -### Example - -> Where `a` is a new unifiable type variable. - -Given: - -```haskell -_ :: r -``` - -running `with_arg` will produce: - -```haskell -(_2 :: a -> r) (_1 :: a) -``` - diff --git a/plugins/hls-tactics-plugin/LICENSE b/plugins/hls-tactics-plugin/LICENSE deleted file mode 100644 index 261eeb9e9f..0000000000 --- a/plugins/hls-tactics-plugin/LICENSE +++ /dev/null @@ -1,201 +0,0 @@ - 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-tactics-plugin/README.md b/plugins/hls-tactics-plugin/README.md deleted file mode 100644 index 6f4171196c..0000000000 --- a/plugins/hls-tactics-plugin/README.md +++ /dev/null @@ -1,162 +0,0 @@ -

-Wingman for Haskell -

- -

 

- -# Wingman for Haskell - -[![Hackage](https://img.shields.io/hackage/v/hls-tactics-plugin.svg?logo=haskell&label=hls-tactics-plugin)](https://hackage.haskell.org/package/hls-tactics-plugin) - -"Focus on the important stuff; delegate the rest" - - -## Dedication - -> There's a lot of automation that can happen that isn't a replacement of -> humans, but of mind-numbing behavior. -> -> --Stewart Butterfield - - -## Overview - -Wingman writes the boring, auxiliary code, so you don't have to. Generate -functions from type signatures, and intelligently complete holes. - - -## Getting Started - -Wingman for Haskell is enabled by default in all [official release of Haskell -Language Server.][hls] Just hover over a typed hole, run the "Attempt to -fill hole" code action, *et voila!* - -[hls]: https://github.com/haskell/haskell-language-server/releases - - -## Usage - -When enabled, Wingman for Haskell will remove HLS support for hole-fit code -actions. These code actions are provided by GHC and make typechecking extremely -slow in the presence of typed holes. Because Wingman relies so heavily on typed -holes, these features are in great tension. - -The solution: we just remove the hole-fit actions. If you'd prefer to use these -actions, you can get them back by compiling HLS without the Wingman plugin. - - -## Editor Configuration - -### Enabling Jump to Hole - -Set the `haskell.plugin.tactics.config.hole_severity` config option to `4`, or -`hint` if your editor uses a GUI for its configuration. This has the potential -to negatively impact performance --- please holler if you notice any appreciable -slowdown by enabling this option. - - -### coc.nvim - -The following vimscript maps Wingman code-actions to your leader key: - -```viml -" use [h and ]h to navigate between holes -nnoremap [h :call CocActionAsync('diagnosticPrevious', 'hint') -nnoremap ]h :call JumpToNextHole() - -" d to perform a pattern match, n to fill a hole -nnoremap d :set operatorfunc=WingmanDestructg@l -nnoremap n :set operatorfunc=WingmanFillHoleg@l -nnoremap r :set operatorfunc=WingmanRefineg@l -nnoremap c :set operatorfunc=WingmanUseCtorg@l -nnoremap a :set operatorfunc=WingmanDestructAllg@l - - -function! s:JumpToNextHole() - call CocActionAsync('diagnosticNext', 'hint') -endfunction - -function! s:GotoNextHole() - " wait for the hole diagnostics to reload - sleep 500m - " and then jump to the next hole - normal 0 - call JumpToNextHole() -endfunction - -function! s:WingmanRefine(type) - call CocAction('codeAction', a:type, ['refactor.wingman.refine']) - call GotoNextHole() -endfunction - -function! s:WingmanDestruct(type) - call CocAction('codeAction', a:type, ['refactor.wingman.caseSplit']) - call GotoNextHole() -endfunction - -function! s:WingmanDestructAll(type) - call CocAction('codeAction', a:type, ['refactor.wingman.splitFuncArgs']) - call GotoNextHole() -endfunction - -function! s:WingmanFillHole(type) - call CocAction('codeAction', a:type, ['refactor.wingman.fillHole']) - call GotoNextHole() -endfunction - -function! s:WingmanUseCtor(type) - call CocAction('codeAction', a:type, ['refactor.wingman.useConstructor']) - call GotoNextHole() -endfunction -``` - -### Emacs - -When using Emacs, wingman actions should be available out-of-the-box and -show up e.g. when using `M-x helm-lsp-code-actions RET` provided by -[helm-lsp](https://github.com/emacs-lsp/helm-lsp) or as popups via -[lsp-ui-sideline](https://emacs-lsp.github.io/lsp-ui/#lsp-ui-sideline). - -Additionally, if you want to bind wingman actions directly to specific -keybindings or use them from Emacs Lisp, you can do so like this: - -``` emacs-lisp -;; will define elisp functions for the given lsp code actions, prefixing the -;; given function names with "lsp" -(lsp-make-interactive-code-action wingman-fill-hole "refactor.wingman.fillHole") -(lsp-make-interactive-code-action wingman-case-split "refactor.wingman.caseSplit") -(lsp-make-interactive-code-action wingman-refine "refactor.wingman.refine") -(lsp-make-interactive-code-action wingman-split-func-args "refactor.wingman.spltFuncArgs") -(lsp-make-interactive-code-action wingman-use-constructor "refactor.wingman.useConstructor") - -;; example key bindings -(define-key haskell-mode-map (kbd "C-c d") #'lsp-wingman-case-split) -(define-key haskell-mode-map (kbd "C-c n") #'lsp-wingman-fill-hole) -(define-key haskell-mode-map (kbd "C-c r") #'lsp-wingman-refine) -(define-key haskell-mode-map (kbd "C-c c") #'lsp-wingman-use-constructor) -(define-key haskell-mode-map (kbd "C-c a") #'lsp-wingman-split-func-args) -``` - -### Other Editors - -Please open a PR if you have a working configuration! - - -## Features - -* [Type-directed code synthesis][auto], including pattern matching and recursion -* [Automatic case-splitting][case] --- just run the "Case split on " code action -* [Smart next actions][next], for those times it can't read your mind - -[auto]: https://haskellwingman.dev/foldr.gif -[case]: https://haskellwingman.dev/case-split.gif -[next]: https://haskellwingman.dev/intros.gif - - -## Support - -Please consider [pledging on Patreon][patreon] to support the project and get -access to cutting-edge features. - -[patreon]: https://www.patreon.com/wingman_for_haskell - diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal deleted file mode 100644 index 935b08bece..0000000000 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ /dev/null @@ -1,200 +0,0 @@ -cabal-version: 2.4 -category: Development -name: hls-tactics-plugin -version: 2.2.0.0 -synopsis: Wingman plugin for Haskell Language Server -description: - Please see the README on GitHub at -author: Sandy Maguire, Reed Mullanix -maintainer: sandy@sandymaguire.me -copyright: Sandy Maguire, Reed Mullanix -homepage: https://haskellwingman.dev -bug-reports: https://github.com/haskell/haskell-language-server/issues -license: Apache-2.0 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - new/src/**/*.hs-boot - old/src/**/*.hs-boot - new/test/golden/*.cabal - new/test/golden/*.hs - new/test/golden/*.yaml - old/test/golden/*.cabal - old/test/golden/*.hs - old/test/golden/*.yaml - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server.git - -flag pedantic - description: Enable -Werror - default: False - manual: True - -library - if impl(ghc >= 9.2.1) - buildable: False - else - buildable: True - - if impl(ghc >= 9.2.1) - hs-source-dirs: new/src - else - hs-source-dirs: old/src - exposed-modules: - Ide.Plugin.Tactic - Refinery.Future - Wingman.AbstractLSP - Wingman.AbstractLSP.TacticActions - Wingman.AbstractLSP.Types - Wingman.Auto - Wingman.CaseSplit - Wingman.CodeGen - Wingman.CodeGen.Utils - Wingman.Context - Wingman.Debug - Wingman.EmptyCase - Wingman.GHC - Wingman.Judgements - Wingman.Judgements.SYB - Wingman.Judgements.Theta - Wingman.KnownStrategies - Wingman.KnownStrategies.QuickCheck - Wingman.LanguageServer - Wingman.LanguageServer.Metaprogram - Wingman.LanguageServer.TacticProviders - Wingman.Machinery - Wingman.Metaprogramming.Lexer - Wingman.Metaprogramming.Parser - Wingman.Metaprogramming.Parser.Documentation - Wingman.Metaprogramming.ProofState - Wingman.Naming - Wingman.Plugin - Wingman.Range - Wingman.Simplify - Wingman.StaticPlugin - Wingman.Tactics - Wingman.Types - - ghc-options: - -Wall -Wno-name-shadowing -Wredundant-constraints - -Wno-unticked-promoted-constructors - - if flag(pedantic) - ghc-options: -Werror - - build-depends: - , aeson - , base >=4.12 && <5 - , containers - , deepseq - , directory - , extra >=1.7.8 - , filepath - , fingertree - , generic-lens - , ghc - , ghc-boot-th - , ghc-exactprint - , ghc-source-gen ^>=0.4.1 - , ghcide == 2.2.0.0 - , hls-graph - , hls-plugin-api == 2.2.0.0 - , hls-refactor-plugin - , hyphenation - , lens - , lsp - , megaparsec >=8 && <10 - , mtl - , parser-combinators - , prettyprinter - , refinery ^>=0.4 - , retrie >=0.1.1.0 - , syb - , unagi-chan - , text - , transformers - , unordered-containers - - default-language: Haskell2010 - default-extensions: - DataKinds - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NumDecimals - OverloadedLabels - PatternSynonyms - ScopedTypeVariables - TypeApplications - TypeOperators - ViewPatterns - -test-suite tests - if impl(ghc >= 9.2.1) - buildable: False - else - buildable: True - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - AutoTupleSpec - CodeAction.AutoSpec - CodeAction.DestructAllSpec - CodeAction.DestructPunSpec - CodeAction.DestructSpec - CodeAction.IntrosSpec - CodeAction.IntroDestructSpec - CodeAction.RefineSpec - CodeAction.RunMetaprogramSpec - CodeAction.UseDataConSpec - CodeLens.EmptyCaseSpec - ProviderSpec - Spec - UnificationSpec - Utils - - if impl(ghc >= 9.2.1) - hs-source-dirs: new/test - else - hs-source-dirs: old/test - ghc-options: - -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N - - build-depends: - , aeson - , base - , containers - , deepseq - , directory - , filepath - , ghc - , ghcide - , hls-plugin-api - , hls-tactics-plugin - , hls-test-utils == 2.2.0.0 - , hspec - , hspec-expectations - , lens - , lsp-types - , mtl - , QuickCheck - , tasty-hspec - , tasty-hunit - , text - - build-tool-depends: hspec-discover:hspec-discover -any - default-language: Haskell2010 diff --git a/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs deleted file mode 100644 index cf326ee653..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs +++ /dev/null @@ -1,5 +0,0 @@ --- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log(..)) where - -import Wingman.Plugin - diff --git a/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs b/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs deleted file mode 100644 index e829672831..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------- --- | Things that belong in the future release of refinery v5. -module Refinery.Future - ( runStreamingTacticT - , hoistListT - , consume - ) where - -import Control.Applicative -import Control.Monad (ap, (>=>)) -import Control.Monad.State.Lazy (runStateT) -import Control.Monad.Trans -import Data.Either (isRight) -import Data.Functor ((<&>)) -import Data.Tuple (swap) -import Refinery.ProofState -import Refinery.Tactic.Internal - - - -hoistElem :: Functor m => (forall x. m x -> n x) -> Elem m a -> Elem n a -hoistElem _ Done = Done -hoistElem f (Next a lt) = Next a $ hoistListT f lt - - -hoistListT :: Functor m => (forall x. m x -> n x) -> ListT m a -> ListT n a -hoistListT f t = ListT $ f $ fmap (hoistElem f) $ unListT t - - -consume :: Monad m => ListT m a -> (a -> m ()) -> m () -consume lt f = unListT lt >>= \case - Done -> pure () - Next a lt' -> f a >> consume lt' f - - -newHole :: MonadExtract meta ext err s m => s -> m (s, (meta, ext)) -newHole = fmap swap . runStateT hole - -runStreamingTacticT :: (MonadExtract meta ext err s m) => TacticT jdg ext err s m () -> jdg -> s -> ListT m (Either err (Proof s meta jdg ext)) -runStreamingTacticT t j s = streamProofs s $ fmap snd $ proofState t j - -data Elem m a - = Done - | Next a (ListT m a) - deriving stock Functor - - -point :: Applicative m => a -> Elem m a -point a = Next a $ ListT $ pure Done - -newtype ListT m a = ListT { unListT :: m (Elem m a) } - -cons :: (Applicative m) => a -> ListT m a -> ListT m a -cons x xs = ListT $ pure $ Next x xs - -instance Functor m => Functor (ListT m) where - fmap f (ListT xs) = ListT $ xs <&> \case - Done -> Done - Next a xs -> Next (f a) (fmap f xs) - -instance (Monad m) => Applicative (ListT m) where - pure = return - (<*>) = ap - -instance (Monad m) => Alternative (ListT m) where - empty = ListT $ pure Done - (ListT xs) <|> (ListT ys) = - ListT $ xs >>= \case - Done -> ys - Next x xs -> pure (Next x (xs <|> ListT ys)) - -instance (Monad m) => Monad (ListT m) where - return a = cons a empty - (ListT xs) >>= k = - ListT $ xs >>= \case - Done -> pure Done - Next x xs -> unListT $ k x <|> (xs >>= k) - - -instance MonadTrans ListT where - lift m = ListT $ fmap (\x -> Next x empty) m - - -interleaveT :: (Monad m) => Elem m a -> Elem m a -> Elem m a -interleaveT xs ys = - case xs of - Done -> ys - Next x xs -> Next x $ ListT $ fmap (interleaveT ys) $ unListT xs - --- ys <&> \case --- Done -> Next x xs --- Next y ys -> Next x (cons y (interleaveT xs ys)) - -force :: (Monad m) => Elem m a -> m [a] -force = \case - Done -> pure [] - Next x xs' -> (x:) <$> (unListT xs' >>= force) - -ofList :: Monad m => [a] -> Elem m a -ofList [] = Done -ofList (x:xs) = Next x $ ListT $ pure $ ofList xs - -streamProofs :: forall ext err s m goal meta. (MonadExtract meta ext err s m) => s -> ProofStateT ext ext err s m goal -> ListT m (Either err (Proof s meta goal ext)) -streamProofs s p = ListT $ go s [] pure p - where - go :: s -> [(meta, goal)] -> (err -> m err) -> ProofStateT ext ext err s m goal -> m (Elem m (Either err (Proof s meta goal ext))) - go s goals _ (Subgoal goal k) = do - (s', (meta, h)) <- newHole s - -- Note [Handler Reset]: - -- We reset the handler stack to avoid the handlers leaking across subgoals. - -- This would happen when we had a handler that wasn't followed by an error call. - -- pair >> goal >>= \g -> (handler_ $ \_ -> traceM $ "Handling " <> show g) <|> failure "Error" - -- We would see the "Handling a" message when solving for b. - go s' (goals ++ [(meta, goal)]) pure $ k h - go s goals handlers (Effect m) = m >>= go s goals handlers - go s goals handlers (Stateful f) = - let (s', p) = f s - in go s' goals handlers p - go s goals handlers (Alt p1 p2) = - unListT $ ListT (go s goals handlers p1) <|> ListT (go s goals handlers p2) - go s goals handlers (Interleave p1 p2) = - interleaveT <$> go s goals handlers p1 <*> go s goals handlers p2 - go s goals handlers (Commit p1 p2) = do - solns <- force =<< go s goals handlers p1 - if any isRight solns then pure $ ofList solns else go s goals handlers p2 - go _ _ _ Empty = pure Done - go _ _ handlers (Failure err _) = do - annErr <- handlers err - pure $ point $ Left annErr - go s goals handlers (Handle p h) = - -- Note [Handler ordering]: - -- If we have multiple handlers in scope, then we want the handlers closer to the error site to - -- run /first/. This allows the handlers up the stack to add their annotations on top of the - -- ones lower down, which is the behavior that we desire. - -- IE: for @handler f >> handler g >> failure err@, @g@ ought to be run before @f@. - go s goals (h >=> handlers) p - go s goals _ (Axiom ext) = pure $ point $ Right (Proof ext s goals) - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs deleted file mode 100644 index 000e2f3740..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RecordWildCards #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.AbstractLSP (installInteractions) where - -import Control.Monad (void) -import Control.Monad.IO.Class -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) -import qualified Data.Aeson as A -import Data.Coerce -import Data.Foldable (traverse_) -import Data.Monoid (Last (..)) -import qualified Data.Text as T -import Data.Traversable (for) -import Data.Tuple.Extra (uncurry3) -import Development.IDE (IdeState) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource)) -import qualified Ide.Plugin.Config as Plugin -import Ide.Types -import Language.LSP.Server (LspM, sendRequest, getClientCapabilities) -import qualified Language.LSP.Types as LSP -import Language.LSP.Types hiding (CodeLens, CodeAction) -import Wingman.AbstractLSP.Types -import Wingman.EmptyCase (fromMaybeT) -import Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) -import Wingman.StaticPlugin (enableQuasiQuotes) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are --- self-contained request/response pairs that abstract over the LSP, and --- provide a unified interface for doing interesting things, without needing to --- dive into the underlying API too directly. -installInteractions - :: [Interaction] - -> PluginDescriptor IdeState - -> PluginDescriptor IdeState -installInteractions is desc = - let plId = pluginId desc - in desc - { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is - , pluginHandlers = pluginHandlers desc <> buildHandlers is - } - - ------------------------------------------------------------------------------- --- | Extract 'PluginHandlers' from 'Interaction's. -buildHandlers - :: [Interaction] - -> PluginHandlers IdeState -buildHandlers cs = - flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> - case c_makeCommand c of - SynthesizeCodeAction k -> - mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k - SynthesizeCodeLens k -> - mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k - - ------------------------------------------------------------------------------- --- | Extract a 'PluginCommand' from an 'Interaction'. -buildCommand - :: PluginId - -> Interaction - -> PluginCommand IdeState -buildCommand plId (Interaction (c :: Continuation sort target b)) = - PluginCommand - { commandId = toCommandId $ c_sort c - , commandDesc = T.pack "" - , commandFunc = runContinuation plId c - } - - ------------------------------------------------------------------------------- --- | Boilerplate for running a 'Continuation' as part of an LSP command. -runContinuation - :: forall sort a b - . IsTarget a - => PluginId - -> Continuation sort a b - -> CommandFunction IdeState (FileContext, b) -runContinuation plId cont state (fc, b) = do - fromMaybeT - (Left $ ResponseError - { _code = InternalError - , _message = T.pack "TODO(sandy)" - , _xdata = Nothing - } ) $ do - env@LspEnv{..} <- buildEnv state plId fc - nfp <- getNfp $ fc_uri le_fileContext - let stale a = runStaleIde "runContinuation" state nfp a - args <- fetchTargetArgs @a env - res <- c_runCommand cont env args fc b - - -- This block returns a maybe error. - fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $ - for res $ \case - ErrorMessages errs -> do - traverse_ showUserFacingMessage errs - pure Nothing - RawEdit edits -> do - sendEdits edits - pure Nothing - GraftEdit gr -> do - ccs <- lift getClientCapabilities - TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of - Left errs -> - pure $ Just $ ResponseError - { _code = InternalError - , _message = T.pack $ show errs - , _xdata = Nothing - } - Right edits -> do - sendEdits edits - pure Nothing - - ------------------------------------------------------------------------------- --- | Push a 'WorkspaceEdit' to the client. -sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () -sendEdits edits = - void $ lift $ - sendRequest - SWorkspaceApplyEdit - (ApplyWorkspaceEditParams Nothing edits) - (const $ pure ()) - - ------------------------------------------------------------------------------- --- | Push a 'UserFacingMessage' to the client. -showUserFacingMessage - :: UserFacingMessage - -> MaybeT (LspM Plugin.Config) () -showUserFacingMessage ufm = - void $ lift $ showLspMessage $ mkShowMessageParams ufm - - ------------------------------------------------------------------------------- --- | Build an 'LspEnv', which contains the majority of things we need to know --- in a 'Continuation'. -buildEnv - :: IdeState - -> PluginId - -> FileContext - -> MaybeT (LspM Plugin.Config) LspEnv -buildEnv state plId fc = do - cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId - nfp <- getNfp $ fc_uri fc - dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp - pure $ LspEnv - { le_ideState = state - , le_pluginId = plId - , le_dflags = dflags - , le_config = cfg - , le_fileContext = fc - } - - ------------------------------------------------------------------------------- --- | Lift a 'Continuation' into an LSP CodeAction. -codeActionProvider - :: forall target sort b - . (IsContinuationSort sort, A.ToJSON b, IsTarget target) - => sort - -> ( LspEnv - -> TargetArgs target - -> MaybeT (LspM Plugin.Config) [(Metadata, b)] - ) - -> PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider sort k state plId - (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do - fromMaybeT (Right $ List []) $ do - let fc = FileContext - { fc_uri = uri - , fc_range = Just $ unsafeMkCurrent range - } - env <- buildEnv state plId fc - args <- fetchTargetArgs @target env - actions <- k env args - pure - $ Right - $ List - $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions - - ------------------------------------------------------------------------------- --- | Lift a 'Continuation' into an LSP CodeLens. -codeLensProvider - :: forall target sort b - . (IsContinuationSort sort, A.ToJSON b, IsTarget target) - => sort - -> ( LspEnv - -> TargetArgs target - -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] - ) - -> PluginMethodHandler IdeState TextDocumentCodeLens -codeLensProvider sort k state plId - (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do - fromMaybeT (Right $ List []) $ do - let fc = FileContext - { fc_uri = uri - , fc_range = Nothing - } - env <- buildEnv state plId fc - args <- fetchTargetArgs @target env - actions <- k env args - pure - $ Right - $ List - $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions - - ------------------------------------------------------------------------------- --- | Build a 'LSP.CodeAction'. -makeCodeAction - :: (A.ToJSON b, IsContinuationSort sort) - => PluginId - -> FileContext - -> sort - -> Metadata - -> b - -> LSP.CodeAction -makeCodeAction plId fc sort (Metadata title kind preferred) b = - let cmd_id = toCommandId sort - cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)] - in LSP.CodeAction - { _title = title - , _kind = Just kind - , _diagnostics = Nothing - , _isPreferred = Just preferred - , _disabled = Nothing - , _edit = Nothing - , _command = Just cmd - , _xdata = Nothing - } - - ------------------------------------------------------------------------------- --- | Build a 'LSP.CodeLens'. -makeCodeLens - :: (A.ToJSON b, IsContinuationSort sort) - => PluginId - -> sort - -> FileContext - -> Range - -> Metadata - -> b - -> LSP.CodeLens -makeCodeLens plId sort fc range (Metadata title _ _) b = - let fc' = fc { fc_range = Just $ unsafeMkCurrent range } - cmd_id = toCommandId sort - cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)] - in LSP.CodeLens - { _range = range - , _command = Just cmd - , _xdata = Nothing - } - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs deleted file mode 100644 index bb30f27b02..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.AbstractLSP.TacticActions where - -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (mapMaybeT) -import Data.Foldable -import Data.Maybe (listToMaybe) -import Data.Proxy -import Development.IDE hiding (rangeToRealSrcSpan) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Generics.SYB.GHC (mkBindListT, everywhereM') -import Wingman.AbstractLSP.Types -import Wingman.CaseSplit -import Wingman.GHC (liftMaybe, isHole, pattern AMatch) -import Wingman.Judgements (jNeedsToBindArgs) -import Wingman.LanguageServer (runStaleIde) -import Wingman.LanguageServer.TacticProviders -import Wingman.Machinery (runTactic, scoreSolution) -import Wingman.Range -import Wingman.Types -import Development.IDE.Core.Service (getIdeOptionsIO) -import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting)) - - ------------------------------------------------------------------------------- --- | An 'Interaction' for a 'TacticCommand'. -makeTacticInteraction - :: TacticCommand - -> Interaction -makeTacticInteraction cmd = - Interaction $ Continuation @_ @HoleTarget cmd - (SynthesizeCodeAction $ \env hj -> do - pure $ commandProvider cmd $ - TacticProviderData - { tpd_lspEnv = env - , tpd_jdg = hj_jdg hj - , tpd_hole_sort = hj_hole_sort hj - } - ) - $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do - nfp <- getNfp fc_uri - let stale a = runStaleIde "tacticCmd" le_ideState nfp a - - let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range - TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - pm_span <- liftMaybe $ mapAgeFrom pmmap span - IdeOptions{optTesting = IdeTesting isTesting} <- - liftIO $ getIdeOptionsIO (shakeExtras le_ideState) - - let t = commandTactic cmd var_name - timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds - - liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case - Left err -> - pure - $ pure - $ ErrorMessages - $ pure - $ mkUserFacingMessage err - Right rtr -> - case rtr_extract rtr of - L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) -> - pure - $ addTimeoutMessage rtr - $ pure - $ ErrorMessages - $ pure NothingToDo - _ -> do - for_ (rtr_other_solns rtr) $ \soln -> do - traceMX "other solution" $ syn_val soln - traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) [] - traceMX "solution" $ rtr_extract rtr - pure - $ addTimeoutMessage rtr - $ pure - $ GraftEdit - $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr - - -addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult] -addTimeoutMessage rtr = mappend - [ ErrorMessages $ pure TimedOut - | rtr_timed_out rtr - ] - - ------------------------------------------------------------------------------- --- | The number of microseconds in a second -seconds :: Num a => a -seconds = 1e6 - - ------------------------------------------------------------------------------- --- | Transform some tactic errors into a 'UserFacingMessage'. -mkUserFacingMessage :: [TacticError] -> UserFacingMessage -mkUserFacingMessage errs - | elem OutOfGas errs = NotEnoughGas -mkUserFacingMessage [] = NothingToDo -mkUserFacingMessage _ = TacticErrors - - ------------------------------------------------------------------------------- --- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly --- deals with top-level holes, in which we might need to fiddle with the --- 'Match's that bind variables. -graftHole - :: SrcSpan - -> RunTacticResults - -> Graft (Either String) ParsedSource -graftHole span rtr - | _jIsTopHole (rtr_jdg rtr) - = genericGraftWithSmallestM - (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span - $ \dflags matches -> - everywhereM' - $ mkBindListT $ \ix -> - graftDecl dflags span ix $ \name pats -> - splitToDecl - (case not $ jNeedsToBindArgs (rtr_jdg rtr) of - -- If the user has explicitly bound arguments, use the - -- fixity they wrote. - True -> matchContextFixity . m_ctxt . unLoc - =<< listToMaybe matches - -- Otherwise, choose based on the name of the function. - False -> Nothing - ) - (occName name) - $ iterateSplit - $ mkFirstAgda pats - $ unLoc - $ rtr_extract rtr -graftHole span rtr - = graft span - $ rtr_extract rtr - - ------------------------------------------------------------------------------- --- | Keep a fixity if one was present in the 'HsMatchContext'. -matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity -matchContextFixity (FunRhs _ l _) = Just l -matchContextFixity _ = Nothing - - ------------------------------------------------------------------------------- --- | Helper function to route 'mergeFunBindMatches' into the right place in an --- AST --- correctly dealing with inserting into instance declarations. -graftDecl - :: DynFlags - -> SrcSpan - -> Int - -> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs) - -> LMatch GhcPs (LHsExpr GhcPs) - -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)] -graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _)) - | dst `isSubspanOf` src = do - L _ dec <- annotateDecl dflags $ make_decl name pats - case dec of - ValD _ FunBind{ fun_matches = MG { mg_alts = L _ alts@(first_match : _)} - } -> do - -- For whatever reason, ExactPrint annotates newlines to the ends of - -- case matches and type signatures, but only allows us to insert - -- them at the beginning of those things. Thus, we need want to - -- insert a preceding newline (done in 'annotateDecl') on all - -- matches, except for the first one --- since it gets its newline - -- from the line above. - when (ix == 0) $ - setPrecedingLinesT first_match 0 0 - pure alts - _ -> lift $ Left "annotateDecl didn't produce a funbind" -graftDecl _ _ _ _ x = pure $ pure x - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs deleted file mode 100644 index 750bdfaa2d..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.AbstractLSP.Types where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT) -import qualified Data.Aeson as A -import Data.Text (Text) -import Development.IDE (IdeState) -import Development.IDE.GHC.ExactPrint (Graft) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (Target) -import GHC.Generics (Generic) -import qualified Ide.Plugin.Config as Plugin -import Ide.Types hiding (Config) -import Language.LSP.Server (LspM) -import Language.LSP.Types hiding (CodeLens, CodeAction) -import Wingman.LanguageServer (judgementForHole) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | An 'Interaction' is an existential 'Continuation', which handles both --- sides of the request/response interaction for LSP. -data Interaction where - Interaction - :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b) - => Continuation sort target b - -> Interaction - - ------------------------------------------------------------------------------- --- | Metadata for a command. Used by both code actions and lenses, though for --- lenses, only 'md_title' is currently used. -data Metadata - = Metadata - { md_title :: Text - , md_kind :: CodeActionKind - , md_preferred :: Bool - } - deriving stock (Eq, Show) - - ------------------------------------------------------------------------------- --- | Whether we're defining a CodeAction or CodeLens. -data SynthesizeCommand a b - = SynthesizeCodeAction - ( LspEnv - -> TargetArgs a - -> MaybeT (LspM Plugin.Config) [(Metadata, b)] - ) - | SynthesizeCodeLens - ( LspEnv - -> TargetArgs a - -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] - ) - - ------------------------------------------------------------------------------- --- | Transform a "continuation sort" into a 'CommandId'. -class IsContinuationSort a where - toCommandId :: a -> CommandId - -instance IsContinuationSort CommandId where - toCommandId = id - -instance IsContinuationSort Text where - toCommandId = CommandId - - ------------------------------------------------------------------------------- --- | Ways a 'Continuation' can resolve. -data ContinuationResult - = -- | Produce some error messages. - ErrorMessages [UserFacingMessage] - -- | Produce an explicit 'WorkspaceEdit'. - | RawEdit WorkspaceEdit - -- | Produce a 'Graft', corresponding to a transformation of the current - -- AST. - | GraftEdit (Graft (Either String) ParsedSource) - - ------------------------------------------------------------------------------- --- | A 'Continuation' is a single object corresponding to an action that users --- can take via LSP. It generalizes codeactions and codelenses, allowing for --- a significant amount of code reuse. --- --- Given @Continuation sort target payload@: --- --- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions --- rather than working directly with text. This functionality is driven via --- 'IsContinuationSort'. --- --- the @target@ is used to fetch data from LSP on both sides of the --- request/response barrier. For example, you can use it to resolve what node --- in the AST the incoming range refers to. This functionality is driven via --- 'IsTarget'. --- --- the @payload@ is used for data you'd explicitly like to send from the --- request to the response. It's like @target@, but only gets computed once. --- This is beneficial if you can do it, but requires that your data is --- serializable via JSON. -data Continuation sort target payload = Continuation - { c_sort :: sort - , c_makeCommand :: SynthesizeCommand target payload - , c_runCommand - :: LspEnv - -> TargetArgs target - -> FileContext - -> payload - -> MaybeT (LspM Plugin.Config) [ContinuationResult] - } - - ------------------------------------------------------------------------------- --- | What file are we looking at, and what bit of it? -data FileContext = FileContext - { fc_uri :: Uri - , fc_range :: Maybe (Tracked 'Current Range) - -- ^ For code actions, this is 'Just'. For code lenses, you'll get - -- a 'Nothing' in the request, and a 'Just' in the response. - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (A.ToJSON, A.FromJSON) - - ------------------------------------------------------------------------------- --- | Everything we need to resolve continuations. -data LspEnv = LspEnv - { le_ideState :: IdeState - , le_pluginId :: PluginId - , le_dflags :: DynFlags - , le_config :: Config - , le_fileContext :: FileContext - } - - ------------------------------------------------------------------------------- --- | Extract some information from LSP, so it can be passed to the requests and --- responses of a 'Continuation'. -class IsTarget t where - type TargetArgs t - fetchTargetArgs - :: LspEnv - -> MaybeT (LspM Plugin.Config) (TargetArgs t) - ------------------------------------------------------------------------------- --- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given --- range is an HsExpr hole. It gives continuations access to the resulting --- tactic judgement. -data HoleTarget = HoleTarget - deriving stock (Eq, Ord, Show, Enum, Bounded) - -getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath -getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri - -instance IsTarget HoleTarget where - type TargetArgs HoleTarget = HoleJudgment - fetchTargetArgs LspEnv{..} = do - let FileContext{..} = le_fileContext - range <- MaybeT $ pure fc_range - nfp <- getNfp fc_uri - mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs deleted file mode 100644 index 3748af1e5b..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs +++ /dev/null @@ -1,32 +0,0 @@ - -module Wingman.Auto where - -import Control.Monad.Reader.Class (asks) -import Control.Monad.State (gets) -import qualified Data.Set as S -import Refinery.Tactic -import Wingman.Judgements -import Wingman.KnownStrategies -import Wingman.Machinery (tracing, getCurrentDefinitions) -import Wingman.Tactics -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Automatically solve a goal. -auto :: TacticsM () -auto = do - jdg <- goal - skolems <- gets ts_skolems - gas <- asks $ cfg_auto_gas . ctxConfig - current <- getCurrentDefinitions - traceMX "goal" jdg - traceMX "ctx" current - traceMX "skolems" skolems - commit knownStrategies - . tracing "auto" - . localTactic (auto' gas) - . disallowing RecursiveCall - . S.fromList - $ fmap fst current - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs deleted file mode 100644 index 373fc9b23b..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Wingman.CaseSplit - ( mkFirstAgda - , iterateSplit - , splitToDecl - ) where - -import Data.Bool (bool) -import Data.Data -import Data.Generics -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.GHC.Compat -import GHC.Exts (IsString (fromString)) -import GHC.SourceGen (funBindsWithFixity, match, wildP) -import Wingman.GHC -import Wingman.Types - - - ------------------------------------------------------------------------------- --- | Construct an 'AgdaMatch' from patterns in scope (should be the LHS of the --- match) and a body. -mkFirstAgda :: [Pat GhcPs] -> HsExpr GhcPs -> AgdaMatch -mkFirstAgda pats (Lambda pats' body) = mkFirstAgda (pats <> pats') body -mkFirstAgda pats body = AgdaMatch pats body - - ------------------------------------------------------------------------------- --- | Transform an 'AgdaMatch' whose body is a case over a bound pattern, by --- splitting it into multiple matches: one for each alternative of the case. -agdaSplit :: AgdaMatch -> [AgdaMatch] -agdaSplit (AgdaMatch pats (Case (HsVar _ (L _ var)) matches)) - -- Ensure the thing we're destructing is actually a pattern that's been - -- bound. - | containsVar var pats - = do - (pat, body) <- matches - -- TODO(sandy): use an at pattern if necessary - pure $ AgdaMatch (rewriteVarPat var pat pats) $ unLoc body -agdaSplit x = [x] - - ------------------------------------------------------------------------------- --- | Replace unused bound patterns with wild patterns. -wildify :: AgdaMatch -> AgdaMatch -wildify (AgdaMatch pats body) = - let make_wild = bool id (wildifyT (allOccNames body)) $ not $ containsHole body - in AgdaMatch (make_wild pats) body - - ------------------------------------------------------------------------------- --- | Helper function for 'wildify'. -wildifyT :: Data a => Set OccName -> a -> a -wildifyT (S.map occNameString -> used) = everywhere $ mkT $ \case - VarPat _ (L _ var) | S.notMember (occNameString $ occName var) used -> wildP - (x :: Pat GhcPs) -> x - - ------------------------------------------------------------------------------- --- | Determine whether the given 'RdrName' exists as a 'VarPat' inside of @a@. -containsVar :: Data a => RdrName -> a -> Bool -containsVar name = everything (||) $ - mkQ False (\case - VarPat _ (L _ var) -> eqRdrName name var - (_ :: Pat GhcPs) -> False - ) - `extQ` \case - HsRecField lbl _ True -> eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl - (_ :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> False - - ------------------------------------------------------------------------------- --- | Replace a 'VarPat' with the given @'Pat' GhcPs@. -rewriteVarPat :: Data a => RdrName -> Pat GhcPs -> a -> a -rewriteVarPat name rep = everywhere $ - mkT (\case - VarPat _ (L _ var) | eqRdrName name var -> rep - (x :: Pat GhcPs) -> x - ) - `extT` \case - HsRecField lbl _ True - | eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl - -> HsRecField lbl (toPatCompat rep) False - (x :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> x - - ------------------------------------------------------------------------------- --- | Construct an 'HsDecl' from a set of 'AgdaMatch'es. -splitToDecl - :: Maybe LexicalFixity - -> OccName -- ^ The name of the function - -> [AgdaMatch] - -> LHsDecl GhcPs -splitToDecl fixity name ams = do - traceX "fixity" fixity $ - noLoc $ - funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do - AgdaMatch pats body <- ams - pure $ match pats body - - ------------------------------------------------------------------------------- --- | Sometimes 'agdaSplit' exposes another opportunity to do 'agdaSplit'. This --- function runs it a few times, hoping it will find a fixpoint. -iterateSplit :: AgdaMatch -> [AgdaMatch] -iterateSplit am = - let iterated = iterate (agdaSplit =<<) $ pure am - in fmap wildify . (!! 5) $ iterated - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs deleted file mode 100644 index 322a6f5b8c..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.CodeGen - ( module Wingman.CodeGen - , module Wingman.CodeGen.Utils - ) where - - -import Control.Lens ((%~), (<>~), (&)) -import Control.Monad.Except -import Control.Monad.Reader (ask) -import Control.Monad.State -import Data.Bifunctor (second) -import Data.Bool (bool) -import Data.Functor ((<&>)) -import Data.Generics.Labels () -import Data.List -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat -import GHC.Exts -import GHC.SourceGen (occNameToStr) -import GHC.SourceGen.Binds -import GHC.SourceGen.Expr -import GHC.SourceGen.Overloaded -import GHC.SourceGen.Pat -import Wingman.CodeGen.Utils -import Wingman.GHC -import Wingman.Judgements -import Wingman.Judgements.Theta -import Wingman.Machinery -import Wingman.Naming -import Wingman.Types - - -destructMatches - :: Bool - -> (ConLike -> Judgement -> Rule) - -- ^ How to construct each match - -> Maybe OccName - -- ^ Scrutinee - -> CType - -- ^ Type being destructed - -> Judgement - -> RuleM (Synthesized [RawMatch]) --- TODO(sandy): In an ideal world, this would be the same codepath as --- 'destructionFor'. Make sure to change that if you ever change this. -destructMatches use_field_puns f scrut t jdg = do - let hy = jEntireHypothesis jdg - g = jGoal jdg - case tacticsGetDataCons $ unCType t of - Nothing -> cut -- throwError $ GoalMismatch "destruct" g - Just (dcs, apps) -> - fmap unzipTrace $ for dcs $ \dc -> do - let con = RealDataCon dc - ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps - -- We explicitly do not need to add the method hypothesis to - -- #syn_scoped - method_hy = foldMap evidenceToHypothesis ev - args = conLikeInstOrigArgTys' con apps - ctx <- ask - - let names_in_scope = hyNamesInScope hy - names = mkManyGoodNames (hyNamesInScope hy) args - (names', destructed) = - mkDestructPat (bool Nothing (Just names_in_scope) use_field_puns) con names - - let hy' = patternHypothesis scrut con jdg - $ zip names' - $ coerce args - j = withNewCoercions (evidenceToCoercions ev) - $ introduce ctx hy' - $ introduce ctx method_hy - $ withNewGoal g jdg - ext <- f con j - pure $ ext - & #syn_trace %~ rose ("match " <> show dc <> " {" <> intercalate ", " (fmap show names') <> "}") - . pure - & #syn_scoped <>~ hy' - & #syn_val %~ match [destructed] . unLoc - - ------------------------------------------------------------------------------- --- | Generate just the 'Match'es for a case split on a specific type. -destructionFor :: Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)] --- TODO(sandy): In an ideal world, this would be the same codepath as --- 'destructMatches'. Make sure to change that if you ever change this. -destructionFor hy t = do - case tacticsGetDataCons t of - Nothing -> Nothing - Just ([], _) -> Nothing - Just (dcs, apps) -> do - for dcs $ \dc -> do - let con = RealDataCon dc - args = conLikeInstOrigArgTys' con apps - names = mkManyGoodNames (hyNamesInScope hy) args - pure - . noLoc - . Match - noExtField - CaseAlt - [toPatCompat $ snd $ mkDestructPat Nothing con names] - . GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_") - . noLoc - $ EmptyLocalBinds noExtField - - - ------------------------------------------------------------------------------- --- | Produces a pattern for a data con and the names of its fields. -mkDestructPat :: Maybe (S.Set OccName) -> ConLike -> [OccName] -> ([OccName], Pat GhcPs) -mkDestructPat already_in_scope con names - | RealDataCon dcon <- con - , isTupleDataCon dcon = - (names, tuple pat_args) - | fields@(_:_) <- zip (conLikeFieldLabels con) names - , Just in_scope <- already_in_scope = - let (names', rec_fields) = - unzip $ fields <&> \(label, name) -> do - let label_occ = mkVarOccFS $ flLabel label - case S.member label_occ in_scope of - -- We have a shadow, so use the generated name instead - True -> - (name,) $ noLoc $ - HsRecField - (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ) - (noLoc $ bvar' name) - False - -- No shadow, safe to use a pun - False -> - (label_occ,) $ noLoc $ - HsRecField - (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ) - (noLoc $ bvar' label_occ) - True - - in (names', ) - $ ConPatIn (noLoc $ Unqual $ occName $ conLikeName con) - $ RecCon - $ HsRecFields rec_fields Nothing - | otherwise = - (names, ) $ infixifyPatIfNecessary con $ - conP - (coerceName $ conLikeName con) - pat_args - where - pat_args = fmap bvar' names - - -infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs -infixifyPatIfNecessary dcon x - | conLikeIsInfix dcon = - case x of - ConPatIn op (PrefixCon [lhs, rhs]) -> - ConPatIn op $ InfixCon lhs rhs - y -> y - | otherwise = x - - - -unzipTrace :: [Synthesized a] -> Synthesized [a] -unzipTrace = sequenceA - - --- | Essentially same as 'dataConInstOrigArgTys' in GHC, --- but only accepts universally quantified types as the second arguments --- and automatically introduces existentials. --- --- NOTE: The behaviour depends on GHC's 'dataConInstOrigArgTys'. --- We need some tweaks if the compiler changes the implementation. -conLikeInstOrigArgTys' - :: ConLike - -- ^ 'DataCon'structor - -> [Type] - -- ^ /Universally/ quantified type arguments to a result type. - -- It /MUST NOT/ contain any dictionaries, coercion and existentials. - -- - -- For example, for @MkMyGADT :: b -> MyGADT a c@, we - -- must pass @[a, c]@ as this argument but not @b@, as @b@ is an existential. - -> [Type] - -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument. -conLikeInstOrigArgTys' con uniTys = - let exvars = conLikeExTys con - in fmap scaledThing $ conLikeInstOrigArgTys con $ - uniTys ++ fmap mkTyVarTy exvars - -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys' - -- unifies the second argument with DataCon's universals followed by existentials. - -- If the definition of 'dataConInstOrigArgTys' changes, - -- this place must be changed accordingly. - - -conLikeExTys :: ConLike -> [TyCoVar] -conLikeExTys (RealDataCon d) = dataConExTyCoVars d -conLikeExTys (PatSynCon p) = patSynExTys p - -patSynExTys :: PatSyn -> [TyCoVar] -patSynExTys ps = patSynExTyVars ps - - ------------------------------------------------------------------------------- --- | Combinator for performing case splitting, and running sub-rules on the --- resulting matches. - -destruct' :: Bool -> (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule -destruct' use_field_puns f hi jdg = do - when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic - let term = hi_name hi - ext - <- destructMatches - use_field_puns - f - (Just term) - (hi_type hi) - $ disallowing AlreadyDestructed (S.singleton term) jdg - pure $ ext - & #syn_trace %~ rose ("destruct " <> show term) . pure - & #syn_val %~ noLoc . case' (var' term) - - ------------------------------------------------------------------------------- --- | Combinator for performing case splitting, and running sub-rules on the --- resulting matches. -destructLambdaCase' :: Bool -> (ConLike -> Judgement -> Rule) -> Judgement -> Rule -destructLambdaCase' use_field_puns f jdg = do - when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic - let g = jGoal jdg - case splitFunTy_maybe (unCType g) of -#if __GLASGOW_HASKELL__ >= 900 - Just (_multiplicity, arg, _) | isAlgType arg -> -#else - Just (arg, _) | isAlgType arg -> -#endif - fmap (fmap noLoc lambdaCase) <$> - destructMatches use_field_puns f Nothing (CType arg) jdg - _ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g - - ------------------------------------------------------------------------------- --- | Construct a data con with subgoals for each field. -buildDataCon - :: Bool -- Should we blacklist destruct? - -> Judgement - -> ConLike -- ^ The data con to build - -> [Type] -- ^ Type arguments for the data con - -> RuleM (Synthesized (LHsExpr GhcPs)) -buildDataCon should_blacklist jdg dc tyapps = do - args <- case dc of - RealDataCon dc' -> do - let (skolems', theta, args) = dataConInstSig dc' tyapps - modify $ \ts -> - evidenceToSubst (foldMap mkEvidence theta) ts - & #ts_skolems <>~ S.fromList skolems' - pure args - _ -> - -- If we have a 'PatSyn', we can't continue, since there is no - -- 'dataConInstSig' equivalent for 'PatSyn's. I don't think this is - -- a fundamental problem, but I don't know enough about the GHC internals - -- to implement it myself. - -- - -- Fortunately, this isn't an issue in practice, since 'PatSyn's are - -- never in the hypothesis. - cut -- throwError $ TacticPanic "Can't build Pattern constructors yet" - ext - <- fmap unzipTrace - $ traverse ( \(arg, n) -> - newSubgoal - . filterSameTypeFromOtherPositions dc n - . bool id blacklistingDestruct should_blacklist - . flip withNewGoal jdg - $ CType arg - ) $ zip args [0..] - pure $ ext - & #syn_trace %~ rose (show dc) . pure - & #syn_val %~ mkCon dc tyapps - - ------------------------------------------------------------------------------- --- | Make a function application, correctly handling the infix case. -mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs -mkApply occ (lhs : rhs : more) - | isSymOcc occ - = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more -mkApply occ args = noLoc $ foldl' (@@) (var' occ) args - - ------------------------------------------------------------------------------- --- | Run a tactic over each term in the given 'Hypothesis', binding the results --- of each in a let expression. -letForEach - :: (OccName -> OccName) -- ^ How to name bound variables - -> (HyInfo CType -> TacticsM ()) -- ^ The tactic to run - -> Hypothesis CType -- ^ Terms to generate bindings for - -> Judgement -- ^ The goal of original hole - -> RuleM (Synthesized (LHsExpr GhcPs)) -letForEach rename solve (unHypothesis -> hy) jdg = do - case hy of - [] -> newSubgoal jdg - _ -> do - ctx <- ask - let g = jGoal jdg - terms <- fmap sequenceA $ for hy $ \hi -> do - let name = rename $ hi_name hi - let generalized_let_ty = CType alphaTy - res <- tacticToRule (withNewGoal generalized_let_ty jdg) $ solve hi - pure $ fmap ((name,) . unLoc) res - let hy' = fmap (g <$) $ syn_val terms - matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms - g <- fmap (fmap unLoc) $ newSubgoal $ introduce ctx (userHypothesis hy') jdg - pure $ fmap noLoc $ let' <$> matches <*> g - - ------------------------------------------------------------------------------- --- | Let-bind the given occname judgement pairs. -nonrecLet - :: [(OccName, Judgement)] - -> Judgement - -> RuleM (Synthesized (LHsExpr GhcPs)) -nonrecLet occjdgs jdg = do - occexts <- traverse newSubgoal $ fmap snd occjdgs - ctx <- ask - ext <- newSubgoal - $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs) jdg - pure $ fmap noLoc $ - let' - <$> traverse - (\(occ, ext) -> valBind (occNameToStr occ) <$> fmap unLoc ext) - (zip (fmap fst occjdgs) occexts) - <*> fmap unLoc ext - - ------------------------------------------------------------------------------- --- | Converts a function application into applicative form -idiomize :: LHsExpr GhcPs -> LHsExpr GhcPs -idiomize x = noLoc $ case unLoc x of - HsApp _ (L _ (HsVar _ (L _ x))) gshgp3 -> - op (bvar' $ occName x) "<$>" (unLoc gshgp3) - HsApp _ gsigp gshgp3 -> - op (unLoc $ idiomize gsigp) "<*>" (unLoc gshgp3) - RecordCon _ con flds -> - unLoc $ idiomize $ noLoc $ foldl' (@@) (HsVar noExtField con) $ fmap unLoc flds - y -> y - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs deleted file mode 100644 index d683db9ffd..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Wingman.CodeGen.Utils where - -import Data.String -import Data.List -import Development.IDE.GHC.Compat -import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string) -import GHC.SourceGen.Overloaded as SourceGen -import Wingman.GHC (getRecordFields) - - ------------------------------------------------------------------------------- --- | Make a data constructor with the given arguments. -mkCon :: ConLike -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs -mkCon con apps (fmap unLoc -> args) - | RealDataCon dcon <- con - , dcon == nilDataCon - , [ty] <- apps - , ty `eqType` charTy = noLoc $ string "" - - | RealDataCon dcon <- con - , isTupleDataCon dcon = - noLoc $ tuple args - - | RealDataCon dcon <- con - , dataConIsInfix dcon - , (lhs : rhs : args') <- args = - noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args' - - | Just fields <- getRecordFields con - , length fields >= 2 = -- record notation is unnatural on single field ctors - noLoc $ recordConE (coerceName con_name) $ do - (arg, (field, _)) <- zip args fields - pure (coerceName field, arg) - - | otherwise = - noLoc $ foldl' (@@) (bvar' $ occName con_name) args - where - con_name = conLikeName con - - -coerceName :: HasOccName a => a -> RdrNameStr -coerceName = UnqualStr . fromString . occNameString . occName - - ------------------------------------------------------------------------------- --- | Like 'var', but works over standard GHC 'OccName's. -var' :: SourceGen.Var a => OccName -> a -var' = var . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Like 'bvar', but works over standard GHC 'OccName's. -bvar' :: BVar a => OccName -> a -bvar' = bvar . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a function name. -mkFunc :: String -> HsExpr GhcPs -mkFunc = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a value name. -mkVal :: String -> HsExpr GhcPs -mkVal = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Like 'op', but easier to call. -infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -infixCall s = flip op (fromString s) - - ------------------------------------------------------------------------------- --- | Like '(@@)', but uses a dollar instead of parentheses. -appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -appDollar = infixCall "$" - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs deleted file mode 100644 index 3c1b40ba1f..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.Context where - -import Control.Arrow -import Control.Monad.Reader -import Data.Coerce (coerce) -import Data.Foldable.Extra (allM) -import Data.Maybe (fromMaybe, isJust, mapMaybe) -import qualified Data.Set as S -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import Wingman.GHC (normalizeType) -import Wingman.Judgements.Theta -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - -mkContext - :: Config - -> [(OccName, CType)] - -> TcGblEnv - -> HscEnv - -> ExternalPackageState - -> [Evidence] - -> Context -mkContext cfg locals tcg hscenv eps ev = fix $ \ctx -> - Context - { ctxDefiningFuncs - = fmap (second $ coerce $ normalizeType ctx) locals - , ctxModuleFuncs - = fmap (second (coerce $ normalizeType ctx) . splitId) - . mappend (locallyDefinedMethods tcg) - . (getFunBindId =<<) - . fmap unLoc - . bagToList - $ tcg_binds tcg - , ctxConfig = cfg - , ctxFamInstEnvs = - (eps_fam_inst_env eps, tcg_fam_inst_env tcg) - , ctxInstEnvs = - InstEnvs - (eps_inst_env eps) - (tcg_inst_env tcg) - (tcVisibleOrphanMods tcg) - , ctxTheta = evidenceToThetaType ev - , ctx_hscEnv = hscenv - , ctx_occEnv = tcg_rdr_env tcg - , ctx_module = extractModule tcg - } - - -locallyDefinedMethods :: TcGblEnv -> [Id] -locallyDefinedMethods - = foldMap classMethods - . mapMaybe tyConClass_maybe - . tcg_tcs - - - -splitId :: Id -> (OccName, CType) -splitId = occName &&& CType . idType - - -getFunBindId :: HsBindLR GhcTc GhcTc -> [Id] -getFunBindId (AbsBinds _ _ _ abes _ _ _) - = abes >>= \case - ABE _ poly _ _ _ -> pure poly - _ -> [] -getFunBindId _ = [] - - ------------------------------------------------------------------------------- --- | Determine if there is an instance that exists for the given 'Class' at the --- specified types. Deeply checks contexts to ensure the instance is actually --- real. --- --- If so, this returns a 'PredType' that corresponds to the type of the --- dictionary. -getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType)) -getInstance cls tys = do - env <- asks ctxInstEnvs - let (mres, _, _) = lookupInstEnv False env cls tys - case mres of - ((inst, mapps) : _) -> do - -- Get the instantiated type of the dictionary - let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps - -- pull off its resulting arguments - let (theta, df') = tcSplitPhiTy df - allM hasClassInstance theta >>= \case - True -> pure $ Just (cls, df') - False -> pure Nothing - _ -> pure Nothing - - ------------------------------------------------------------------------------- --- | Like 'getInstance', but only returns whether or not it succeeded. Can fail --- fast, and uses a cached Theta from the context. -hasClassInstance :: MonadReader Context m => PredType -> m Bool -hasClassInstance predty = do - theta <- asks ctxTheta - case S.member (CType predty) theta of - True -> pure True - False -> do - let (con, apps) = tcSplitTyConApp predty - case tyConClass_maybe con of - Nothing -> pure False - Just cls -> fmap isJust $ getInstance cls apps - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs deleted file mode 100644 index e637779824..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -module Wingman.Debug - ( unsafeRender - , unsafeRender' - , traceM - , traceShowId - , trace - , traceX - , traceIdX - , traceMX - , traceFX - ) where - -import Control.DeepSeq -import Control.Exception -import Data.Either (fromRight) -import qualified Data.Text as T -import qualified Debug.Trace -import Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc) -import Development.IDE.GHC.Util (printOutputable) -import System.IO.Unsafe (unsafePerformIO) - ------------------------------------------------------------------------------- --- | Print something -unsafeRender :: Outputable a => a -> String -unsafeRender = unsafeRender' . ppr - - -unsafeRender' :: SDoc -> String -unsafeRender' sdoc = unsafePerformIO $ do - let z = T.unpack $ printOutputable sdoc - -- We might not have unsafeGlobalDynFlags (like during testing), in which - -- case GHC panics. Instead of crashing, let's just fail to print. - !res <- try @PlainGhcException $ evaluate $ deepseq z z - pure $ fromRight "" res -{-# NOINLINE unsafeRender' #-} - -traceMX :: (Monad m, Show a) => String -> a -> m () -traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a - -traceX :: (Show a) => String -> a -> b -> b -traceX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) - -traceIdX :: (Show a) => String -> a -> a -traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a - -traceFX :: String -> (a -> String) -> a -> a -traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a - -traceM :: Applicative f => String -> f () -trace :: String -> a -> a -traceShowId :: Show a => a -> a -#ifdef DEBUG -traceM = Debug.Trace.traceM -trace = Debug.Trace.trace -traceShowId = Debug.Trace.traceShowId -#else -traceM _ = pure () -trace _ = id -traceShowId = id -#endif diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs deleted file mode 100644 index a13d7c1a65..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.EmptyCase where - -import Control.Applicative (empty) -import Control.Monad -import Control.Monad.Except (runExcept) -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Data.Generics.Aliases (mkQ, GenericQ) -import Data.Generics.Schemes (everything) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import Data.Traversable -import Development.IDE (hscEnv, realSrcSpanToRange) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty, EmptyCase) -import Development.IDE.GHC.ExactPrint -import Development.IDE.Spans.LocalBindings (getLocalScope) -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Prelude hiding (span) -import Wingman.AbstractLSP.Types -import Wingman.CodeGen (destructionFor) -import Wingman.GHC -import Wingman.Judgements -import Wingman.LanguageServer -import Wingman.Types - - -data EmptyCaseT = EmptyCaseT - -instance IsContinuationSort EmptyCaseT where - toCommandId _ = CommandId "wingman.emptyCase" - -instance IsTarget EmptyCaseT where - type TargetArgs EmptyCaseT = () - fetchTargetArgs _ = pure () - -emptyCaseInteraction :: Interaction -emptyCaseInteraction = Interaction $ - Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT - (SynthesizeCodeLens $ \LspEnv{..} _ -> do - let FileContext{..} = le_fileContext - nfp <- getNfp fc_uri - - let stale a = runStaleIde "codeLensProvider" le_ideState nfp a - - ccs <- lift getClientCapabilities - TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - TrackedStale binds bind_map <- mapMaybeT liftIO $ stale GetBindings - holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState nfp - - for holes $ \(ss, ty) -> do - binds_ss <- liftMaybe $ mapAgeFrom bind_map ss - let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss - range = realSrcSpanToRange $ unTrack ss - matches <- - liftMaybe $ - destructionFor - (foldMap (hySingleton . occName . fst) bindings) - ty - edits <- liftMaybe $ hush $ - mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $ - graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ - noLoc matches - pure - ( range - , Metadata - (mkEmptyCaseLensDesc ty) - (CodeActionUnknown "refactor.wingman.completeEmptyCase") - False - , edits - ) - ) - (\ _ _ _ we -> pure $ pure $ RawEdit we) - - -scrutinzedType :: EmptyCaseSort Type -> Maybe Type -scrutinzedType (EmptyCase ty) = pure ty -scrutinzedType (EmptyLamCase ty) = - case tacticsSplitFunTy ty of - (_, _, tys, _) -> listToMaybe $ fmap scaledThing tys - - ------------------------------------------------------------------------------- --- | The description for the empty case lens. -mkEmptyCaseLensDesc :: Type -> T.Text -mkEmptyCaseLensDesc ty = - "Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")" - - ------------------------------------------------------------------------------- --- | Silence an error. -hush :: Either e a -> Maybe a -hush (Left _) = Nothing -hush (Right a) = Just a - - ------------------------------------------------------------------------------- --- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly --- deals with top-level holes, in which we might need to fiddle with the --- 'Match's that bind variables. -graftMatchGroup - :: SrcSpan - -> Located [LMatch GhcPs (LHsExpr GhcPs)] - -> Graft (Either String) ParsedSource -graftMatchGroup ss l = - hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case - L span (HsCase ext scrut mg) -> do - pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l } - L span (HsLamCase ext mg) -> do - pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l } - (_ :: LHsExpr GhcPs) -> pure Nothing - - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT - - ------------------------------------------------------------------------------- --- | Find the last typechecked module, and find the most specific span, as well --- as the judgement at the given range. -emptyCaseScrutinees - :: IdeState - -> NormalizedFilePath - -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)] -emptyCaseScrutinees state nfp = do - let stale a = runStaleIde "emptyCaseScrutinees" state nfp a - - TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck - let tcg' = unTrack tcg - hscenv <- stale GhcSessionDeps - - let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg - fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do - ty <- MaybeT - . fmap (scrutinzedType <=< sequence) - . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg') - $ scrutinee - case null $ tacticsGetDataCons ty of - True -> pure empty - False -> - case ss of - RealSrcSpan r _ -> do - rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r - pure $ Just (rss', ty) - UnhelpfulSpan _ -> empty - -data EmptyCaseSort a - = EmptyCase a - | EmptyLamCase a - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - ------------------------------------------------------------------------------- --- | Get the 'SrcSpan' and scrutinee of every empty case. -emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))] -emptyCaseQ = everything (<>) $ mkQ mempty $ \case - L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee) - L new_span expr@(LamCase []) -> pure (new_span, EmptyLamCase expr) - (_ :: LHsExpr GhcTc) -> mempty - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs deleted file mode 100644 index 13562a6ef8..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.GHC where - -import Control.Monad.State -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Data.Bool (bool) -import Data.Coerce (coerce) -import Data.Function (on) -import Data.Functor ((<&>)) -import Data.List (isPrefixOf) -import qualified Data.Map as M -import Data.Maybe (isJust) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import GHC.SourceGen (lambda) -import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) -import Wingman.StaticPlugin (pattern MetaprogramSyntax) -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - -tcTyVar_maybe :: Type -> Maybe Var -tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty' -tcTyVar_maybe (CastTy ty _) = tcTyVar_maybe ty -- look through casts, as - -- this is only used for - -- e.g., FlexibleContexts -tcTyVar_maybe (TyVarTy v) = Just v -tcTyVar_maybe _ = Nothing - - -instantiateType :: Type -> ([TyVar], Type) -instantiateType t = do - let vs = tyCoVarsOfTypeList t - vs' = fmap cloneTyVar vs - subst = foldr (\(v,t) a -> extendTCvSubst a v $ TyVarTy t) emptyTCvSubst - $ zip vs vs' - in (vs', substTy subst t) - - -cloneTyVar :: TyVar -> TyVar -cloneTyVar t = - let uniq = getUnique t - some_magic_char = 'w' -- 'w' for wingman ;D - in setVarUnique t $ newTagUnique uniq some_magic_char - - ------------------------------------------------------------------------------- --- | Is this a function type? -isFunction :: Type -> Bool -isFunction (tacticsSplitFunTy -> (_, _, [], _)) = False -isFunction _ = True - - ------------------------------------------------------------------------------- --- | Split a function, also splitting out its quantified variables and theta --- context. -tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type) -tacticsSplitFunTy t - = let (vars, theta, t') = tcSplitNestedSigmaTys t - (args, res) = tcSplitFunTys t' - in (vars, theta, args, res) - - ------------------------------------------------------------------------------- --- | Rip the theta context out of a regular type. -tacticsThetaTy :: Type -> ThetaType -tacticsThetaTy (tcSplitSigmaTy -> (_, theta, _)) = theta - - ------------------------------------------------------------------------------- --- | Get the data cons of a type, if it has any. -tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type]) -tacticsGetDataCons ty - | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty - = tacticsGetDataCons ty' -tacticsGetDataCons ty - | Just _ <- algebraicTyCon ty - = splitTyConApp_maybe ty <&> \(tc, apps) -> - ( filter (not . dataConCannotMatch apps) $ tyConDataCons tc - , apps - ) -tacticsGetDataCons _ = Nothing - ------------------------------------------------------------------------------- --- | Instantiate all of the quantified type variables in a type with fresh --- skolems. -freshTyvars :: MonadState TacticState m => Type -> m Type -freshTyvars t = do - let (tvs, _, _, _) = tacticsSplitFunTy t - reps <- fmap M.fromList - $ for tvs $ \tv -> do - uniq <- freshUnique - pure (tv, setTyVarUnique tv uniq) - pure $ - everywhere - (mkT $ \tv -> M.findWithDefault tv tv reps - ) $ snd $ tcSplitForAllTyVars t - - ------------------------------------------------------------------------------- --- | Given a datacon, extract its record fields' names and types. Returns --- nothing if the datacon is not a record. -getRecordFields :: ConLike -> Maybe [(OccName, CType)] -getRecordFields dc = - case conLikeFieldLabels dc of - [] -> Nothing - lbls -> for lbls $ \lbl -> do - let ty = conLikeFieldType dc $ flLabel lbl - pure (mkVarOccFS $ flLabel lbl, CType ty) - - ------------------------------------------------------------------------------- --- | Is this an algebraic type? -algebraicTyCon :: Type -> Maybe TyCon -algebraicTyCon ty - | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty - = algebraicTyCon ty' -algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _)) - | tycon == intTyCon = Nothing - | tycon == floatTyCon = Nothing - | tycon == doubleTyCon = Nothing - | tycon == charTyCon = Nothing - | tycon == funTyCon = Nothing - | otherwise = Just tycon -algebraicTyCon _ = Nothing - - ------------------------------------------------------------------------------- --- | We can't compare 'RdrName' for equality directly. Instead, sloppily --- compare them by their 'OccName's. -eqRdrName :: RdrName -> RdrName -> Bool -eqRdrName = (==) `on` occNameString . occName - - ------------------------------------------------------------------------------- --- | Compare two 'OccName's for unqualified equality. -sloppyEqOccName :: OccName -> OccName -> Bool -sloppyEqOccName = (==) `on` occNameString - - ------------------------------------------------------------------------------- --- | Does this thing contain any references to 'HsVar's with the given --- 'RdrName'? -containsHsVar :: Data a => RdrName -> a -> Bool -containsHsVar name x = not $ null $ listify ( - \case - ((HsVar _ (L _ a)) :: HsExpr GhcPs) | eqRdrName a name -> True - _ -> False - ) x - - ------------------------------------------------------------------------------- --- | Does this thing contain any holes? -containsHole :: Data a => a -> Bool -containsHole x = not $ null $ listify ( - \case - ((HsVar _ (L _ name)) :: HsExpr GhcPs) -> isHole $ occName name - MetaprogramSyntax _ -> True - _ -> False - ) x - - ------------------------------------------------------------------------------- --- | Check if an 'OccName' is a hole -isHole :: OccName -> Bool --- TODO(sandy): Make this more robust -isHole = isPrefixOf "_" . occNameString - - ------------------------------------------------------------------------------- --- | Get all of the referenced occnames. -allOccNames :: Data a => a -> Set OccName -allOccNames = everything (<>) $ mkQ mempty $ \case - a -> S.singleton a - - ------------------------------------------------------------------------------- --- | Unpack the relevant parts of a 'Match' -#if __GLASGOW_HASKELL__ >= 900 -pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) -#else -pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) -#endif -pattern AMatch ctx pats body <- - Match { m_ctxt = ctx - , m_pats = fmap fromPatCompat -> pats - , m_grhss = UnguardedRHSs (unLoc -> body) - } - - -pattern SingleLet :: IdP GhcPs -> [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -pattern SingleLet bind pats val expr <- - HsLet _ - (HsValBinds _ - (ValBinds _ (bagToList -> - [L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _)) - (L _ expr) - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -pattern Lambda pats body <- - HsLam _ - MG {mg_alts = L _ [L _ (AMatch _ pats body) ]} - where - -- If there are no patterns to bind, just stick in the body - Lambda [] body = body - Lambda pats body = lambda pats body - - ------------------------------------------------------------------------------- --- | A GRHS that contains no guards. -pattern UnguardedRHSs :: LHsExpr p -> GRHSs p (LHsExpr p) -pattern UnguardedRHSs body <- - GRHSs {grhssGRHSs = [L _ (GRHS _ [] body)]} - - ------------------------------------------------------------------------------- --- | A match with a single pattern. Case matches are always 'SinglePatMatch'es. -pattern SinglePatMatch :: PatCompattable p => Pat p -> LHsExpr p -> Match p (LHsExpr p) -pattern SinglePatMatch pat body <- - Match { m_pats = [fromPatCompat -> pat] - , m_grhss = UnguardedRHSs body - } - - ------------------------------------------------------------------------------- --- | Helper function for defining the 'Case' pattern. -unpackMatches :: PatCompattable p => [Match p (LHsExpr p)] -> Maybe [(Pat p, LHsExpr p)] -unpackMatches [] = Just [] -unpackMatches (SinglePatMatch pat body : matches) = - ((pat, body):) <$> unpackMatches matches -unpackMatches _ = Nothing - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Case :: PatCompattable p => HsExpr p -> [(Pat p, LHsExpr p)] -> HsExpr p -pattern Case scrutinee matches <- - HsCase _ (L _ scrutinee) - MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)} - ------------------------------------------------------------------------------- --- | Like 'Case', but for lambda cases. -pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p -pattern LamCase matches <- - HsLamCase _ - MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)} - - ------------------------------------------------------------------------------- --- | Can ths type be lambda-cased? --- --- Return: 'Nothing' if no --- @Just False@ if it can't be homomorphic --- @Just True@ if it can -lambdaCaseable :: Type -> Maybe Bool -#if __GLASGOW_HASKELL__ >= 900 -lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res)) -#else -lambdaCaseable (splitFunTy_maybe -> Just (arg, res)) -#endif - | isJust (algebraicTyCon arg) - = Just $ isJust $ algebraicTyCon res -lambdaCaseable _ = Nothing - -class PatCompattable p where - fromPatCompat :: PatCompat p -> Pat p - toPatCompat :: Pat p -> PatCompat p - -instance PatCompattable GhcTc where - fromPatCompat = unLoc - toPatCompat = noLoc - -instance PatCompattable GhcPs where - fromPatCompat = unLoc - toPatCompat = noLoc - -type PatCompat pass = LPat pass - ------------------------------------------------------------------------------- --- | Should make sure it's a fun bind -pattern TopLevelRHS - :: OccName - -> [PatCompat GhcTc] - -> LHsExpr GhcTc - -> HsLocalBindsLR GhcTc GhcTc - -> Match GhcTc (LHsExpr GhcTc) -pattern TopLevelRHS name ps body where_binds <- - Match _ - (FunRhs (L _ (occName -> name)) _ _) - ps - (GRHSs _ - [L _ (GRHS _ [] body)] (L _ where_binds)) - -liftMaybe :: Monad m => Maybe a -> MaybeT m a -liftMaybe a = MaybeT $ pure a - - ------------------------------------------------------------------------------- --- | Get the type of an @HsExpr GhcTc@. This is slow and you should prefer to --- not use it, but sometimes it can't be helped. -typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type) -typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr - ------------------------------------------------------------------------------- --- | Expand type and data families -normalizeType :: Context -> Type -> Type -normalizeType ctx ty = - let ty' = expandTyFam ctx ty - in case tcSplitTyConApp_maybe ty' of - Just (tc, tys) -> - -- try to expand any data families - case tcLookupDataFamInst_maybe (ctxFamInstEnvs ctx) tc tys of - Just (dtc, dtys, _) -> mkAppTys (mkTyConTy dtc) dtys - Nothing -> ty' - Nothing -> ty' - ------------------------------------------------------------------------------- --- | Expand type families -expandTyFam :: Context -> Type -> Type -expandTyFam ctx = snd . normaliseType (ctxFamInstEnvs ctx) Nominal - - ------------------------------------------------------------------------------- --- | Like 'tcUnifyTy', but takes a list of skolems to prevent unification of. -tryUnifyUnivarsButNotSkolems :: Set TyVar -> CType -> CType -> Maybe TCvSubst -tryUnifyUnivarsButNotSkolems skolems goal inst = - tryUnifyUnivarsButNotSkolemsMany skolems $ coerce [(goal, inst)] - ------------------------------------------------------------------------------- --- | Like 'tryUnifyUnivarsButNotSkolems', but takes a list --- of pairs of types to unify. -tryUnifyUnivarsButNotSkolemsMany :: Set TyVar -> [(Type, Type)] -> Maybe TCvSubst -tryUnifyUnivarsButNotSkolemsMany skolems (unzip -> (goal, inst)) = - tcUnifyTys - (bool BindMe Skolem . flip S.member skolems) - inst - goal - - -updateSubst :: TCvSubst -> TacticState -> TacticState -updateSubst subst s = s { ts_unifier = unionTCvSubst subst (ts_unifier s) } - - ------------------------------------------------------------------------------- --- | Get the class methods of a 'PredType', correctly dealing with --- instantiation of quantified class types. -methodHypothesis :: PredType -> Maybe [HyInfo CType] -methodHypothesis ty = do - (tc, apps) <- splitTyConApp_maybe ty - cls <- tyConClass_maybe tc - let methods = classMethods cls - tvs = classTyVars cls - subst = zipTvSubst tvs apps - pure $ methods <&> \method -> - let (_, _, ty) = tcSplitSigmaTy $ idType method - in ( HyInfo (occName method) (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty - ) - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs deleted file mode 100644 index 0ff03e60ee..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs +++ /dev/null @@ -1,474 +0,0 @@ -module Wingman.Judgements where - -import Control.Arrow -import Control.Lens hiding (Context) -import Data.Bool -import Data.Char -import Data.Coerce -import Data.Generics.Product (field) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.Core.UseStale (Tracked, unTrack) -import Development.IDE.GHC.Compat hiding (isTopLevel) -import Development.IDE.Spans.LocalBindings -import Wingman.GHC (algebraicTyCon, normalizeType) -import Wingman.Judgements.Theta -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis. -hypothesisFromBindings :: Tracked age RealSrcSpan -> Tracked age Bindings -> Hypothesis CType -hypothesisFromBindings (unTrack -> span) (unTrack -> bs) = buildHypothesis $ getLocalScope bs span - - ------------------------------------------------------------------------------- --- | Convert a @Set Id@ into a hypothesis. -buildHypothesis :: [(Name, Maybe Type)] -> Hypothesis CType -buildHypothesis - = Hypothesis - . mapMaybe go - where - go (occName -> occ, t) - | Just ty <- t - , (h:_) <- occNameString occ - , isAlpha h = Just $ HyInfo occ UserPrv $ CType ty - | otherwise = Nothing - - ------------------------------------------------------------------------------- --- | Build a trivial hypothesis containing only a single name. The corresponding --- HyInfo has no provenance or type. -hySingleton :: OccName -> Hypothesis () -hySingleton n = Hypothesis . pure $ HyInfo n UserPrv () - - -blacklistingDestruct :: Judgement -> Judgement -blacklistingDestruct = - field @"_jBlacklistDestruct" .~ True - - -unwhitelistingSplit :: Judgement -> Judgement -unwhitelistingSplit = - field @"_jWhitelistSplit" .~ False - - -isDestructBlacklisted :: Judgement -> Bool -isDestructBlacklisted = _jBlacklistDestruct - - -isSplitWhitelisted :: Judgement -> Bool -isSplitWhitelisted = _jWhitelistSplit - - -withNewGoal :: a -> Judgement' a -> Judgement' a -withNewGoal t = field @"_jGoal" .~ t - ------------------------------------------------------------------------------- --- | Like 'withNewGoal' but allows you to modify the goal rather than replacing --- it. -withModifiedGoal :: (a -> a) -> Judgement' a -> Judgement' a -withModifiedGoal f = field @"_jGoal" %~ f - - ------------------------------------------------------------------------------- --- | Add some new type equalities to the local judgement. -withNewCoercions :: [(CType, CType)] -> Judgement -> Judgement -withNewCoercions ev j = - let subst = allEvidenceToSubst mempty $ coerce ev - in fmap (CType . substTyAddInScope subst . unCType) j - & field @"j_coercion" %~ unionTCvSubst subst - - -normalizeHypothesis :: Functor f => Context -> f CType -> f CType -normalizeHypothesis = fmap . coerce . normalizeType - -normalizeJudgement :: Functor f => Context -> f CType -> f CType -normalizeJudgement = normalizeHypothesis - - -introduce :: Context -> Hypothesis CType -> Judgement' CType -> Judgement' CType --- NOTE(sandy): It's important that we put the new hypothesis terms first, --- since 'jAcceptableDestructTargets' will never destruct a pattern that occurs --- after a previously-destructed term. -introduce ctx hy = - field @"_jHypothesis" %~ mappend (normalizeHypothesis ctx hy) - - ------------------------------------------------------------------------------- --- | Helper function for implementing functions which introduce new hypotheses. -introduceHypothesis - :: (Int -> Int -> Provenance) - -- ^ A function from the total number of args and position of this arg - -- to its provenance. - -> [(OccName, a)] - -> Hypothesis a -introduceHypothesis f ns = - Hypothesis $ zip [0..] ns <&> \(pos, (name, ty)) -> - HyInfo name (f (length ns) pos) ty - - ------------------------------------------------------------------------------- --- | Introduce bindings in the context of a lambda. -lambdaHypothesis - :: Maybe OccName -- ^ The name of the top level function. For any other - -- function, this should be 'Nothing'. - -> [(OccName, a)] - -> Hypothesis a -lambdaHypothesis func = - introduceHypothesis $ \count pos -> - maybe UserPrv (\x -> TopLevelArgPrv x pos count) func - - ------------------------------------------------------------------------------- --- | Introduce a binding in a recursive context. -recursiveHypothesis :: [(OccName, a)] -> Hypothesis a -recursiveHypothesis = introduceHypothesis $ const $ const RecursivePrv - - ------------------------------------------------------------------------------- --- | Introduce a binding in a recursive context. -userHypothesis :: [(OccName, a)] -> Hypothesis a -userHypothesis = introduceHypothesis $ const $ const UserPrv - - ------------------------------------------------------------------------------- --- | Check whether any of the given occnames are an ancestor of the term. -hasPositionalAncestry - :: Foldable t - => t OccName -- ^ Desired ancestors. - -> Judgement - -> OccName -- ^ Potential child - -> Maybe Bool -- ^ Just True if the result is the oldest positional ancestor - -- just false if it's a descendent - -- otherwise nothing -hasPositionalAncestry ancestors jdg name - | not $ null ancestors - = case name `elem` ancestors of - True -> Just True - False -> - case M.lookup name $ jAncestryMap jdg of - Just ancestry -> - bool Nothing (Just False) $ any (flip S.member ancestry) ancestors - Nothing -> Nothing - | otherwise = Nothing - - ------------------------------------------------------------------------------- --- | Helper function for disallowing hypotheses that have the wrong ancestry. -filterAncestry - :: Foldable t - => t OccName - -> DisallowReason - -> Judgement - -> Judgement -filterAncestry ancestry reason jdg = - disallowing reason (M.keysSet $ M.filterWithKey go $ hyByName $ jHypothesis jdg) jdg - where - go name _ - = isNothing - $ hasPositionalAncestry ancestry jdg name - - ------------------------------------------------------------------------------- --- | @filter defn pos@ removes any hypotheses which are bound in @defn@ to --- a position other than @pos@. Any terms whose ancestry doesn't include @defn@ --- remain. -filterPosition :: OccName -> Int -> Judgement -> Judgement -filterPosition defn pos jdg = - filterAncestry (findPositionVal jdg defn pos) (WrongBranch pos) jdg - - ------------------------------------------------------------------------------- --- | Helper function for determining the ancestry list for 'filterPosition'. -findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName -findPositionVal jdg defn pos = listToMaybe $ do - -- It's important to inspect the entire hypothesis here, as we need to trace - -- ancestry through potentially disallowed terms in the hypothesis. - (name, hi) <- M.toList - $ M.map (overProvenance expandDisallowed) - $ hyByName - $ jEntireHypothesis jdg - case hi_provenance hi of - TopLevelArgPrv defn' pos' _ - | defn == defn' - , pos == pos' -> pure name - PatternMatchPrv pv - | pv_scrutinee pv == Just defn - , pv_position pv == pos -> pure name - _ -> [] - - ------------------------------------------------------------------------------- --- | Helper function for determining the ancestry list for --- 'filterSameTypeFromOtherPositions'. -findDconPositionVals :: Judgement' a -> ConLike -> Int -> [OccName] -findDconPositionVals jdg dcon pos = do - (name, hi) <- M.toList $ hyByName $ jHypothesis jdg - case hi_provenance hi of - PatternMatchPrv pv - | pv_datacon pv == Uniquely dcon - , pv_position pv == pos -> pure name - _ -> [] - - ------------------------------------------------------------------------------- --- | Disallow any hypotheses who have the same type as anything bound by the --- given position for the datacon. Used to ensure recursive functions like --- 'fmap' preserve the relative ordering of their arguments by eliminating any --- other term which might match. -filterSameTypeFromOtherPositions :: ConLike -> Int -> Judgement -> Judgement -filterSameTypeFromOtherPositions dcon pos jdg = - let hy = hyByName - . jHypothesis - $ filterAncestry - (findDconPositionVals jdg dcon pos) - (WrongBranch pos) - jdg - tys = S.fromList $ hi_type <$> M.elems hy - to_remove = - M.filter (flip S.member tys . hi_type) (hyByName $ jHypothesis jdg) - M.\\ hy - in disallowing Shadowed (M.keysSet to_remove) jdg - - ------------------------------------------------------------------------------- --- | Return the ancestry of a 'PatVal', or 'mempty' otherwise. -getAncestry :: Judgement' a -> OccName -> Set OccName -getAncestry jdg name = - maybe mempty pv_ancestry . M.lookup name $ jPatHypothesis jdg - - -jAncestryMap :: Judgement' a -> Map OccName (Set OccName) -jAncestryMap jdg = - M.map pv_ancestry (jPatHypothesis jdg) - - -provAncestryOf :: Provenance -> Set OccName -provAncestryOf (TopLevelArgPrv o _ _) = S.singleton o -provAncestryOf (PatternMatchPrv (PatVal mo so _ _)) = - maybe mempty S.singleton mo <> so -provAncestryOf (ClassMethodPrv _) = mempty -provAncestryOf UserPrv = mempty -provAncestryOf RecursivePrv = mempty -provAncestryOf ImportPrv = mempty -provAncestryOf (DisallowedPrv _ p2) = provAncestryOf p2 - - ------------------------------------------------------------------------------- --- TODO(sandy): THIS THING IS A BIG BIG HACK --- --- Why? 'ctxDefiningFuncs' is _all_ of the functions currently being defined --- (eg, we might be in a where block). The head of this list is not guaranteed --- to be the one we're interested in. -extremelyStupid__definingFunction :: Context -> OccName -extremelyStupid__definingFunction = - fst . head . ctxDefiningFuncs - - -patternHypothesis - :: Maybe OccName - -> ConLike - -> Judgement' a - -> [(OccName, a)] - -> Hypothesis a -patternHypothesis scrutinee dc jdg - = introduceHypothesis $ \_ pos -> - PatternMatchPrv $ - PatVal - scrutinee - (maybe - mempty - (\scrut -> S.singleton scrut <> getAncestry jdg scrut) - scrutinee) - (Uniquely dc) - pos - - ------------------------------------------------------------------------------- --- | Prevent some occnames from being used in the hypothesis. This will hide --- them from 'jHypothesis', but not from 'jEntireHypothesis'. -disallowing :: DisallowReason -> S.Set OccName -> Judgement' a -> Judgement' a -disallowing reason ns = - field @"_jHypothesis" %~ (\z -> Hypothesis . flip fmap (unHypothesis z) $ \hi -> - case S.member (hi_name hi) ns of - True -> overProvenance (DisallowedPrv reason) hi - False -> hi - ) - - ------------------------------------------------------------------------------- --- | The hypothesis, consisting of local terms and the ambient environment --- (imports and class methods.) Hides disallowed values. -jHypothesis :: Judgement' a -> Hypothesis a -jHypothesis - = Hypothesis - . filter (not . isDisallowed . hi_provenance) - . unHypothesis - . jEntireHypothesis - - ------------------------------------------------------------------------------- --- | The whole hypothesis, including things disallowed. -jEntireHypothesis :: Judgement' a -> Hypothesis a -jEntireHypothesis = _jHypothesis - - ------------------------------------------------------------------------------- --- | Just the local hypothesis. -jLocalHypothesis :: Judgement' a -> Hypothesis a -jLocalHypothesis - = Hypothesis - . filter (isLocalHypothesis . hi_provenance) - . unHypothesis - . jHypothesis - - ------------------------------------------------------------------------------- --- | Filter elements from the hypothesis -hyFilter :: (HyInfo a -> Bool) -> Hypothesis a -> Hypothesis a -hyFilter f = Hypothesis . filter f . unHypothesis - - ------------------------------------------------------------------------------- --- | Given a judgment, return the hypotheses that are acceptable to destruct. --- --- We use the ordering of the hypothesis for this purpose. Since new bindings --- are always inserted at the beginning, we can impose a canonical ordering on --- which order to try destructs by what order they are introduced --- stopping --- at the first one we've already destructed. -jAcceptableDestructTargets :: Judgement' CType -> [HyInfo CType] -jAcceptableDestructTargets - = filter (isJust . algebraicTyCon . unCType . hi_type) - . takeWhile (not . isAlreadyDestructed . hi_provenance) - . unHypothesis - . jEntireHypothesis - - ------------------------------------------------------------------------------- --- | If we're in a top hole, the name of the defining function. -isTopHole :: Context -> Judgement' a -> Maybe OccName -isTopHole ctx = - bool Nothing (Just $ extremelyStupid__definingFunction ctx) . _jIsTopHole - - -unsetIsTopHole :: Judgement' a -> Judgement' a -unsetIsTopHole = field @"_jIsTopHole" .~ False - - ------------------------------------------------------------------------------- --- | What names are currently in scope in the hypothesis? -hyNamesInScope :: Hypothesis a -> Set OccName -hyNamesInScope = M.keysSet . hyByName - - ------------------------------------------------------------------------------- --- | Are there any top-level function argument bindings in this judgement? -jHasBoundArgs :: Judgement' a -> Bool -jHasBoundArgs - = any (isTopLevel . hi_provenance) - . unHypothesis - . jLocalHypothesis - - -jNeedsToBindArgs :: Judgement' CType -> Bool -jNeedsToBindArgs = isFunTy . unCType . jGoal - - ------------------------------------------------------------------------------- --- | Fold a hypothesis into a single mapping from name to info. This --- unavoidably will cause duplicate names (things like methods) to shadow one --- another. -hyByName :: Hypothesis a -> Map OccName (HyInfo a) -hyByName - = M.fromList - . fmap (hi_name &&& id) - . unHypothesis - - ------------------------------------------------------------------------------- --- | Only the hypothesis members which are pattern vals -jPatHypothesis :: Judgement' a -> Map OccName PatVal -jPatHypothesis - = M.mapMaybe (getPatVal . hi_provenance) - . hyByName - . jHypothesis - - -getPatVal :: Provenance-> Maybe PatVal -getPatVal prov = - case prov of - PatternMatchPrv pv -> Just pv - _ -> Nothing - - -jGoal :: Judgement' a -> a -jGoal = _jGoal - - -substJdg :: TCvSubst -> Judgement -> Judgement -substJdg subst = fmap $ coerce . substTy subst . coerce - - -mkFirstJudgement - :: Context - -> Hypothesis CType - -> Bool -- ^ are we in the top level rhs hole? - -> Type - -> Judgement' CType -mkFirstJudgement ctx hy top goal = - normalizeJudgement ctx $ - Judgement - { _jHypothesis = hy - , _jBlacklistDestruct = False - , _jWhitelistSplit = True - , _jIsTopHole = top - , _jGoal = CType goal - , j_coercion = emptyTCvSubst - } - - ------------------------------------------------------------------------------- --- | Is this a top level function binding? -isTopLevel :: Provenance -> Bool -isTopLevel TopLevelArgPrv{} = True -isTopLevel _ = False - - ------------------------------------------------------------------------------- --- | Is this a local function argument, pattern match or user val? -isLocalHypothesis :: Provenance -> Bool -isLocalHypothesis UserPrv{} = True -isLocalHypothesis PatternMatchPrv{} = True -isLocalHypothesis TopLevelArgPrv{} = True -isLocalHypothesis _ = False - - ------------------------------------------------------------------------------- --- | Is this a pattern match? -isPatternMatch :: Provenance -> Bool -isPatternMatch PatternMatchPrv{} = True -isPatternMatch _ = False - - ------------------------------------------------------------------------------- --- | Was this term ever disallowed? -isDisallowed :: Provenance -> Bool -isDisallowed DisallowedPrv{} = True -isDisallowed _ = False - ------------------------------------------------------------------------------- --- | Has this term already been disallowed? -isAlreadyDestructed :: Provenance -> Bool -isAlreadyDestructed (DisallowedPrv AlreadyDestructed _) = True -isAlreadyDestructed _ = False - - ------------------------------------------------------------------------------- --- | Eliminates 'DisallowedPrv' provenances. -expandDisallowed :: Provenance -> Provenance -expandDisallowed (DisallowedPrv _ prv) = expandDisallowed prv -expandDisallowed prv = prv diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs deleted file mode 100644 index 8cd6130eb3..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} - --- | Custom SYB traversals -module Wingman.Judgements.SYB where - -import Data.Foldable (foldl') -import Data.Generics hiding (typeRep) -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util (unpackFS) -import GHC.Exts (Any) -import Type.Reflection -import Unsafe.Coerce (unsafeCoerce) -import Wingman.StaticPlugin (pattern WingmanMetaprogram) - - ------------------------------------------------------------------------------- --- | Like 'everything', but only looks inside 'Located' terms that contain the --- given 'SrcSpan'. -everythingContaining - :: forall r - . Monoid r - => SrcSpan - -> GenericQ r - -> GenericQ r -everythingContaining dst f = go - where - go :: GenericQ r - go x = - case genericIsSubspan dst x of - Just False -> mempty - _ -> foldl' (<>) (f x) (gmapQ go x) - - ------------------------------------------------------------------------------- --- | Helper function for implementing 'everythingWithin' --- --- NOTE(sandy): Subtly broken. In an ideal world, this function should return --- @Just False@ for nodes of /any type/ which do not contain the span. But if --- this functionality exists anywhere within the SYB machinery, I have yet to --- find it. -genericIsSubspan - :: SrcSpan - -> GenericQ (Maybe Bool) -genericIsSubspan dst = mkQ1 (L noSrcSpan ()) Nothing $ \case - L span _ -> Just $ dst `isSubspanOf` span - - ------------------------------------------------------------------------------- --- | Like 'mkQ', but allows for polymorphic instantiation of its specific case. --- This instantiation matches whenever the dynamic value has the same --- constructor as the proxy @f ()@ value. -mkQ1 :: forall a r f - . (Data a, Data (f ())) - => f () -- ^ Polymorphic constructor to match on - -> r -- ^ Default value - -> (forall b. f b -> r) -- ^ Polymorphic match - -> a - -> r -mkQ1 proxy r br a = - case l_con == a_con && sameTypeModuloLastApp @a @(f ()) of - -- We have proven that the two values share the same constructor, and - -- that they have the same type if you ignore the final application. - -- Therefore, it is safe to coerce @a@ to @f b@, since @br@ is universal - -- over @b@ and can't inspect it. - True -> br $ unsafeCoerce @_ @(f Any) a - False -> r - where - l_con = toConstr proxy - a_con = toConstr a - - ------------------------------------------------------------------------------- --- | Given @a ~ f1 a1@ and @b ~ f2 b2@, returns true if @f1 ~ f2@. -sameTypeModuloLastApp :: forall a b. (Typeable a, Typeable b) => Bool -sameTypeModuloLastApp = - let tyrep1 = typeRep @a - tyrep2 = typeRep @b - in case (tyrep1 , tyrep2) of - (App a _, App b _) -> - case eqTypeRep a b of - Just HRefl -> True - Nothing -> False - _ -> False - - -metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)] -metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case - L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program) - (_ :: LHsExpr GhcTc) -> mempty - - -metaprogramQ :: GenericQ [(SrcSpan, T.Text)] -metaprogramQ = everything (<>) $ mkQ mempty $ \case - L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program) - (_ :: LHsExpr GhcTc) -> mempty - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs deleted file mode 100644 index 25bf5a3a21..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -module Wingman.Judgements.Theta - ( Evidence - , getEvidenceAtHole - , mkEvidence - , evidenceToCoercions - , evidenceToSubst - , evidenceToHypothesis - , evidenceToThetaType - , allEvidenceToSubst - ) where - -import Control.Applicative (empty) -import Control.Lens (preview) -import Data.Coerce (coerce) -import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import Data.Generics.Sum (_Ctor) -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Generics.SYB hiding (tyConName, empty, Generic) -import GHC.Generics -import Wingman.GHC -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - ------------------------------------------------------------------------------- --- | Something we've learned about the type environment. -data Evidence - -- | The two types are equal, via a @a ~ b@ relationship - = EqualityOfTypes Type Type - -- | We have an instance in scope - | HasInstance PredType - deriving (Show, Generic) - - ------------------------------------------------------------------------------- --- | Given a 'PredType', pull an 'Evidence' out of it. -mkEvidence :: PredType -> [Evidence] -mkEvidence (getEqualityTheta -> Just (a, b)) - = pure $ EqualityOfTypes a b -mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) = do - (_, apps) <- maybeToList $ splitTyConApp_maybe inst - let tvs = classTyVars cls - subst = zipTvSubst tvs apps - sc_ev <- traverse (mkEvidence . substTy subst) $ classSCTheta cls - HasInstance inst : sc_ev -mkEvidence _ = empty - - ------------------------------------------------------------------------------- --- | Build a set of 'PredType's from the evidence. -evidenceToThetaType :: [Evidence] -> Set CType -evidenceToThetaType evs = S.fromList $ do - HasInstance t <- evs - pure $ CType t - - ------------------------------------------------------------------------------- --- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'. -getEvidenceAtHole :: Tracked age SrcSpan -> Tracked age (LHsBinds GhcTc) -> [Evidence] -getEvidenceAtHole (unTrack -> dst) - = concatMap mkEvidence - . (everything (<>) $ - mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst) - . unTrack - - -mkSubst :: Set TyVar -> Type -> Type -> TCvSubst -mkSubst skolems a b = - let tyvars = S.fromList $ mapMaybe getTyVar_maybe [a, b] - -- If we can unify our skolems, at least one is no longer a skolem. - -- Removing them from this set ensures we can get a substitution between - -- the two. But it's okay to leave them in 'ts_skolems' in general, since - -- they won't exist after running this substitution. - skolems' = skolems S.\\ tyvars - in - case tryUnifyUnivarsButNotSkolems skolems' (CType a) (CType b) of - Just subst -> subst - Nothing -> emptyTCvSubst - - -substPair :: TCvSubst -> (Type, Type) -> (Type, Type) -substPair subst (ty, ty') = (substTy subst ty, substTy subst ty') - - ------------------------------------------------------------------------------- --- | Construct a substitution given a list of types that are equal to one --- another. This is more subtle than it seems, since there might be several --- equalities for the same type. We must be careful to push the accumulating --- substitution through each pair of types before adding their equalities. -allEvidenceToSubst :: Set TyVar -> [(Type, Type)] -> TCvSubst -allEvidenceToSubst _ [] = emptyTCvSubst -allEvidenceToSubst skolems ((a, b) : evs) = - let subst = mkSubst skolems a b - in unionTCvSubst subst - $ allEvidenceToSubst skolems - $ fmap (substPair subst) evs - ------------------------------------------------------------------------------- --- | Given some 'Evidence', get a list of which types are now equal. -evidenceToCoercions :: [Evidence] -> [(CType, CType)] -evidenceToCoercions = coerce . mapMaybe (preview $ _Ctor @"EqualityOfTypes") - ------------------------------------------------------------------------------- --- | Update our knowledge of which types are equal. -evidenceToSubst :: [Evidence] -> TacticState -> TacticState -evidenceToSubst evs ts = - updateSubst - (allEvidenceToSubst (ts_skolems ts) . coerce $ evidenceToCoercions evs) - ts - - ------------------------------------------------------------------------------- --- | Get all of the methods that are in scope from this piece of 'Evidence'. -evidenceToHypothesis :: Evidence -> Hypothesis CType -evidenceToHypothesis EqualityOfTypes{} = mempty -evidenceToHypothesis (HasInstance t) = - Hypothesis . excludeForbiddenMethods . fromMaybe [] $ methodHypothesis t - - ------------------------------------------------------------------------------- --- | Given @a ~ b@ or @a ~# b@, returns @Just (a, b)@, otherwise @Nothing@. -getEqualityTheta :: PredType -> Maybe (Type, Type) -getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k, a, b])) -#if __GLASGOW_HASKELL__ > 806 - | tc == eqTyCon -#else - | nameRdrName (tyConName tc) == eqTyCon_RDR -#endif - = Just (a, b) -getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k1, _k2, a, b])) - | tc == eqPrimTyCon = Just (a, b) -getEqualityTheta _ = Nothing - - ------------------------------------------------------------------------------- --- | Many operations are defined in typeclasses for performance reasons, rather --- than being a true part of the class. This function filters out those, in --- order to keep our hypothesis space small. -excludeForbiddenMethods :: [HyInfo a] -> [HyInfo a] -excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name) - where - forbiddenMethods :: Set OccName - forbiddenMethods = S.map mkVarOcc $ S.fromList - [ -- monadfail - "fail" - -- show - , "showsPrec", "showList" - -- functor - , "<$" - -- applicative - , "liftA2", "<*", "*>" - -- monad - , "return", ">>" - -- alternative - , "some", "many" - -- foldable - , "foldr1", "foldl1", "elem", "maximum", "minimum", "sum", "product" - -- traversable - , "sequenceA", "mapM", "sequence" - -- semigroup - , "sconcat", "stimes" - -- monoid - , "mconcat" - ] - - ------------------------------------------------------------------------------- --- | Extract evidence from 'AbsBinds' in scope. -absBinds :: SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -absBinds dst (L src (FunBind w _ _ _)) - | dst `isSubspanOf` src - = wrapper w -absBinds dst (L src (AbsBinds _ _ h _ _ z _)) -#else -absBinds dst (L src (AbsBinds _ _ h _ _ _ _)) -#endif - | dst `isSubspanOf` src - = fmap idType h -#if __GLASGOW_HASKELL__ >= 900 - <> foldMap (absBinds dst) z -#endif -absBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from 'HsWrapper's in scope -wrapperBinds :: SrcSpan -> LHsExpr GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _)))) -#else -wrapperBinds dst (L src (HsWrap _ h _)) -#endif - | dst `isSubspanOf` src - = wrapper h -wrapperBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from the 'ConPatOut's bound in this 'Match'. -matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType] -matchBinds dst (L src (Match _ _ pats _)) - | dst `isSubspanOf` src - = everything (<>) (mkQ mempty patBinds) pats -matchBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from a 'ConPatOut'. -patBinds :: Pat GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }}) -#else -patBinds (ConPatOut { pat_dicts = dicts }) -#endif - = fmap idType dicts -patBinds _ = [] - - ------------------------------------------------------------------------------- --- | Extract the types of the evidence bindings in scope. -wrapper :: HsWrapper -> [PredType] -wrapper (WpCompose h h2) = wrapper h <> wrapper h2 -wrapper (WpEvLam v) = [idType v] -wrapper _ = [] - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs deleted file mode 100644 index e898358c49..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Wingman.KnownStrategies where - -import Data.Foldable (for_) -import Development.IDE.GHC.Compat.Core -import Refinery.Tactic -import Wingman.Judgements (jGoal) -import Wingman.KnownStrategies.QuickCheck (deriveArbitrary) -import Wingman.Machinery (tracing, getKnownInstance, getCurrentDefinitions) -import Wingman.Tactics -import Wingman.Types - - -knownStrategies :: TacticsM () -knownStrategies = choice - [ known "fmap" deriveFmap - , known "mempty" deriveMempty - , known "arbitrary" deriveArbitrary - , known "<>" deriveMappend - , known "mappend" deriveMappend - ] - - -known :: String -> TacticsM () -> TacticsM () -known name t = do - getCurrentDefinitions >>= \case - [(def, _)] | def == mkVarOcc name -> - tracing ("known " <> name) t - _ -> failure NoApplicableTactic - - -deriveFmap :: TacticsM () -deriveFmap = do - try intros - overAlgebraicTerms homo - choice - [ overFunctions (apply Saturated) >> auto' 2 - , assumption - , recursion - ] - - ------------------------------------------------------------------------------- --- | We derive mappend by binding the arguments, introducing the constructor, --- and then calling mappend recursively. At each recursive call, we filter away --- any binding that isn't in an analogous position. --- --- The recursive call first attempts to use an instance in scope. If that fails, --- it falls back to trying a theta method from the hypothesis with the correct --- name. -deriveMappend :: TacticsM () -deriveMappend = do - try intros - destructAll - split - g <- goal - minst <- getKnownInstance (mkClsOcc "Semigroup") - . pure - . unCType - $ jGoal g - for_ minst $ \(cls, df) -> do - restrictPositionForApplication - (applyMethod cls df $ mkVarOcc "<>") - assumption - try $ - restrictPositionForApplication - (applyByName $ mkVarOcc "<>") - assumption - - ------------------------------------------------------------------------------- --- | We derive mempty by introducing the constructor, and then trying to --- 'mempty' everywhere. This smaller 'mempty' might come from an instance in --- scope, or it might come from the hypothesis theta. -deriveMempty :: TacticsM () -deriveMempty = do - split - g <- goal - minst <- getKnownInstance (mkClsOcc "Monoid") [unCType $ jGoal g] - for_ minst $ \(cls, df) -> do - applyMethod cls df $ mkVarOcc "mempty" - try assumption - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs deleted file mode 100644 index b14e4b8348..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Wingman.KnownStrategies.QuickCheck where - -import Data.Bool (bool) -import Data.Generics (everything, mkQ) -import Data.List (partition) -import Development.IDE.GHC.Compat -import GHC.Exts (IsString (fromString)) -import GHC.List (foldl') -import GHC.SourceGen (int) -import GHC.SourceGen.Binds (match, valBind) -import GHC.SourceGen.Expr (case', lambda, let') -import GHC.SourceGen.Overloaded (App ((@@)), HasList (list)) -import GHC.SourceGen.Pat (conP) -import Refinery.Tactic (goal, rule, failure) -import Wingman.CodeGen -import Wingman.Judgements (jGoal) -import Wingman.Machinery (tracePrim) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Known tactic for deriving @arbitrary :: Gen a@. This tactic splits the --- type's data cons into terminal and inductive cases, and generates code that --- produces a terminal if the QuickCheck size parameter is <=1, or any data con --- otherwise. It correctly scales recursive parameters, ensuring termination. -deriveArbitrary :: TacticsM () -deriveArbitrary = do - ty <- jGoal <$> goal - case splitTyConApp_maybe $ unCType ty of - Just (gen_tc, [splitTyConApp_maybe -> Just (tc, apps)]) - | occNameString (occName $ tyConName gen_tc) == "Gen" -> do - rule $ \_ -> do - let dcs = tyConDataCons tc - (terminal, big) = partition ((== 0) . genRecursiveCount) - $ fmap (mkGenerator tc apps) dcs - terminal_expr = mkVal "terminal" - oneof_expr = mkVal "oneof" - pure - $ Synthesized (tracePrim "deriveArbitrary") - -- TODO(sandy): This thing is not actually empty! We produced - -- a bespoke binding "terminal", and a not-so-bespoke "n". - -- But maybe it's fine for known rules? - mempty - mempty - mempty - $ noLoc $ case terminal of - [onlyCon] -> genExpr onlyCon -- See #1879 - _ -> let' [valBind (fromString "terminal") $ list $ fmap genExpr terminal] $ - appDollar (mkFunc "sized") $ lambda [bvar' (mkVarOcc "n")] $ - case' (infixCall "<=" (mkVal "n") (int 1)) - [ match [conP (fromString "True") []] $ - oneof_expr @@ terminal_expr - , match [conP (fromString "False") []] $ - appDollar oneof_expr $ - infixCall "<>" - (list $ fmap genExpr big) - terminal_expr - ] - _ -> failure $ GoalMismatch "deriveArbitrary" ty - - ------------------------------------------------------------------------------- --- | Helper data type for the generator of a specific data con. -data Generator = Generator - { genRecursiveCount :: Integer - , genExpr :: HsExpr GhcPs - } - - ------------------------------------------------------------------------------- --- | Make a 'Generator' for a given tycon instantiated with the given @[Type]@. -mkGenerator :: TyCon -> [Type] -> DataCon -> Generator -mkGenerator tc apps dc = do - let dc_expr = var' $ occName $ dataConName dc - args = conLikeInstOrigArgTys' (RealDataCon dc) apps - num_recursive_calls = sum $ fmap (bool 0 1 . doesTypeContain tc) args - mkArbitrary = mkArbitraryCall tc num_recursive_calls - Generator num_recursive_calls $ case args of - [] -> mkFunc "pure" @@ dc_expr - (a : as) -> - foldl' - (infixCall "<*>") - (infixCall "<$>" dc_expr $ mkArbitrary a) - (fmap mkArbitrary as) - - ------------------------------------------------------------------------------- --- | Check if the given 'TyCon' exists anywhere in the 'Type'. -doesTypeContain :: TyCon -> Type -> Bool -doesTypeContain recursive_tc = - everything (||) $ mkQ False (== recursive_tc) - - ------------------------------------------------------------------------------- --- | Generate the correct sort of call to @arbitrary@. For recursive calls, we --- need to scale down the size parameter, either by a constant factor of 1 if --- it's the only recursive parameter, or by @`div` n@ where n is the number of --- recursive parameters. For all other types, just call @arbitrary@ directly. -mkArbitraryCall :: TyCon -> Integer -> Type -> HsExpr GhcPs -mkArbitraryCall recursive_tc n ty = - let arbitrary = mkFunc "arbitrary" - in case doesTypeContain recursive_tc ty of - True -> - mkFunc "scale" - @@ bool (mkFunc "flip" @@ mkFunc "div" @@ int n) - (mkFunc "subtract" @@ int 1) - (n == 1) - @@ arbitrary - False -> arbitrary diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs deleted file mode 100644 index 044061d579..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs +++ /dev/null @@ -1,662 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.LanguageServer where - -import Control.Arrow ((***)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.RWS -import Control.Monad.State (State, evalState) -import Control.Monad.Trans.Maybe -import Data.Bifunctor (first) -import Data.Coerce -import Data.Functor ((<&>)) -import Data.Functor.Identity (runIdentity) -import qualified Data.HashMap.Strict as Map -import Data.IORef (readIORef) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Traversable -import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction) -import Development.IDE.Core.PositionMapping (idDelta) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Rules (usePropertyAction) -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule) -import qualified Development.IDE.Core.Shake as IDE -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Development.IDE.GHC.Compat.ExactPrint -import qualified Development.IDE.GHC.Compat.Util as FastString -import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) -import Development.IDE.Graph (Action, RuleResult, Rules, action) -import Development.IDE.Graph.Classes (Hashable, NFData) -import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) -import GHC.Generics (Generic) -import Generics.SYB hiding (Generic) -import qualified Ide.Plugin.Config as Plugin -import Ide.Plugin.Properties -import Ide.PluginUtils (usePropertyLsp) -import Ide.Types (PluginId) -import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) -import Language.LSP.Server (MonadLsp, sendNotification) -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities -import Prelude hiding (span) -import Retrie (transformA) -import Wingman.Context -import Wingman.GHC -import Wingman.Judgements -import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ) -import Wingman.Judgements.Theta -import Wingman.Range -import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) -import Wingman.Types -import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) -import qualified Development.IDE.Core.Shake as Shake - - -newtype Log - = LogShake Shake.Log - deriving Show - -instance Pretty Log where - pretty = \case - LogShake shakeLog -> pretty shakeLog - -tacticDesc :: T.Text -> T.Text -tacticDesc name = "fill the hole using the " <> name <> " tactic" - - ------------------------------------------------------------------------------- --- | The name of the command for the LS. -tcCommandName :: TacticCommand -> T.Text -tcCommandName = T.pack . show - - -runIde :: String -> String -> IdeState -> Action a -> IO a -runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state - -runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a -runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state) - - -runCurrentIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO (Tracked 'Current r) -runCurrentIde herald state nfp a = - MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp - - -runStaleIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO (TrackedStale r) -runStaleIde herald state nfp a = - MaybeT $ runIde herald (show a) state $ useWithStale a nfp - - -unsafeRunStaleIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO r -unsafeRunStaleIde herald state nfp a = do - (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp - pure r - -unsafeRunStaleIdeFast - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO r -unsafeRunStaleIdeFast herald state nfp a = do - (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp - pure r - - ------------------------------------------------------------------------------- - -properties :: Properties - '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity)) - , 'PropertyKey "max_use_ctor_actions" 'TInteger - , 'PropertyKey "timeout_duration" 'TInteger - , 'PropertyKey "auto_gas" 'TInteger - , 'PropertyKey "proofstate_styling" 'TBoolean - ] -properties = emptyProperties - & defineBooleanProperty #proofstate_styling - "Should Wingman emit styling markup when showing metaprogram proof states?" True - & defineIntegerProperty #auto_gas - "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4 - & defineIntegerProperty #timeout_duration - "The timeout for Wingman actions, in seconds" 2 - & defineIntegerProperty #max_use_ctor_actions - "Maximum number of `Use constructor ` code actions that can appear" 5 - & defineEnumProperty #hole_severity - "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities." - [ (Just DsError, "error") - , (Just DsWarning, "warning") - , (Just DsInfo, "info") - , (Just DsHint, "hint") - , (Nothing, "none") - ] - Nothing - - --- | Get the the plugin config -getTacticConfigAction :: PluginId -> Action Config -getTacticConfigAction pId = - Config - <$> usePropertyAction #max_use_ctor_actions pId properties - <*> usePropertyAction #timeout_duration pId properties - <*> usePropertyAction #auto_gas pId properties - <*> usePropertyAction #proofstate_styling pId properties - - -getIdeDynflags - :: IdeState - -> NormalizedFilePath - -> MaybeT IO DynFlags -getIdeDynflags state nfp = do - -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' - -- which don't change very often. - msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps - pure $ ms_hspp_opts $ msrModSummary msr - -getAllMetaprograms :: Data a => a -> [String] -getAllMetaprograms = everything (<>) $ mkQ mempty $ \case - WingmanMetaprogram fs -> [ FastString.unpackFS fs ] - (_ :: HsExpr GhcTc) -> mempty - - ------------------------------------------------------------------------------- --- | Find the last typechecked module, and find the most specific span, as well --- as the judgement at the given range. -judgementForHole - :: IdeState - -> NormalizedFilePath - -> Tracked 'Current Range - -> Config - -> MaybeT IO HoleJudgment -judgementForHole state nfp range cfg = do - let stale a = runStaleIde "judgementForHole" state nfp a - - TrackedStale asts amapping <- stale GetHieAst - case unTrack asts of - HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" - HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do - range' <- liftMaybe $ mapAgeFrom amapping range - binds <- stale GetBindings - tcg@(TrackedStale tcg_t tcg_map) - <- fmap (fmap tmrTypechecked) - $ stale TypeCheck - - hscenv <- stale GhcSessionDeps - - (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf - - new_rss <- liftMaybe $ mapAgeTo amapping rss - tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss - - -- KnownThings is just the instances in scope. There are no ranges - -- involved, so it's not crucial to track ages. - let henv = untrackedStaleValue hscenv - eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv - - (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps - let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t - - dflags <- getIdeDynflags state nfp - pure $ HoleJudgment - { hj_range = fmap realSrcSpanToRange new_rss - , hj_jdg = jdg - , hj_ctx = ctx - , hj_dflags = dflags - , hj_hole_sort = holeSortFor mp - } - - -holeSortFor :: Maybe T.Text -> HoleSort -holeSortFor = maybe Hole Metaprogram - - -mkJudgementAndContext - :: Config - -> Type - -> TrackedStale Bindings - -> Tracked 'Current RealSrcSpan - -> TrackedStale TcGblEnv - -> HscEnv - -> ExternalPackageState - -> Maybe (Judgement, Context) -mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do - binds_rss <- mapAgeFrom bmap rss - tcg_rss <- mapAgeFrom tcgmap rss - - let tcs = fmap tcg_binds tcg - ctx = mkContext cfg - (mapMaybe (sequenceA . (occName *** coerce)) - $ unTrack - $ getDefiningBindings <$> binds <*> binds_rss) - (unTrack tcg) - hscenv - eps - evidence - top_provs = getRhsPosVals tcg_rss tcs - already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs - local_hy = spliceProvenance top_provs - $ hypothesisFromBindings binds_rss binds - evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs - cls_hy = foldMap evidenceToHypothesis evidence - subst = ts_unifier $ evidenceToSubst evidence defaultTacticState - pure - ( disallowing AlreadyDestructed already_destructed - $ fmap (CType . substTyAddInScope subst . unCType) $ - mkFirstJudgement - ctx - (local_hy <> cls_hy) - (isRhsHoleWithoutWhere tcg_rss tcs) - g - , ctx - ) - - ------------------------------------------------------------------------------- --- | Determine which bindings have already been destructed by the location of --- the hole. -getAlreadyDestructed - :: Tracked age SrcSpan - -> Tracked age (LHsBinds GhcTc) - -> Set OccName -getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = - everythingContaining span - (mkQ mempty $ \case - Case (HsVar _ (L _ (occName -> var))) _ -> - S.singleton var - (_ :: HsExpr GhcTc) -> mempty - ) binds - - -getSpanAndTypeAtHole - :: Tracked age Range - -> Tracked age (HieASTs Type) - -> Maybe (Tracked age RealSrcSpan, Type) -getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do - join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of - Nothing -> Nothing - Just ast' -> do - let info = nodeInfo ast' - ty <- listToMaybe $ nodeType info - guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info - -- Ensure we're actually looking at a hole here - occ <- (either (const Nothing) (Just . occName) =<<) - . listToMaybe - . S.toList - . M.keysSet - $ nodeIdentifiers info - guard $ isHole occ - pure (unsafeCopyAge r $ nodeSpan ast', ty) - - - ------------------------------------------------------------------------------- --- | Combine two (possibly-overlapping) hypotheses; using the provenance from --- the first hypothesis if the bindings overlap. -spliceProvenance - :: Hypothesis a -- ^ Bindings to keep - -> Hypothesis a -- ^ Bindings to keep if they don't overlap with the first set - -> Hypothesis a -spliceProvenance top x = - let bound = S.fromList $ fmap hi_name $ unHypothesis top - in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x - - ------------------------------------------------------------------------------- --- | Compute top-level position vals of a function -getRhsPosVals - :: Tracked age RealSrcSpan - -> Tracked age TypecheckedSource - -> Hypothesis CType -getRhsPosVals (unTrack -> rss) (unTrack -> tcs) - = everything (<>) (mkQ mempty $ \case - TopLevelRHS name ps - (L (RealSrcSpan span _) -- body with no guards and a single defn - (HsVar _ (L _ hole))) - _ - | containsSpan rss span -- which contains our span - , isHole $ occName hole -- and the span is a hole - -> flip evalState 0 $ buildTopLevelHypothesis name ps - _ -> mempty - ) tcs - - ------------------------------------------------------------------------------- --- | Construct a hypothesis given the patterns from the left side of a HsMatch. --- These correspond to things that the user put in scope before running --- tactics. -buildTopLevelHypothesis - :: OccName -- ^ Function name - -> [PatCompat GhcTc] - -> State Int (Hypothesis CType) -buildTopLevelHypothesis name ps = do - fmap mconcat $ - for (zip [0..] ps) $ \(ix, p) -> - buildPatHy (TopLevelArgPrv name ix $ length ps) p - - ------------------------------------------------------------------------------- --- | Construct a hypothesis for a single pattern, including building --- sub-hypotheses for constructor pattern matches. -buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType) -buildPatHy prov (fromPatCompat -> p0) = - case p0 of - VarPat _ x -> pure $ mkIdHypothesis (unLoc x) prov - LazyPat _ p -> buildPatHy prov p - AsPat _ x p -> do - hy' <- buildPatHy prov p - pure $ mkIdHypothesis (unLoc x) prov <> hy' - ParPat _ p -> buildPatHy prov p - BangPat _ p -> buildPatHy prov p - ViewPat _ _ p -> buildPatHy prov p - -- Desugar lists into cons - ListPat _ [] -> pure mempty - ListPat x@(ListPatTc ty _) (p : ps) -> - mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] - [ (0, p) - , (1, toPatCompat $ ListPat x ps) - ] - -- Desugar tuples into an explicit constructor - TuplePat tys pats boxity -> - mkDerivedConHypothesis - prov - (RealDataCon $ tupleDataCon boxity $ length pats) - tys - $ zip [0.. ] pats -#if __GLASGOW_HASKELL__ >= 900 - ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} -> -#else - ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} -> -#endif - case f of - PrefixCon l_pgt -> - mkDerivedConHypothesis prov con args $ zip [0..] l_pgt - InfixCon pgt pgt5 -> - mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] - RecCon r -> - mkDerivedRecordHypothesis prov con args r - SigPat _ p _ -> buildPatHy prov p - _ -> pure mempty - - ------------------------------------------------------------------------------- --- | Like 'mkDerivedConHypothesis', but for record patterns. -mkDerivedRecordHypothesis - :: Provenance - -> ConLike -- ^ Destructing constructor - -> [Type] -- ^ Applied type variables - -> HsRecFields GhcTc (PatCompat GhcTc) - -> State Int (Hypothesis CType) -mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _) - | Just rec_fields <- getRecordFields dc - = do - let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..] - mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) -> - ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ) - , p - ) -mkDerivedRecordHypothesis _ _ _ _ = - error "impossible! using record pattern on something that isn't a record" - - ------------------------------------------------------------------------------- --- | Construct a fake variable name. Used to track the provenance of top-level --- pattern matches which otherwise wouldn't have anything to attach their --- 'TopLevelArgPrv' to. -mkFakeVar :: State Int OccName -mkFakeVar = do - i <- get - put $ i + 1 - pure $ mkVarOcc $ "_" <> show i - - ------------------------------------------------------------------------------- --- | Construct a fake variable to attach the current 'Provenance' to, and then --- build a sub-hypothesis for the pattern match. -mkDerivedConHypothesis - :: Provenance - -> ConLike -- ^ Destructing constructor - -> [Type] -- ^ Applied type variables - -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con - -> State Int (Hypothesis CType) -mkDerivedConHypothesis prov dc args ps = do - var <- mkFakeVar - hy' <- fmap mconcat $ - for ps $ \(ix, p) -> do - let prov' = PatternMatchPrv - $ PatVal (Just var) - (S.singleton var <> provAncestryOf prov) - (Uniquely dc) - ix - buildPatHy prov' p - pure - $ mappend hy' - $ Hypothesis - $ pure - $ HyInfo var (DisallowedPrv AlreadyDestructed prov) - $ CType - -- TODO(sandy): This is the completely wrong type, but we don't have a good - -- way to get the real one. It's probably OK though, since we're generating - -- this term with a disallowed provenance, and it doesn't actually exist - -- anyway. - $ conLikeResTy dc args - - ------------------------------------------------------------------------------- --- | Build a 'Hypothesis' given an 'Id'. -mkIdHypothesis :: Id -> Provenance -> Hypothesis CType -mkIdHypothesis (splitId -> (name, ty)) prov = - Hypothesis $ pure $ HyInfo name prov ty - - ------------------------------------------------------------------------------- --- | Is this hole immediately to the right of an equals sign --- and is there --- no where clause attached to it? --- --- It's important that there is no where clause because otherwise it gets --- clobbered. See #2183 for an example. --- --- This isn't a perfect check, and produces some ugly code. But it's much much --- better than the alternative, which is to destructively modify the user's --- AST. -isRhsHoleWithoutWhere - :: Tracked age RealSrcSpan - -> Tracked age TypecheckedSource - -> Bool -isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = - everything (||) (mkQ False $ \case - TopLevelRHS _ _ - (L (RealSrcSpan span _) _) - (EmptyLocalBinds _) -> containsSpan rss span - _ -> False - ) tcs - - -ufmSeverity :: UserFacingMessage -> MessageType -ufmSeverity NotEnoughGas = MtInfo -ufmSeverity TacticErrors = MtError -ufmSeverity TimedOut = MtInfo -ufmSeverity NothingToDo = MtInfo -ufmSeverity (InfrastructureError _) = MtError - - -mkShowMessageParams :: UserFacingMessage -> ShowMessageParams -mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm - - -showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () -showLspMessage = sendNotification SWindowShowMessage - - --- This rule only exists for generating file diagnostics --- so the RuleResult is empty -data WriteDiagnostics = WriteDiagnostics - deriving (Eq, Show, Typeable, Generic) - -instance Hashable WriteDiagnostics -instance NFData WriteDiagnostics - -type instance RuleResult WriteDiagnostics = () - -data GetMetaprograms = GetMetaprograms - deriving (Eq, Show, Typeable, Generic) - -instance Hashable GetMetaprograms -instance NFData GetMetaprograms - -type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] - -wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -wingmanRules recorder plId = do - define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> - usePropertyAction #hole_severity plId properties >>= \case - Nothing -> pure (mempty, Just ()) - Just severity -> - use GetParsedModule nfp >>= \case - Nothing -> - pure ([], Nothing) - Just pm -> do - let holes :: [Range] - holes = - everything (<>) - (mkQ mempty $ \case - L span (HsVar _ (L _ name)) - | isHole (occName name) -> - maybeToList $ srcSpanToRange span -#if __GLASGOW_HASKELL__ >= 900 - L span (HsUnboundVar _ occ) -#else - L span (HsUnboundVar _ (TrueExprHole occ)) -#endif - | isHole occ -> - maybeToList $ srcSpanToRange span - (_ :: LHsExpr GhcPs) -> mempty - ) $ pm_parsed_source pm - pure - ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes - , Just () - ) - - defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do - TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp - let scrutinees = traverse (metaprogramQ . tcg_binds) tcg - return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do - case ss of - RealSrcSpan r _ -> do - rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r - pure (rss', program) - UnhelpfulSpan _ -> Nothing - - -- This persistent rule helps to avoid blocking HLS hover providers at startup - -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other - -- hover providers from being used to produce a response - addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing) - - action $ do - files <- getFilesOfInterestUntracked - void $ uses WriteDiagnostics $ Map.keys files - - -mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic -mkDiagnostic severity r = - Diagnostic r - (Just severity) - (Just $ InR "hole") - (Just "wingman") - "Hole" - (Just $ List [DtUnnecessary]) - Nothing - - ------------------------------------------------------------------------------- --- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. -mkWorkspaceEdits - :: DynFlags - -> ClientCapabilities - -> Uri - -> Annotated ParsedSource - -> Graft (Either String) ParsedSource - -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits dflags ccs uri pm g = do - let pm' = runIdentity $ transformA pm annotateMetaprograms - let response = transform dflags ccs uri g pm' - in first (InfrastructureError . T.pack) response - - ------------------------------------------------------------------------------- --- | Add ExactPrint annotations to every metaprogram in the source tree. --- Usually the ExactPrint module can do this for us, but we've enabled --- QuasiQuotes, so the round-trip print/parse journey will crash. -annotateMetaprograms :: Data a => a -> Transform a -annotateMetaprograms = everywhereM $ mkM $ \case - L ss (WingmanMetaprogram mp) -> do - let x = L ss $ MetaprogramSyntax mp - let anns = addAnnotationsForPretty [] x mempty - modifyAnnsT $ mappend anns - pure x - (x :: LHsExpr GhcPs) -> pure x - - ------------------------------------------------------------------------------- --- | Find the source of a tactic metaprogram at the given span. -getMetaprogramAtSpan - :: Tracked age SrcSpan - -> Tracked age TcGblEnv - -> Maybe T.Text -getMetaprogramAtSpan (unTrack -> ss) - = fmap snd - . listToMaybe - . metaprogramAtQ ss - . tcg_binds - . unTrack - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs deleted file mode 100644 index 272f60e1a2..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE RankNTypes #-} - -module Wingman.LanguageServer.Metaprogram - ( hoverProvider - ) where - -import Control.Applicative (empty) -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Data.List (find) -import Data.Maybe -import qualified Data.Text as T -import Development.IDE (positionToRealSrcLoc, realSrcSpanToRange) -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Ide.Types -import Language.LSP.Types -import Prelude hiding (span) -import Wingman.LanguageServer -import Wingman.Metaprogramming.Parser (attempt_it) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Provide the "empty case completion" code lens -hoverProvider :: PluginMethodHandler IdeState TextDocumentHover -hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos - stale = unsafeRunStaleIdeFast "hoverProvider" state nfp - - cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) - liftIO $ fromMaybeT (Right Nothing) $ do - holes <- stale GetMetaprograms - - fmap (Right . Just) $ - case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of - Just (trss, program) -> do - let tr_range = fmap realSrcSpanToRange trss - rsl = realSrcSpanStart $ unTrack trss - HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg - z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program - pure $ Hover - { _contents = HoverContents - $ MarkupContent MkMarkdown - $ either T.pack T.pack z - , _range = Just $ unTrack tr_range - } - Nothing -> empty -hoverProvider _ _ _ = pure $ Right Nothing - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs deleted file mode 100644 index 68da7fc5c0..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.LanguageServer.TacticProviders - ( commandProvider - , commandTactic - , TacticProviderData (..) - ) where - -import Control.Monad -import Data.Bool (bool) -import Data.Coerce -import Data.Maybe -import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Ide.Types hiding (Config) -import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) -import Prelude hiding (span) -import Wingman.AbstractLSP.Types -import Wingman.Auto -import Wingman.GHC -import Wingman.Judgements -import Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons) -import Wingman.Metaprogramming.Parser (parseMetaprogram) -import Wingman.Tactics -import Wingman.Types - - ------------------------------------------------------------------------------- --- | A mapping from tactic commands to actual tactics for refinery. -commandTactic :: TacticCommand -> T.Text -> TacticsM () -commandTactic Auto = const auto -commandTactic Intros = const intros -commandTactic IntroAndDestruct = const introAndDestruct -commandTactic Destruct = useNameFromHypothesis destruct . mkVarOcc . T.unpack -commandTactic DestructPun = useNameFromHypothesis destructPun . mkVarOcc . T.unpack -commandTactic Homomorphism = useNameFromHypothesis homo . mkVarOcc . T.unpack -commandTactic DestructLambdaCase = const destructLambdaCase -commandTactic HomomorphismLambdaCase = const homoLambdaCase -commandTactic DestructAll = const destructAll -commandTactic UseDataCon = userSplit . mkVarOcc . T.unpack -commandTactic Refine = const refine -commandTactic BeginMetaprogram = const metaprogram -commandTactic RunMetaprogram = parseMetaprogram - - ------------------------------------------------------------------------------- --- | The LSP kind -tacticKind :: TacticCommand -> T.Text -tacticKind Auto = "fillHole" -tacticKind Intros = "introduceLambda" -tacticKind IntroAndDestruct = "introduceAndDestruct" -tacticKind Destruct = "caseSplit" -tacticKind DestructPun = "caseSplitPun" -tacticKind Homomorphism = "homomorphicCaseSplit" -tacticKind DestructLambdaCase = "lambdaCase" -tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase" -tacticKind DestructAll = "splitFuncArgs" -tacticKind UseDataCon = "useConstructor" -tacticKind Refine = "refine" -tacticKind BeginMetaprogram = "beginMetaprogram" -tacticKind RunMetaprogram = "runMetaprogram" - - ------------------------------------------------------------------------------- --- | Whether or not this code action is preferred -- ostensibly refers to --- whether or not we can bind it to a key in vs code? -tacticPreferred :: TacticCommand -> Bool -tacticPreferred Auto = True -tacticPreferred Intros = True -tacticPreferred IntroAndDestruct = True -tacticPreferred Destruct = True -tacticPreferred DestructPun = False -tacticPreferred Homomorphism = True -tacticPreferred DestructLambdaCase = False -tacticPreferred HomomorphismLambdaCase = False -tacticPreferred DestructAll = True -tacticPreferred UseDataCon = True -tacticPreferred Refine = True -tacticPreferred BeginMetaprogram = False -tacticPreferred RunMetaprogram = True - - -mkTacticKind :: TacticCommand -> CodeActionKind -mkTacticKind = - CodeActionUnknown . mappend "refactor.wingman." . tacticKind - - ------------------------------------------------------------------------------- --- | Mapping from tactic commands to their contextual providers. See 'provide', --- 'filterGoalType' and 'filterBindingType' for the nitty gritty. -commandProvider :: TacticCommand -> TacticProvider -commandProvider Auto = - requireHoleSort (== Hole) $ - provide Auto "" -commandProvider Intros = - requireHoleSort (== Hole) $ - filterGoalType isFunction $ - provide Intros "" -commandProvider IntroAndDestruct = - requireHoleSort (== Hole) $ - filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $ - provide IntroAndDestruct "" -commandProvider Destruct = - requireHoleSort (== Hole) $ - filterBindingType destructFilter $ \occ _ -> - provide Destruct $ T.pack $ occNameString occ -commandProvider DestructPun = - requireHoleSort (== Hole) $ - filterBindingType destructPunFilter $ \occ _ -> - provide DestructPun $ T.pack $ occNameString occ -commandProvider Homomorphism = - requireHoleSort (== Hole) $ - filterBindingType homoFilter $ \occ _ -> - provide Homomorphism $ T.pack $ occNameString occ -commandProvider DestructLambdaCase = - requireHoleSort (== Hole) $ - requireExtension LambdaCase $ - filterGoalType (isJust . lambdaCaseable) $ - provide DestructLambdaCase "" -commandProvider HomomorphismLambdaCase = - requireHoleSort (== Hole) $ - requireExtension LambdaCase $ - filterGoalType (liftLambdaCase False homoFilter) $ - provide HomomorphismLambdaCase "" -commandProvider DestructAll = - requireHoleSort (== Hole) $ - withJudgement $ \jdg -> - case _jIsTopHole jdg && jHasBoundArgs jdg of - True -> provide DestructAll "" - False -> mempty -commandProvider UseDataCon = - requireHoleSort (== Hole) $ - withConfig $ \cfg -> - filterTypeProjection - ( guardLength (<= cfg_max_use_ctor_actions cfg) - . maybe [] fst - . tacticsGetDataCons - ) $ \dcon -> - provide UseDataCon - . T.pack - . occNameString - . occName - $ dataConName dcon -commandProvider Refine = - requireHoleSort (== Hole) $ - provide Refine "" -commandProvider BeginMetaprogram = - requireHoleSort (== Hole) $ - provide BeginMetaprogram "" -commandProvider RunMetaprogram = - withMetaprogram $ \mp -> - provide RunMetaprogram mp - - ------------------------------------------------------------------------------- --- | Return an empty list if the given predicate doesn't hold over the length -guardLength :: (Int -> Bool) -> [a] -> [a] -guardLength f as = bool [] as $ f $ length as - - ------------------------------------------------------------------------------- --- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS --- UI. -type TacticProvider - = TacticProviderData - -> [(Metadata, T.Text)] - - -data TacticProviderData = TacticProviderData - { tpd_lspEnv :: LspEnv - , tpd_jdg :: Judgement - , tpd_hole_sort :: HoleSort - } - - -requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider -requireHoleSort p tp tpd = - case p $ tpd_hole_sort tpd of - True -> tp tpd - False -> [] - -withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider -withMetaprogram tp tpd = - case tpd_hole_sort tpd of - Metaprogram mp -> tp mp tpd - _ -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -requireExtension :: Extension -> TacticProvider -> TacticProvider -requireExtension ext tp tpd = - case xopt ext $ le_dflags $ tpd_lspEnv tpd of - True -> tp tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider -filterGoalType p tp tpd = - case p $ unCType $ jGoal $ tpd_jdg tpd of - True -> tp tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -withJudgement :: (Judgement -> TacticProvider) -> TacticProvider -withJudgement tp tpd = tp (tpd_jdg tpd) tpd - - ------------------------------------------------------------------------------- --- | Multiply a 'TacticProvider' for each binding, making sure it appears only --- when the given predicate holds over the goal and binding types. -filterBindingType - :: (Type -> Type -> Bool) -- ^ Goal and then binding types. - -> (OccName -> Type -> TacticProvider) - -> TacticProvider -filterBindingType p tp tpd = - let jdg = tpd_jdg tpd - hy = jLocalHypothesis jdg - g = jGoal jdg - in unHypothesis hy >>= \hi -> - let ty = unCType $ hi_type hi - in case p (unCType g) ty of - True -> tp (hi_name hi) ty tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Multiply a 'TacticProvider' by some feature projection out of the goal --- type. Used e.g. to crete a code action for every data constructor. -filterTypeProjection - :: (Type -> [a]) -- ^ Features of the goal to look into further - -> (a -> TacticProvider) - -> TacticProvider -filterTypeProjection p tp tpd = - (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a -> - tp a tpd - - ------------------------------------------------------------------------------- --- | Get access to the 'Config' when building a 'TacticProvider'. -withConfig :: (Config -> TacticProvider) -> TacticProvider -withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd - - ------------------------------------------------------------------------------- --- | Terminal constructor for providing context-sensitive tactics. Tactics --- given by 'provide' are always available. -provide :: TacticCommand -> T.Text -> TacticProvider -provide tc name _ = - pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name) - - ------------------------------------------------------------------------------- --- | Construct a 'CommandId' -tcCommandId :: TacticCommand -> CommandId -tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command" - - ------------------------------------------------------------------------------- --- | We should show homos only when the goal type is the same as the binding --- type, and that both are usual algebraic types. -homoFilter :: Type -> Type -> Bool -homoFilter codomain domain = - case uncoveredDataCons domain codomain of - Just s -> S.null s - _ -> False - - ------------------------------------------------------------------------------- --- | Lift a function of (codomain, domain) over a lambda case. -liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r -liftLambdaCase nil f t = - case tacticsSplitFunTy t of - (_, _, arg : _, res) -> f res $ scaledThing arg - _ -> nil - - - ------------------------------------------------------------------------------- --- | We should show destruct for bindings only when those bindings have usual --- algebraic types. -destructFilter :: Type -> Type -> Bool -destructFilter _ (algebraicTyCon -> Just _) = True -destructFilter _ _ = False - - ------------------------------------------------------------------------------- --- | We should show destruct punning for bindings only when those bindings have --- usual algebraic types, and when any of their data constructors are records. -destructPunFilter :: Type -> Type -> Bool -destructPunFilter _ (algebraicTyCon -> Just tc) = - not . all (null . dataConFieldLabels) $ tyConDataCons tc -destructPunFilter _ _ = False - - -instance IsContinuationSort TacticCommand where - toCommandId = tcCommandId - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs deleted file mode 100644 index 278304644e..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.Machinery where - -import Control.Applicative (empty) -import Control.Concurrent.Chan.Unagi.NoBlocking (newChan, writeChan, OutChan, tryRead, tryReadChan) -import Control.Lens ((<>~)) -import Control.Monad.Reader -import Control.Monad.State.Class (gets, modify, MonadState) -import Control.Monad.State.Strict (StateT (..), execStateT) -import Control.Monad.Trans.Maybe -import Data.Coerce -import Data.Foldable -import Data.Functor ((<&>)) -import Data.Generics (everything, gcount, mkQ) -import Data.Generics.Product (field') -import Data.List (sortBy) -import qualified Data.Map as M -import Data.Maybe (mapMaybe, isNothing) -import Data.Monoid (getSum) -import Data.Ord (Down (..), comparing) -import qualified Data.Set as S -import Data.Traversable (for) -import Development.IDE.Core.Compile (lookupName) -import Development.IDE.GHC.Compat hiding (isTopLevel, empty) -import Refinery.Future -import Refinery.ProofState -import Refinery.Tactic -import Refinery.Tactic.Internal -import System.Timeout (timeout) -import Wingman.Context (getInstance) -import Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars, tryUnifyUnivarsButNotSkolemsMany) -import Wingman.Judgements -import Wingman.Simplify (simplify) -import Wingman.Types - -#if __GLASGOW_HASKELL__ < 900 -import FunDeps (fd_eqs, improveFromInstEnv) -import Pair (unPair) -#else -import GHC.Tc.Instance.FunDeps (fd_eqs, improveFromInstEnv) -import GHC.Data.Pair (unPair) -#endif - - -substCTy :: TCvSubst -> CType -> CType -substCTy subst = coerce . substTy subst . coerce - - -getSubstForJudgement - :: MonadState TacticState m - => Judgement - -> m TCvSubst -getSubstForJudgement j = do - -- NOTE(sandy): It's OK to use mempty here, because coercions _can_ give us - -- substitutions for skolems. - let coercions = j_coercion j - unifier <- gets ts_unifier - pure $ unionTCvSubst unifier coercions - ------------------------------------------------------------------------------- --- | Produce a subgoal that must be solved before we can solve the original --- goal. -newSubgoal - :: Judgement - -> Rule -newSubgoal j = do - ctx <- ask - unifier <- getSubstForJudgement j - subgoal - $ normalizeJudgement ctx - $ substJdg unifier - $ unsetIsTopHole - $ normalizeJudgement ctx j - - -tacticToRule :: Judgement -> TacticsM () -> Rule -tacticToRule jdg (TacticT tt) = RuleT $ execStateT tt jdg >>= flip Subgoal Axiom - - -consumeChan :: OutChan (Maybe a) -> IO [a] -consumeChan chan = do - tryReadChan chan >>= tryRead >>= \case - Nothing -> pure [] - Just (Just a) -> (a:) <$> consumeChan chan - Just Nothing -> pure [] - - ------------------------------------------------------------------------------- --- | Attempt to generate a term of the right type using in-scope bindings, and --- a given tactic. -runTactic - :: Int -- ^ Timeout - -> Context - -> Judgement - -> TacticsM () -- ^ Tactic to use - -> IO (Either [TacticError] RunTacticResults) -runTactic duration ctx jdg t = do - let skolems = S.fromList - $ foldMap (tyCoVarsOfTypeWellScoped . unCType) - $ (:) (jGoal jdg) - $ fmap hi_type - $ toList - $ hyByName - $ jHypothesis jdg - tacticState = - defaultTacticState - { ts_skolems = skolems - } - - let stream = hoistListT (flip runReaderT ctx . unExtractM) - $ runStreamingTacticT t jdg tacticState - (in_proofs, out_proofs) <- newChan - (in_errs, out_errs) <- newChan - timed_out <- - fmap isNothing $ timeout duration $ consume stream $ \case - Left err -> writeChan in_errs $ Just err - Right proof -> writeChan in_proofs $ Just proof - writeChan in_proofs Nothing - - solns <- consumeChan out_proofs - let sorted = - flip sortBy solns $ comparing $ \(Proof ext _ holes) -> - Down $ scoreSolution ext jdg $ fmap snd holes - case sorted of - ((Proof syn _ subgoals) : _) -> - pure $ Right $ - RunTacticResults - { rtr_trace = syn_trace syn - , rtr_extract = simplify $ syn_val syn - , rtr_subgoals = fmap snd subgoals - , rtr_other_solns = reverse . fmap pf_extract $ sorted - , rtr_jdg = jdg - , rtr_ctx = ctx - , rtr_timed_out = timed_out - } - _ -> fmap Left $ consumeChan out_errs - - -tracePrim :: String -> Trace -tracePrim = flip rose [] - - ------------------------------------------------------------------------------- --- | Mark that a tactic used the given string in its extract derivation. Mainly --- used for debugging the search when things go terribly wrong. -tracing - :: Functor m - => String - -> TacticT jdg (Synthesized ext) err s m a - -> TacticT jdg (Synthesized ext) err s m a -tracing s = mappingExtract (mapTrace $ rose s . pure) - - ------------------------------------------------------------------------------- --- | Mark that a tactic performed recursion. Doing so incurs a small penalty in --- the score. -markRecursion - :: Functor m - => TacticT jdg (Synthesized ext) err s m a - -> TacticT jdg (Synthesized ext) err s m a -markRecursion = mappingExtract (field' @"syn_recursion_count" <>~ 1) - - ------------------------------------------------------------------------------- --- | Map a function over the extract created by a tactic. -mappingExtract - :: Functor m - => (ext -> ext) - -> TacticT jdg ext err s m a - -> TacticT jdg ext err s m a -mappingExtract f (TacticT m) - = TacticT $ StateT $ \jdg -> - mapExtract id f $ runStateT m jdg - - ------------------------------------------------------------------------------- --- | Given the results of running a tactic, score the solutions by --- desirability. --- --- NOTE: This function is completely unprincipled and was just hacked together --- to produce the right test results. -scoreSolution - :: Synthesized (LHsExpr GhcPs) - -> Judgement - -> [Judgement] - -> ( Penalize Int -- number of holes - , Reward Bool -- all bindings used - , Penalize Int -- unused top-level bindings - , Penalize Int -- number of introduced bindings - , Reward Int -- number used bindings - , Penalize Int -- number of recursive calls - , Penalize Int -- size of extract - ) -scoreSolution ext goal holes - = ( Penalize $ length holes - , Reward $ S.null $ intro_vals S.\\ used_vals - , Penalize $ S.size unused_top_vals - , Penalize $ S.size intro_vals - , Reward $ S.size used_vals + length used_user_vals - , Penalize $ getSum $ syn_recursion_count ext - , Penalize $ solutionSize $ syn_val ext - ) - where - initial_scope = hyByName $ jEntireHypothesis goal - intro_vals = M.keysSet $ hyByName $ syn_scoped ext - used_vals = S.intersection intro_vals $ syn_used_vals ext - used_user_vals = filter (isLocalHypothesis . hi_provenance) - $ mapMaybe (flip M.lookup initial_scope) - $ S.toList - $ syn_used_vals ext - top_vals = S.fromList - . fmap hi_name - . filter (isTopLevel . hi_provenance) - . unHypothesis - $ syn_scoped ext - unused_top_vals = top_vals S.\\ used_vals - - ------------------------------------------------------------------------------- --- | Compute the number of 'LHsExpr' nodes; used as a rough metric for code --- size. -solutionSize :: LHsExpr GhcPs -> Int -solutionSize = everything (+) $ gcount $ mkQ False $ \case - (_ :: LHsExpr GhcPs) -> True - - -newtype Penalize a = Penalize a - deriving (Eq, Ord, Show) via (Down a) - -newtype Reward a = Reward a - deriving (Eq, Ord, Show) via a - - ------------------------------------------------------------------------------- --- | Generate a unique unification variable. -newUnivar :: MonadState TacticState m => m Type -newUnivar = do - freshTyvars $ - mkInfForAllTys [alphaTyVar] alphaTy - - ------------------------------------------------------------------------------- --- | Attempt to unify two types. -unify :: CType -- ^ The goal type - -> CType -- ^ The type we are trying unify the goal type with - -> RuleM () -unify goal inst = do - skolems <- gets ts_skolems - case tryUnifyUnivarsButNotSkolems skolems goal inst of - Just subst -> - modify $ updateSubst subst - Nothing -> cut - ------------------------------------------------------------------------------- --- | Get a substitution out of a theta's fundeps -learnFromFundeps - :: ThetaType - -> RuleM () -learnFromFundeps theta = do - inst_envs <- asks ctxInstEnvs - skolems <- gets ts_skolems - subst <- gets ts_unifier - let theta' = substTheta subst theta - fundeps = foldMap (foldMap fd_eqs . improveFromInstEnv inst_envs (\_ _ -> ())) theta' - case tryUnifyUnivarsButNotSkolemsMany skolems $ fmap unPair fundeps of - Just subst -> - modify $ updateSubst subst - Nothing -> cut - - -cut :: RuleT jdg ext err s m a -cut = RuleT Empty - - ------------------------------------------------------------------------------- --- | Attempt to unify two types. -canUnify - :: MonadState TacticState m - => CType -- ^ The goal type - -> CType -- ^ The type we are trying unify the goal type with - -> m Bool -canUnify goal inst = do - skolems <- gets ts_skolems - case tryUnifyUnivarsButNotSkolems skolems goal inst of - Just _ -> pure True - Nothing -> pure False - - ------------------------------------------------------------------------------- --- | Prefer the first tactic to the second, if the bool is true. Otherwise, just run the second tactic. --- --- This is useful when you have a clever pruning solution that isn't always --- applicable. -attemptWhen :: TacticsM a -> TacticsM a -> Bool -> TacticsM a -attemptWhen _ t2 False = t2 -attemptWhen t1 t2 True = commit t1 t2 - - ------------------------------------------------------------------------------- --- | Run the given tactic iff the current hole contains no univars. Skolems and --- already decided univars are OK though. -requireConcreteHole :: TacticsM a -> TacticsM a -requireConcreteHole m = do - jdg <- goal - skolems <- gets ts_skolems - let vars = S.fromList $ tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg - case S.size $ vars S.\\ skolems of - 0 -> m - _ -> failure TooPolymorphic - - ------------------------------------------------------------------------------- --- | The 'try' that comes in refinery 0.3 causes unnecessary backtracking and --- balloons the search space. This thing just tries it, but doesn't backtrack --- if it fails. --- --- NOTE(sandy): But there's a bug! Or at least, something not understood here. --- Using this everywhere breaks te tests, and neither I nor TOTBWF are sure --- why. Prefer 'try' if you can, and only try this as a last resort. --- --- TODO(sandy): Remove this when we upgrade to 0.4 -try' - :: Functor m - => TacticT jdg ext err s m () - -> TacticT jdg ext err s m () -try' t = commit t $ pure () - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -exact :: HsExpr GhcPs -> TacticsM () -exact = rule . const . pure . pure . noLoc - ------------------------------------------------------------------------------- --- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to --- look it up in the hypothesis. -useNameFromHypothesis :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a -useNameFromHypothesis f name = do - hy <- jHypothesis <$> goal - case M.lookup name $ hyByName hy of - Just hi -> f hi - Nothing -> failure $ NotInScope name - ------------------------------------------------------------------------------- --- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to --- look it up in the hypothesis. -useNameFromContext :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a -useNameFromContext f name = do - lookupNameInContext name >>= \case - Just ty -> f $ createImportedHyInfo name ty - Nothing -> failure $ NotInScope name - - ------------------------------------------------------------------------------- --- | Find the type of an 'OccName' that is defined in the current module. -lookupNameInContext :: MonadReader Context m => OccName -> m (Maybe CType) -lookupNameInContext name = do - ctx <- asks ctxModuleFuncs - pure $ case find ((== name) . fst) ctx of - Just (_, ty) -> pure ty - Nothing -> empty - - -getDefiningType - :: TacticsM CType -getDefiningType = do - calling_fun_name <- asks (fst . head . ctxDefiningFuncs) - maybe - (failure $ NotInScope calling_fun_name) - pure - =<< lookupNameInContext calling_fun_name - - ------------------------------------------------------------------------------- --- | Build a 'HyInfo' for an imported term. -createImportedHyInfo :: OccName -> CType -> HyInfo CType -createImportedHyInfo on ty = HyInfo - { hi_name = on - , hi_provenance = ImportPrv - , hi_type = ty - } - - -getTyThing - :: OccName - -> TacticsM (Maybe TyThing) -getTyThing occ = do - ctx <- ask - case lookupOccEnv (ctx_occEnv ctx) occ of - Just (elt : _) -> do - mvar <- lift - $ ExtractM - $ lift - $ lookupName (ctx_hscEnv ctx) - $ gre_name elt - pure mvar - _ -> pure Nothing - - ------------------------------------------------------------------------------- --- | Like 'getTyThing' but specialized to classes. -knownClass :: OccName -> TacticsM (Maybe Class) -knownClass occ = - getTyThing occ <&> \case - Just (ATyCon tc) -> tyConClass_maybe tc - _ -> Nothing - - ------------------------------------------------------------------------------- --- | Like 'getInstance', but uses a class that it just looked up. -getKnownInstance :: OccName -> [Type] -> TacticsM (Maybe (Class, PredType)) -getKnownInstance f tys = runMaybeT $ do - cls <- MaybeT $ knownClass f - MaybeT $ getInstance cls tys - - ------------------------------------------------------------------------------- --- | Lookup the type of any 'OccName' that was imported. Necessarily done in --- IO, so we only expose this functionality to the parser. Internal Haskell --- code that wants to lookup terms should do it via 'KnownThings'. -getOccNameType - :: OccName - -> TacticsM Type -getOccNameType occ = do - getTyThing occ >>= \case - Just (AnId v) -> pure $ varType v - _ -> failure $ NotInScope occ - - -getCurrentDefinitions :: TacticsM [(OccName, CType)] -getCurrentDefinitions = do - ctx_funcs <- asks ctxDefiningFuncs - for ctx_funcs $ \res@(occ, _) -> - pure . maybe res (occ,) =<< lookupNameInContext occ - - ------------------------------------------------------------------------------- --- | Given two types, see if we can construct a homomorphism by mapping every --- data constructor in the domain to the same in the codomain. This function --- returns 'Just' when all the lookups succeeded, and a non-empty value if the --- homomorphism *is not* possible. -uncoveredDataCons :: Type -> Type -> Maybe (S.Set (Uniquely DataCon)) -uncoveredDataCons domain codomain = do - (g_dcs, _) <- tacticsGetDataCons codomain - (hi_dcs, _) <- tacticsGetDataCons domain - pure $ S.fromList (coerce hi_dcs) S.\\ S.fromList (coerce g_dcs) - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs deleted file mode 100644 index fed7e91bbd..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.Metaprogramming.Lexer where - -import Control.Applicative -import Control.Monad -import Data.Foldable (asum) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import Development.IDE.GHC.Compat.Core (OccName, mkVarOcc) -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as L - -type Parser = P.Parsec Void Text - - - -lineComment :: Parser () -lineComment = L.skipLineComment "--" - -blockComment :: Parser () -blockComment = L.skipBlockComment "{-" "-}" - -sc :: Parser () -sc = L.space P.space1 lineComment blockComment - -ichar :: Parser Char -ichar = P.alphaNumChar <|> P.char '_' <|> P.char '\'' - -symchar :: Parser Char -symchar = asum - [ P.symbolChar - , P.char '!' - , P.char '#' - , P.char '$' - , P.char '%' - , P.char '^' - , P.char '&' - , P.char '*' - , P.char '-' - , P.char '=' - , P.char '+' - , P.char ':' - , P.char '<' - , P.char '>' - , P.char ',' - , P.char '.' - , P.char '/' - , P.char '?' - , P.char '~' - , P.char '|' - , P.char '\\' - ] - -lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc - -symbol :: Text -> Parser Text -symbol = L.symbol sc - -symbol_ :: Text -> Parser () -symbol_ = void . symbol - -brackets :: Parser a -> Parser a -brackets = P.between (symbol "[") (symbol "]") - -braces :: Parser a -> Parser a -braces = P.between (symbol "{") (symbol "}") - -parens :: Parser a -> Parser a -parens = P.between (symbol "(") (symbol ")") - -identifier :: Text -> Parser () -identifier i = lexeme (P.string i *> P.notFollowedBy ichar) - -variable :: Parser OccName -variable = lexeme $ do - c <- P.alphaNumChar <|> P.char '(' - fmap mkVarOcc $ case c of - '(' -> do - cs <- P.many symchar - void $ P.char ')' - pure cs - _ -> do - cs <- P.many ichar - pure $ c : cs - -name :: Parser Text -name = lexeme $ do - c <- P.alphaNumChar - cs <- P.many (ichar <|> P.char '-') - pure $ T.pack (c:cs) - -keyword :: Text -> Parser () -keyword = identifier - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs deleted file mode 100644 index a1d4eca4d4..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs +++ /dev/null @@ -1,501 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Wingman.Metaprogramming.Parser where - -import qualified Control.Monad.Combinators.Expr as P -import Data.Either (fromRight) -import Data.Functor -import Data.Maybe (listToMaybe) -import qualified Data.Text as T -import Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile) -import Development.IDE.GHC.Compat.Util (unpackFS) -import Refinery.Tactic (failure) -import qualified Refinery.Tactic as R -import qualified Text.Megaparsec as P -import Wingman.Auto -import Wingman.Machinery (useNameFromHypothesis, useNameFromContext, getCurrentDefinitions) -import Wingman.Metaprogramming.Lexer -import Wingman.Metaprogramming.Parser.Documentation -import Wingman.Metaprogramming.ProofState (proofState, layout) -import Wingman.Tactics -import Wingman.Types - - -nullary :: T.Text -> TacticsM () -> Parser (TacticsM ()) -nullary name tac = identifier name $> tac - - -unary_occ :: T.Text -> (OccName -> TacticsM ()) -> Parser (TacticsM ()) -unary_occ name tac = tac <$> (identifier name *> variable) - - ------------------------------------------------------------------------------- --- | Like 'unary_occ', but runs directly in the 'Parser' monad. -unary_occM :: T.Text -> (OccName -> Parser (TacticsM ())) -> Parser (TacticsM ()) -unary_occM name tac = tac =<< (identifier name *> variable) - - -variadic_occ :: T.Text -> ([OccName] -> TacticsM ()) -> Parser (TacticsM ()) -variadic_occ name tac = tac <$> (identifier name *> P.many variable) - - -commands :: [SomeMetaprogramCommand] -commands = - [ command "assumption" Nondeterministic Nullary - "Use any term in the hypothesis that can unify with the current goal." - (pure assumption) - [ Example - Nothing - [] - [EHI "some_a_val" "a"] - (Just "a") - "some_a_val" - ] - - , command "assume" Deterministic (Ref One) - "Use the given term from the hypothesis, unifying it with the current goal" - (pure . assume) - [ Example - Nothing - ["some_a_val"] - [EHI "some_a_val" "a"] - (Just "a") - "some_a_val" - ] - - , command "intros" Deterministic (Bind Many) - ( mconcat - [ "Construct a lambda expression, using the specific names if given, " - , "generating unique names otherwise. When no arguments are given, " - , "all of the function arguments will be bound; otherwise, this " - , "tactic will bind only enough to saturate the given names. Extra " - , "names are ignored." - ]) - (pure . \case - [] -> intros - names -> intros' $ IntroduceOnlyNamed names - ) - [ Example - Nothing - [] - [] - (Just "a -> b -> c -> d") - "\\a b c -> (_ :: d)" - , Example - Nothing - ["aye"] - [] - (Just "a -> b -> c -> d") - "\\aye -> (_ :: b -> c -> d)" - , Example - Nothing - ["x", "y", "z", "w"] - [] - (Just "a -> b -> c -> d") - "\\x y z -> (_ :: d)" - ] - - , command "idiom" Deterministic Tactic - "Lift a tactic into idiom brackets." - (pure . idiom) - [ Example - Nothing - ["(apply f)"] - [EHI "f" "a -> b -> Int"] - (Just "Maybe Int") - "f <$> (_ :: Maybe a) <*> (_ :: Maybe b)" - ] - - , command "intro" Deterministic (Bind One) - "Construct a lambda expression, binding an argument with the given name." - (pure . intros' . IntroduceOnlyNamed . pure) - [ Example - Nothing - ["aye"] - [] - (Just "a -> b -> c -> d") - "\\aye -> (_ :: b -> c -> d)" - ] - - , command "destruct_all" Deterministic Nullary - "Pattern match on every function paramater, in original binding order." - (pure destructAll) - [ Example - (Just "Assume `a` and `b` were bound via `f a b = _`.") - [] - [EHI "a" "Bool", EHI "b" "Maybe Int"] - Nothing $ - T.pack $ init $ unlines - [ "case a of" - , " False -> case b of" - , " Nothing -> _" - , " Just i -> _" - , " True -> case b of" - , " Nothing -> _" - , " Just i -> _" - ] - ] - - , command "destruct" Deterministic (Ref One) - "Pattern match on the argument." - (pure . useNameFromHypothesis destruct) - [ Example - Nothing - ["a"] - [EHI "a" "Bool"] - Nothing $ - T.pack $ init $ unlines - [ "case a of" - , " False -> _" - , " True -> _" - ] - ] - - , command "homo" Deterministic (Ref One) - ( mconcat - [ "Pattern match on the argument, and fill the resulting hole in with " - , "the same data constructor." - ]) - (pure . useNameFromHypothesis homo) - [ Example - (Just $ mconcat - [ "Only applicable when the type constructor of the argument is " - , "the same as that of the hole." - ]) - ["e"] - [EHI "e" "Either a b"] - (Just "Either x y") $ - T.pack $ init $ unlines - [ "case e of" - , " Left a -> Left (_ :: x)" - , " Right b -> Right (_ :: y)" - ] - ] - - , command "application" Nondeterministic Nullary - "Apply any function in the hypothesis that returns the correct type." - (pure application) - [ Example - Nothing - [] - [EHI "f" "a -> b"] - (Just "b") - "f (_ :: a)" - ] - - , command "pointwise" Deterministic Tactic - "Restrict the hypothesis in the holes of the given tactic to align up with the top-level bindings. This will ensure, eg, that the first hole can see only terms that came from the first position in any terms destructed from the top-level bindings." - (pure . flip restrictPositionForApplication (pure ())) - [ Example - (Just "In the context of `f (a1, b1) (a2, b2) = _`. The resulting first hole can see only 'a1' and 'a2', and the second, only 'b1' and 'b2'.") - ["(use mappend)"] - [] - Nothing - "mappend _ _" - ] - - , command "apply" Deterministic (Ref One) - "Apply the given function from *local* scope." - (pure . useNameFromHypothesis (apply Saturated)) - [ Example - Nothing - ["f"] - [EHI "f" "a -> b"] - (Just "b") - "f (_ :: a)" - ] - - , command "split" Nondeterministic Nullary - "Produce a data constructor for the current goal." - (pure split) - [ Example - Nothing - [] - [] - (Just "Either a b") - "Right (_ :: b)" - ] - - , command "ctor" Deterministic (Ref One) - "Use the given data cosntructor." - (pure . userSplit) - [ Example - Nothing - ["Just"] - [] - (Just "Maybe a") - "Just (_ :: a)" - ] - - , command "obvious" Nondeterministic Nullary - "Produce a nullary data constructor for the current goal." - (pure obvious) - [ Example - Nothing - [] - [] - (Just "[a]") - "[]" - ] - - , command "auto" Nondeterministic Nullary - ( mconcat - [ "Repeatedly attempt to split, destruct, apply functions, and " - , "recurse in an attempt to fill the hole." - ]) - (pure auto) - [ Example - Nothing - [] - [EHI "f" "a -> b", EHI "g" "b -> c"] - (Just "a -> c") - "g . f" - ] - - , command "sorry" Deterministic Nullary - "\"Solve\" the goal by leaving a hole." - (pure sorry) - [ Example - Nothing - [] - [] - (Just "b") - "_ :: b" - ] - - , command "unary" Deterministic Nullary - ( mconcat - [ "Produce a hole for a single-parameter function, as well as a hole for " - , "its argument. The argument holes are completely unconstrained, and " - , "will be solved before the function." - ]) - (pure $ nary 1) - [ Example - (Just $ mconcat - [ "In the example below, the variable `a` is free, and will unify " - , "to the resulting extract from any subsequent tactic." - ]) - [] - [] - (Just "Int") - "(_2 :: a -> Int) (_1 :: a)" - ] - - , command "binary" Deterministic Nullary - ( mconcat - [ "Produce a hole for a two-parameter function, as well as holes for " - , "its arguments. The argument holes have the same type but are " - , "otherwise unconstrained, and will be solved before the function." - ]) - (pure $ nary 2) - [ Example - (Just $ mconcat - [ "In the example below, the variable `a` is free, and will unify " - , "to the resulting extract from any subsequent tactic." - ]) - [] - [] - (Just "Int") - "(_3 :: a -> a -> Int) (_1 :: a) (_2 :: a)" - ] - - , command "recursion" Deterministic Nullary - "Fill the current hole with a call to the defining function." - ( pure $ - fmap listToMaybe getCurrentDefinitions >>= \case - Just (self, _) -> useNameFromContext (apply Saturated) self - Nothing -> failure $ TacticPanic "no defining function" - ) - [ Example - (Just "In the context of `foo (a :: Int) (b :: b) = _`:") - [] - [] - Nothing - "foo (_ :: Int) (_ :: b)" - ] - - , command "use" Deterministic (Ref One) - "Apply the given function from *module* scope." - (pure . use Saturated) - [ Example - (Just "`import Data.Char (isSpace)`") - ["isSpace"] - [] - (Just "Bool") - "isSpace (_ :: Char)" - ] - - , command "cata" Deterministic (Ref One) - "Destruct the given term, recursing on every resulting binding." - (pure . useNameFromHypothesis cata) - [ Example - (Just "Assume we're called in the context of a function `f.`") - ["x"] - [EHI "x" "(a, a)"] - Nothing $ - T.pack $ init $ unlines - [ "case x of" - , " (a1, a2) ->" - , " let a1_c = f a1" - , " a2_c = f a2" - , " in _" - ] - ] - - , command "collapse" Deterministic Nullary - "Collapse every term in scope with the same type as the goal." - (pure collapse) - [ Example - Nothing - [] - [ EHI "a1" "a" - , EHI "a2" "a" - , EHI "a3" "a" - ] - (Just "a") - "(_ :: a -> a -> a -> a) a1 a2 a3" - ] - - , command "let" Deterministic (Bind Many) - "Create let-bindings for each binder given to this tactic." - (pure . letBind) - [ Example - Nothing - ["a", "b", "c"] - [ ] - (Just "x") - $ T.pack $ unlines - [ "let a = _1 :: a" - , " b = _2 :: b" - , " c = _3 :: c" - , " in (_4 :: x)" - ] - ] - - , command "try" Nondeterministic Tactic - "Simultaneously run and do not run a tactic. Subsequent tactics will bind on both states." - (pure . R.try) - [ Example - Nothing - ["(apply f)"] - [ EHI "f" "a -> b" - ] - (Just "b") - $ T.pack $ unlines - [ "-- BOTH of:\n" - , "f (_ :: a)" - , "\n-- and\n" - , "_ :: b" - ] - ] - - , command "nested" Nondeterministic (Ref One) - "Nest the given function (in module scope) with itself arbitrarily many times. NOTE: The resulting function is necessarily unsaturated, so you will likely need `with_arg` to use this tactic in a saturated context." - (pure . nested) - [ Example - Nothing - ["fmap"] - [] - (Just "[(Int, Either Bool a)] -> [(Int, Either Bool b)]") - "fmap (fmap (fmap _))" - ] - - , command "with_arg" Deterministic Nullary - "Fill the current goal with a function application. This can be useful when you'd like to fill in the argument before the function, or when you'd like to use a non-saturated function in a saturated context." - (pure with_arg) - [ Example - (Just "Where `a` is a new unifiable type variable.") - [] - [] - (Just "r") - "(_2 :: a -> r) (_1 :: a)" - ] - ] - - - -oneTactic :: Parser (TacticsM ()) -oneTactic = - P.choice - [ parens tactic - , makeParser commands - ] - - -tactic :: Parser (TacticsM ()) -tactic = P.makeExprParser oneTactic operators - -operators :: [[P.Operator Parser (TacticsM ())]] -operators = - [ [ P.InfixR (symbol "|" $> (R.<%>) )] - , [ P.InfixL (symbol ";" $> (>>)) - , P.InfixL (symbol "," $> bindOne) - ] - ] - - -tacticProgram :: Parser (TacticsM ()) -tacticProgram = do - sc - r <- tactic P.<|> pure (pure ()) - P.eof - pure r - - -wrapError :: String -> String -wrapError err = "```\n" <> err <> "\n```\n" - - -fixErrorOffset :: RealSrcLoc -> P.ParseErrorBundle a b -> P.ParseErrorBundle a b -fixErrorOffset rsl (P.ParseErrorBundle ne (P.PosState a n (P.SourcePos _ line col) pos s)) - = P.ParseErrorBundle ne - $ P.PosState a n - (P.SourcePos - (unpackFS $ srcLocFile rsl) - ((<>) line $ P.mkPos $ srcLocLine rsl - 1) - ((<>) col $ P.mkPos $ srcLocCol rsl - 1 + length @[] "[wingman|") - ) - pos - s - ------------------------------------------------------------------------------- --- | Attempt to run a metaprogram tactic, returning the proof state, or the --- errors. -attempt_it - :: RealSrcLoc - -> Context - -> Judgement - -> String - -> IO (Either String String) -attempt_it rsl ctx jdg program = - case P.runParser tacticProgram "" (T.pack program) of - Left peb -> pure $ Left $ wrapError $ P.errorBundlePretty $ fixErrorOffset rsl peb - Right tt -> do - res <- runTactic 2e6 ctx jdg tt - pure $ case res of - Left tes -> Left $ wrapError $ show tes - Right rtr -> Right - $ layout (cfg_proofstate_styling $ ctxConfig ctx) - $ proofState rtr - - -parseMetaprogram :: T.Text -> TacticsM () -parseMetaprogram - = fromRight (pure ()) - . P.runParser tacticProgram "" - - ------------------------------------------------------------------------------- --- | Automatically generate the metaprogram command reference. -writeDocumentation :: IO () -writeDocumentation = - writeFile "COMMANDS.md" $ - unlines - [ "# Wingman Metaprogram Command Reference" - , "" - , prettyReadme commands - ] - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot deleted file mode 100644 index 607db0e6f3..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Wingman.Metaprogramming.Parser where - -import Wingman.Metaprogramming.Lexer -import Wingman.Types - -tactic :: Parser (TacticsM ()) - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs deleted file mode 100644 index 0c37d6365a..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Wingman.Metaprogramming.Parser.Documentation where - -import Data.Functor ((<&>)) -import Data.List (sortOn) -import Data.String (IsString) -import Data.Text (Text) -import Prettyprinter hiding (parens) -import Prettyprinter.Render.String (renderString) -import Development.IDE.GHC.Compat (OccName) -import qualified Text.Megaparsec as P -import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens) -import Wingman.Types (TacticsM) - -import {-# SOURCE #-} Wingman.Metaprogramming.Parser (tactic) - - ------------------------------------------------------------------------------- --- | Is a tactic deterministic or not? -data Determinism - = Deterministic - | Nondeterministic - -prettyDeterminism :: Determinism -> Doc b -prettyDeterminism Deterministic = "deterministic" -prettyDeterminism Nondeterministic = "non-deterministic" - - ------------------------------------------------------------------------------- --- | How many arguments does the tactic take? -data Count a where - One :: Count OccName - Many :: Count [OccName] - -prettyCount :: Count a -> Doc b -prettyCount One = "single" -prettyCount Many = "variadic" - - ------------------------------------------------------------------------------- --- | What sorts of arguments does the tactic take? Currently there is no --- distinction between 'Ref' and 'Bind', other than documentation. --- --- The type index here is used for the shape of the function the parser should --- take. -data Syntax a where - Nullary :: Syntax (Parser (TacticsM ())) - Ref :: Count a -> Syntax (a -> Parser (TacticsM ())) - Bind :: Count a -> Syntax (a -> Parser (TacticsM ())) - Tactic :: Syntax (TacticsM () -> Parser (TacticsM ())) - -prettySyntax :: Syntax a -> Doc b -prettySyntax Nullary = "none" -prettySyntax (Ref co) = prettyCount co <+> "reference" -prettySyntax (Bind co) = prettyCount co <+> "binding" -prettySyntax Tactic = "tactic" - - ------------------------------------------------------------------------------- --- | An example for the documentation. -data Example = Example - { ex_ctx :: Maybe Text -- ^ Specific context information about when the tactic is applicable - , ex_args :: [Var] -- ^ Arguments the tactic was called with - , ex_hyp :: [ExampleHyInfo] -- ^ The hypothesis - , ex_goal :: Maybe ExampleType -- ^ Current goal. Nothing indicates it's uninteresting. - , ex_result :: Text -- ^ Resulting extract. - } - - ------------------------------------------------------------------------------- --- | An example 'HyInfo'. -data ExampleHyInfo = EHI - { ehi_name :: Var -- ^ Name of the variable - , ehi_type :: ExampleType -- ^ Type of the variable - } - - ------------------------------------------------------------------------------- --- | A variable -newtype Var = Var - { getVar :: Text - } - deriving newtype (IsString, Pretty) - - ------------------------------------------------------------------------------- --- | A type -newtype ExampleType = ExampleType - { getExampleType :: Text - } - deriving newtype (IsString, Pretty) - - ------------------------------------------------------------------------------- --- | A command to expose to the parser -data MetaprogramCommand a = MC - { mpc_name :: Text -- ^ Name of the command. This is the token necessary to run the command. - , mpc_syntax :: Syntax a -- ^ The command's arguments - , mpc_det :: Determinism -- ^ Determinism of the command - , mpc_description :: Text -- ^ User-facing description - , mpc_tactic :: a -- ^ Tactic to run - , mpc_examples :: [Example] -- ^ Collection of documentation examples - } - ------------------------------------------------------------------------------- --- | Existentialize the pain away -data SomeMetaprogramCommand where - SMC :: MetaprogramCommand a -> SomeMetaprogramCommand - - ------------------------------------------------------------------------------- --- | Run the 'Parser' of a 'MetaprogramCommand' -makeMPParser :: MetaprogramCommand a -> Parser (TacticsM ()) -makeMPParser (MC name Nullary _ _ t _) = do - identifier name - t -makeMPParser (MC name (Ref One) _ _ t _) = do - identifier name - variable >>= t -makeMPParser (MC name (Ref Many) _ _ t _) = do - identifier name - P.many variable >>= t -makeMPParser (MC name (Bind One) _ _ t _) = do - identifier name - variable >>= t -makeMPParser (MC name (Bind Many) _ _ t _) = do - identifier name - P.many variable >>= t -makeMPParser (MC name Tactic _ _ t _) = do - identifier name - parens tactic >>= t - - ------------------------------------------------------------------------------- --- | Compile a collection of metaprogram commands into a parser. -makeParser :: [SomeMetaprogramCommand] -> Parser (TacticsM ()) -makeParser ps = P.choice $ ps <&> \(SMC mp) -> makeMPParser mp - - ------------------------------------------------------------------------------- --- | Pretty print a command. -prettyCommand :: MetaprogramCommand a -> Doc b -prettyCommand (MC name syn det desc _ exs) = vsep - [ "##" <+> pretty name - , mempty - , "arguments:" <+> prettySyntax syn <> ". " - , prettyDeterminism det <> "." - , mempty - , ">" <+> align (pretty desc) - , mempty - , vsep $ fmap (prettyExample name) exs - , mempty - ] - - ------------------------------------------------------------------------------- --- | Pretty print a hypothesis. -prettyHyInfo :: ExampleHyInfo -> Doc a -prettyHyInfo hi = pretty (ehi_name hi) <+> "::" <+> pretty (ehi_type hi) - - ------------------------------------------------------------------------------- --- | Append the given term only if the first argument has elements. -mappendIfNotNull :: [a] -> a -> [a] -mappendIfNotNull [] _ = [] -mappendIfNotNull as a = as <> [a] - - ------------------------------------------------------------------------------- --- | Pretty print an example. -prettyExample :: Text -> Example -> Doc a -prettyExample name (Example m_txt args hys goal res) = - align $ vsep - [ mempty - , "### Example" - , maybe mempty ((line <>) . (<> line) . (">" <+>) . align . pretty) m_txt - , "Given:" - , mempty - , codeFence $ vsep - $ mappendIfNotNull (fmap prettyHyInfo hys) mempty - <> [ "_" <+> maybe mempty (("::" <+>). pretty) goal - ] - , mempty - , hsep - [ "running " - , enclose "`" "`" $ pretty name <> hsep (mempty : fmap pretty args) - , "will produce:" - ] - , mempty - , codeFence $ align $ pretty res - ] - - ------------------------------------------------------------------------------- --- | Make a haskell code fence. -codeFence :: Doc a -> Doc a -codeFence d = align $ vsep - [ "```haskell" - , d - , "```" - ] - - ------------------------------------------------------------------------------- --- | Render all of the commands. -prettyReadme :: [SomeMetaprogramCommand] -> String -prettyReadme - = renderString - . layoutPretty defaultLayoutOptions - . vsep - . fmap (\case SMC c -> prettyCommand c) - . sortOn (\case SMC c -> mpc_name c) - - - ------------------------------------------------------------------------------- --- | Helper function to build a 'SomeMetaprogramCommand'. -command - :: Text - -> Determinism - -> Syntax a - -> Text - -> a - -> [Example] - -> SomeMetaprogramCommand -command txt det syn txt' a exs = SMC $ - MC - { mpc_name = txt - , mpc_det = det - , mpc_syntax = syn - , mpc_description = txt' - , mpc_tactic = a - , mpc_examples = exs - } - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs deleted file mode 100644 index 8c128a9153..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Wingman.Metaprogramming.ProofState where - -import Data.Bool (bool) -import Data.Functor ((<&>)) -import qualified Data.Text as T -import Prettyprinter -import Prettyprinter.Render.Util.Panic -import Language.LSP.Types (sectionSeparator) -import Wingman.Judgements (jHypothesis) -import Wingman.Types - -renderSimplyDecorated - :: Monoid out - => (T.Text -> out) -- ^ Render plain 'Text' - -> (ann -> out) -- ^ How to render an annotation - -> (ann -> out) -- ^ How to render the removed annotation - -> SimpleDocStream ann - -> out -renderSimplyDecorated text push pop = go [] - where - go _ SFail = panicUncaughtFail - go [] SEmpty = mempty - go (_:_) SEmpty = panicInputNotFullyConsumed - go st (SChar c rest) = text (T.singleton c) <> go st rest - go st (SText _l t rest) = text t <> go st rest - go st (SLine i rest) = - text (T.singleton '\n') <> text (textSpaces i) <> go st rest - go st (SAnnPush ann rest) = push ann <> go (ann : st) rest - go (ann:st) (SAnnPop rest) = pop ann <> go st rest - go [] SAnnPop{} = panicUnpairedPop -{-# INLINE renderSimplyDecorated #-} - - -data Ann - = Goal - | Hypoth - | Status - deriving (Eq, Ord, Show, Enum, Bounded) - -forceMarkdownNewlines :: String -> String -forceMarkdownNewlines = unlines . fmap (<> " ") . lines - -layout :: Bool -> Doc Ann -> String -layout use_styling - = forceMarkdownNewlines - . T.unpack - . renderSimplyDecorated id - (renderAnn use_styling) - (renderUnann use_styling) - . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.6) - -renderAnn :: Bool -> Ann -> T.Text -renderAnn False _ = "" -renderAnn _ Goal = "" -renderAnn _ Hypoth = "```haskell\n" -renderAnn _ Status = "" - -renderUnann :: Bool -> Ann -> T.Text -renderUnann False _ = "" -renderUnann _ Goal = "" -renderUnann _ Hypoth = "\n```\n" -renderUnann _ Status = "" - -proofState :: RunTacticResults -> Doc Ann -proofState RunTacticResults{rtr_subgoals} = - vsep - $ ( annotate Status - . countFinished "goals accomplished 🎉" "goal" - $ length rtr_subgoals - ) - : pretty sectionSeparator - : fmap prettySubgoal rtr_subgoals - - -prettySubgoal :: Judgement -> Doc Ann -prettySubgoal jdg = - vsep $ - [ mempty | has_hy] <> - [ annotate Hypoth $ prettyHypothesis hy | has_hy] <> - [ "⊢" <+> annotate Goal (prettyType (_jGoal jdg)) - , pretty sectionSeparator - ] - where - hy = jHypothesis jdg - has_hy = not $ null $ unHypothesis hy - - -prettyHypothesis :: Hypothesis CType -> Doc Ann -prettyHypothesis hy = - vsep $ unHypothesis hy <&> \hi -> - prettyHyInfo hi - -prettyHyInfo :: HyInfo CType -> Doc Ann -prettyHyInfo hi = viaShow (hi_name hi) <+> "::" <+> prettyType (hi_type hi) - - -prettyType :: CType -> Doc Ann -prettyType (CType ty) = viaShow ty - - -countFinished :: Doc Ann -> Doc Ann -> Int -> Doc Ann -countFinished finished _ 0 = finished -countFinished _ thing n = count thing n - -count :: Doc Ann -> Int -> Doc Ann -count thing n = - pretty n <+> thing <> bool "" "s" (n /= 1) - -textSpaces :: Int -> T.Text -textSpaces n = T.replicate n $ T.singleton ' ' - - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs deleted file mode 100644 index 832fa117e1..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.Naming where - -import Control.Arrow -import Control.Monad.State.Strict -import Data.Aeson (camelTo2) -import Data.Bool (bool) -import Data.Char -import Data.List (isPrefixOf) -import Data.List.Extra (split) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat.Core hiding (IsFunction) -import Text.Hyphenation (hyphenate, english_US) -import Wingman.GHC (tcTyVar_maybe) - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - ------------------------------------------------------------------------------- --- | A classification of a variable, for which we have specific naming rules. --- A variable can have multiple purposes simultaneously. -data Purpose - = Function [Type] Type - | Predicate - | Continuation - | Integral - | Number - | String - | List Type - | Maybe Type - | TyConned TyCon [Type] - -- ^ Something of the form @TC a b c@ - | TyVarred TyVar [Type] - -- ^ Something of the form @m a b c@ - -pattern IsPredicate :: Type -pattern IsPredicate <- - (tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True)) - -pattern IsFunction :: [Type] -> Type -> Type -pattern IsFunction args res <- - (first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res)) - -pattern IsString :: Type -pattern IsString <- - (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True])) - -pattern IsMaybe :: Type -> Type -pattern IsMaybe a <- - (splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a])) - -pattern IsList :: Type -> Type -pattern IsList a <- - (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a])) - -pattern IsTyConned :: TyCon -> [Type] -> Type -pattern IsTyConned tc args <- - (splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args)) - -pattern IsTyVarred :: TyVar -> [Type] -> Type -pattern IsTyVarred v args <- - (tcSplitAppTys -> (tcTyVar_maybe -> Just v, args)) - - ------------------------------------------------------------------------------- --- | Get the 'Purpose's of a type. A type can have multiple purposes --- simultaneously, so the order of purposes in this function corresponds to the --- precedence of that naming rule. Which means, eg, that if a type is both --- a 'Predicate' and a 'Function', we should prefer to use the predicate naming --- rules, since they come first. -getPurposes :: Type -> [Purpose] -getPurposes ty = mconcat - [ [ Predicate | IsPredicate <- [ty] ] - , [ Function args res | IsFunction args res <- [ty] ] - , with (isIntegerTy ty) [ Integral, Number ] - , with (isIntTy ty) [ Integral, Number ] - , [ Number | isFloatingTy ty ] - , [ String | isStringTy ty ] - , [ Maybe a | IsMaybe a <- [ty] ] - , [ List a | IsList a <- [ty] ] - , [ TyVarred v args | IsTyVarred v args <- [ty] ] - , [ TyConned tc args | IsTyConned tc args <- [ty] - , not (isTupleTyCon tc) - , tc /= listTyCon ] - ] - - ------------------------------------------------------------------------------- --- | Return 'mempty' if the give bool is false. -with :: Monoid a => Bool -> a -> a -with False _ = mempty -with True a = a - - ------------------------------------------------------------------------------- --- | Names we can give functions -functionNames :: [String] -functionNames = ["f", "g", "h"] - - ------------------------------------------------------------------------------- --- | Get a ranked ordering of names for a given purpose. -purposeToName :: Purpose -> [String] -purposeToName (Function args res) - | Just tv_args <- traverse tcTyVar_maybe $ args <> pure res - = fmap (<> foldMap (occNameString . occName) tv_args) functionNames -purposeToName (Function _ _) = functionNames -purposeToName Predicate = pure "p" -purposeToName Continuation = pure "k" -purposeToName Integral = ["n", "i", "j"] -purposeToName Number = ["x", "y", "z", "w"] -purposeToName String = ["s", "str"] -purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t -purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t -purposeToName (TyVarred tv args) - | Just tv_args <- traverse tcTyVar_maybe args - = pure $ foldMap (occNameString . occName) $ tv : tv_args -purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv -purposeToName (TyConned tc args@(_:_)) - | Just tv_args <- traverse tcTyVar_maybe args - = [ mkTyConName tc - -- We insert primes to everything later, but it gets the lowest - -- precedence. Here we'd like to prefer it over the more specific type - -- name. - , mkTyConName tc <> "'" - , mconcat - [ mkTyConName tc - , bool mempty "_" $ length (mkTyConName tc) > 1 - , foldMap (occNameString . occName) tv_args - ] - ] -purposeToName (TyConned tc _) - = pure - $ mkTyConName tc - - -mkTyName :: Type -> [String] -mkTyName = purposeToName <=< getPurposes - - ------------------------------------------------------------------------------- --- | Get a good name for a type constructor. -mkTyConName :: TyCon -> String -mkTyConName tc - | tc == unitTyCon = "u" - | isSymOcc occ - = take 1 - . fmap toLower - . filterReplace isSymbol 's' - . filterReplace isPunctuation 'p' - $ name - | camels@(_:_:_) <- camelTerms name - = foldMap (fmap toLower . take 1) camels - | otherwise - = getStem - $ fmap toLower name - where - occ = getOccName tc - name = occNameString occ - - ------------------------------------------------------------------------------- --- | Split a string into its camel case components. -camelTerms :: String -> [String] -camelTerms = split (== '@') . camelTo2 '@' - - ------------------------------------------------------------------------------- --- | A stem of a string is either a special-case shortened form, or a shortened --- first syllable. If the string is one syllable, we take the full word if it's --- short, or just the first two characters if it's long. Otherwise, just take --- the first syllable. --- --- NOTE: There's no rhyme or reason here, I just experimented until I got --- results that were reasonably consistent with the names I would give things. -getStem :: String -> String -getStem str = - let s = stem str - in case (s == str, length str) of - (False, _) -> s - (True, (<= 3) -> True) -> str - _ -> take 2 str - ------------------------------------------------------------------------------- --- | Get a special-case stem, or, failing that, give back the first syllable. -stem :: String -> String -stem "char" = "c" -stem "function" = "func" -stem "bool" = "b" -stem "either" = "e" -stem "text" = "txt" -stem s = join $ take 1 $ hyphenate english_US s - - ------------------------------------------------------------------------------- --- | Maybe replace an element in the list if the predicate matches -filterReplace :: (a -> Bool) -> a -> [a] -> [a] -filterReplace f r = fmap (\a -> bool a r $ f a) - - ------------------------------------------------------------------------------- --- | Produce a unique, good name for a type. -mkGoodName - :: Set OccName -- ^ Bindings in scope; used to ensure we don't shadow anything - -> Type -- ^ The type to produce a name for - -> OccName -mkGoodName in_scope (mkTyName -> tn) - = mkVarOcc - . fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn) - . getFirst - . foldMap (\n -> bool (pure n) mempty $ check n) - $ tn <> fmap (<> "'") tn - where - check n = S.member (mkVarOcc n) $ illegalNames <> in_scope - - -illegalNames :: Set OccName -illegalNames = S.fromList $ fmap mkVarOcc - [ "case" - , "of" - , "class" - , "data" - , "do" - , "type" - , "if" - , "then" - , "else" - , "let" - , "in" - , "mdo" - , "newtype" - , "proc" - , "rec" - , "where" - ] - - - ------------------------------------------------------------------------------- --- | Given a desired name, compute a new name for it based on how many names in --- scope conflict with it. Eg, if we want to name something @x@, but already --- have @x@, @x'@ and @x2@ in scope, we will give back @x3@. -mkNumericSuffix :: Set OccName -> String -> String -mkNumericSuffix s nm = - mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s - - ------------------------------------------------------------------------------- --- | Like 'mkGoodName' but creates several apart names. -mkManyGoodNames - :: (Traversable t) - => Set OccName - -> t Type - -> t OccName -mkManyGoodNames in_scope args = - flip evalState in_scope $ for args $ \at -> do - in_scope <- get - let n = mkGoodName in_scope at - modify $ S.insert n - pure n - - ------------------------------------------------------------------------------- --- | Which names are in scope? -getInScope :: Map OccName a -> [OccName] -getInScope = M.keys - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs deleted file mode 100644 index f8b62cde72..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | A plugin that uses tactics to synthesize code -module Wingman.Plugin where - -import Control.Monad -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Plugin.CodeAction -import qualified Development.IDE.GHC.ExactPrint as E -import Ide.Types -import Language.LSP.Types -import Prelude hiding (span) -import Wingman.AbstractLSP -import Wingman.AbstractLSP.TacticActions (makeTacticInteraction) -import Wingman.EmptyCase -import Wingman.LanguageServer hiding (Log) -import qualified Wingman.LanguageServer as WingmanLanguageServer -import Wingman.LanguageServer.Metaprogram (hoverProvider) -import Wingman.StaticPlugin -import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) - -data Log - = LogWingmanLanguageServer WingmanLanguageServer.Log - | LogExactPrint E.Log - deriving Show - -instance Pretty Log where - pretty = \case - LogWingmanLanguageServer log -> pretty log - LogExactPrint exactPrintLog -> pretty exactPrintLog - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId - = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder) - $ installInteractions - ( emptyCaseInteraction - : fmap makeTacticInteraction [minBound .. maxBound] - ) - $ (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider - , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId - , pluginConfigDescriptor = - defaultConfigDescriptor - { configCustomConfig = mkCustomConfig properties - } - , pluginModifyDynflags = staticPlugin - } - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs deleted file mode 100644 index ec61efc27f..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Wingman.Range where - -import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan) -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Util as FS - - - ------------------------------------------------------------------------------- --- | Convert a DAML compiler Range to a GHC SrcSpan --- TODO(sandy): this doesn't belong here -rangeToSrcSpan :: String -> Range -> SrcSpan -rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing - - -rangeToRealSrcSpan :: String -> Range -> RealSrcSpan -rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) = - mkRealSrcSpan - (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ startLn + 1) (fromIntegral $ startCh + 1)) - (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ endLn + 1) (fromIntegral $ endCh + 1)) diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs deleted file mode 100644 index 10eaae97c7..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.Simplify - ( simplify - ) where - -import Data.Generics (GenericT, everywhere, mkT) -import Data.List.Extra (unsnoc) -import Data.Monoid (Endo (..)) -import Development.IDE.GHC.Compat -import GHC.SourceGen (var) -import GHC.SourceGen.Expr (lambda) -import Wingman.CodeGen.Utils -import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet) - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -pattern Lambda pats body <- - HsLam _ - MG {mg_alts = L _ [L _ - Match { m_pats = fmap fromPatCompat -> pats - , m_grhss = GRHSs {grhssGRHSs = [L _ ( - GRHS _ [] (L _ body))]} - }] - } - where - -- If there are no patterns to bind, just stick in the body - Lambda [] body = body - Lambda pats body = lambda pats body - - - ------------------------------------------------------------------------------- --- | Simplify an expression. -simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify - = (!!3) -- Do three passes; this should be good enough for the limited - -- amount of gas we give to auto - . iterate (everywhere $ foldEndo - [ simplifyEtaReduce - , simplifyRemoveParens - , simplifyCompose - , simplifySingleLet - ]) - - ------------------------------------------------------------------------------- --- | Like 'foldMap' but for endomorphisms. -foldEndo :: Foldable t => t (a -> a) -> a -> a -foldEndo = appEndo . foldMap Endo - - ------------------------------------------------------------------------------- --- | Perform an eta reduction. For example, transforms @\x -> (f g) x@ into --- @f g@. -simplifyEtaReduce :: GenericT -simplifyEtaReduce = mkT $ \case - Lambda - [VarPat _ (L _ pat)] - (HsVar _ (L _ a)) | pat == a -> - var "id" - Lambda - (unsnoc -> Just (pats, VarPat _ (L _ pat))) - (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) - | pat == a - -- We can only perform this simplification if @pat@ is otherwise unused. - , not (containsHsVar pat f) -> - Lambda pats f - x -> x - ------------------------------------------------------------------------------- --- | Eliminates the unnecessary binding in @let a = b in a@ -simplifySingleLet :: GenericT -simplifySingleLet = mkT $ \case - SingleLet bind [] val (HsVar _ (L _ a)) | a == bind -> val - x -> x - - ------------------------------------------------------------------------------- --- | Perform an eta-reducing function composition. For example, transforms --- @\x -> f (g (h x))@ into @f . g . h@. -simplifyCompose :: GenericT -simplifyCompose = mkT $ \case - Lambda - (unsnoc -> Just (pats, VarPat _ (L _ pat))) - (unroll -> (fs@(_:_), HsVar _ (L _ a))) - | pat == a - -- We can only perform this simplification if @pat@ is otherwise unused. - , not (containsHsVar pat fs) -> - Lambda pats (foldr1 (infixCall ".") fs) - x -> x - - ------------------------------------------------------------------------------- --- | Removes unnecessary parentheses on any token that doesn't need them. -simplifyRemoveParens :: GenericT -simplifyRemoveParens = mkT $ \case - HsPar _ (L _ x) | isAtomicHsExpr x -> x - (x :: HsExpr GhcPs) -> x - - ------------------------------------------------------------------------------- --- | Unrolls a right-associative function application of the form --- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@. -unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs) -unroll (HsPar _ (L _ x)) = unroll x -unroll (HsApp _ (L _ f) (L _ a)) = - let (fs, r) = unroll a - in (f : fs, r) -unroll x = ([], x) - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs deleted file mode 100644 index 42065aa289..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.StaticPlugin - ( staticPlugin - , metaprogramHoleName - , enableQuasiQuotes - , pattern WingmanMetaprogram - , pattern MetaprogramSyntax - ) where - -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util - -import Ide.Types - -import Data.Data -import Generics.SYB -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Driver.Plugins (purePlugin) -#else -import Plugins (purePlugin) -#endif - -staticPlugin :: DynFlagsModifications -staticPlugin = mempty - { dynFlagsModifyGlobal = - \df -> allowEmptyCaseButWithWarning - $ flip gopt_unset Opt_SortBySubsumHoleFits - $ flip gopt_unset Opt_ShowValidHoleFits - $ df - { refLevelHoleFits = Just 0 - , maxRefHoleFits = Just 0 - , maxValidHoleFits = Just 0 - , staticPlugins = staticPlugins df <> [metaprogrammingPlugin] - } - , dynFlagsModifyParser = enableQuasiQuotes - } - - -pattern MetaprogramSourceText :: SourceText -pattern MetaprogramSourceText = SourceText "wingman-meta-program" - - -pattern WingmanMetaprogram :: FastString -> HsExpr p -pattern WingmanMetaprogram mp <- -#if __GLASGOW_HASKELL__ >= 900 - HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)) - (L _ ( HsVar _ _)) -#else - HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp) - (L _ ( HsVar _ _)) -#endif - - -enableQuasiQuotes :: DynFlags -> DynFlags -enableQuasiQuotes = flip xopt_set QuasiQuotes - - --- | Wingman wants to support destructing of empty cases, but these are a parse --- error by default. So we want to enable 'EmptyCase', but then that leads to --- silent errors without 'Opt_WarnIncompletePatterns'. -allowEmptyCaseButWithWarning :: DynFlags -> DynFlags -allowEmptyCaseButWithWarning = - flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns - - -metaprogrammingPlugin :: StaticPlugin -metaprogrammingPlugin = - StaticPlugin $ PluginWithArgs pluginDefinition [] - where - pluginDefinition = defaultPlugin - { parsedResultAction = worker - , pluginRecompile = purePlugin - } - worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule - worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm } - -mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs -mkMetaprogram ss mp = -#if __GLASGOW_HASKELL__ >= 900 - HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)) -#else - HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp) -#endif - $ L ss - $ HsVar noExtField - $ L ss - $ mkRdrUnqual metaprogramHoleName - -addMetaprogrammingSyntax :: Data a => a -> a -addMetaprogrammingSyntax = - everywhere $ mkT $ \case - L ss (MetaprogramSyntax mp) -> - L ss $ mkMetaprogram ss mp - (x :: LHsExpr GhcPs) -> x - -metaprogramHoleName :: OccName -metaprogramHoleName = mkVarOcc "_$metaprogram" - -pattern MetaprogramSyntax :: FastString -> HsExpr GhcPs -pattern MetaprogramSyntax mp <- - HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp) - where - MetaprogramSyntax mp = - HsSpliceE noExtField $ - HsQuasiQuote - noExtField - (mkRdrUnqual $ mkVarOcc "splice") - (mkRdrUnqual $ mkVarOcc "wingman") - noSrcSpan - mp diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs deleted file mode 100644 index 10d87722cd..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.Tactics - ( module Wingman.Tactics - , runTactic - ) where - -import Control.Applicative (Alternative(empty), (<|>)) -import Control.Lens ((&), (%~), (<>~)) -import Control.Monad (filterM, unless) -import Control.Monad (when) -import Control.Monad.Extra (anyM) -import Control.Monad.Reader.Class (MonadReader (ask)) -import Control.Monad.State.Strict (StateT(..), runStateT, execStateT) -import Data.Bool (bool) -import Data.Foldable -import Data.Functor ((<&>)) -import Data.Generics.Labels () -import Data.List -import Data.List.Extra (dropEnd, takeEnd) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable (for) -import Development.IDE.GHC.Compat hiding (empty) -import GHC.Exts -import GHC.SourceGen ((@@)) -import GHC.SourceGen.Expr -import Refinery.Tactic -import Refinery.Tactic.Internal -import Wingman.CodeGen -import Wingman.GHC -import Wingman.Judgements -import Wingman.Machinery -import Wingman.Naming -import Wingman.StaticPlugin (pattern MetaprogramSyntax) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Use something in the hypothesis to fill the hole. -assumption :: TacticsM () -assumption = attemptOn (S.toList . allNames) assume - - ------------------------------------------------------------------------------- --- | Use something named in the hypothesis to fill the hole. -assume :: OccName -> TacticsM () -assume name = rule $ \jdg -> do - case M.lookup name $ hyByName $ jHypothesis jdg of - Just (hi_type -> ty) -> do - unify ty $ jGoal jdg - pure $ - -- This slightly terrible construct is producing a mostly-empty - -- 'Synthesized'; but there is no monoid instance to do something more - -- reasonable for a default value. - (pure (noLoc $ var' name)) - { syn_trace = tracePrim $ "assume " <> occNameString name - , syn_used_vals = S.singleton name <> getAncestry jdg name - } - Nothing -> cut - - ------------------------------------------------------------------------------- --- | Like 'apply', but uses an 'OccName' available in the context --- or the module -use :: Saturation -> OccName -> TacticsM () -use sat occ = do - ctx <- ask - ty <- case lookupNameInContext occ ctx of - Just ty -> pure ty - Nothing -> CType <$> getOccNameType occ - apply sat $ createImportedHyInfo occ ty - - -recursion :: TacticsM () --- TODO(sandy): This tactic doesn't fire for the @AutoThetaFix@ golden test, --- presumably due to running afoul of 'requireConcreteHole'. Look into this! -recursion = requireConcreteHole $ tracing "recursion" $ do - defs <- getCurrentDefinitions - attemptOn (const defs) $ \(name, ty) -> markRecursion $ do - jdg <- goal - -- Peek allows us to look at the extract produced by this block. - peek - ( do - let hy' = recursiveHypothesis defs - ctx <- ask - localTactic (apply Saturated $ HyInfo name RecursivePrv ty) (introduce ctx hy') - <@> fmap (localTactic assumption . filterPosition name) [0..] - ) $ \ext -> do - let pat_vals = jPatHypothesis jdg - -- Make sure that the recursive call contains at least one already-bound - -- pattern value. This ensures it is structurally smaller, and thus - -- suggests termination. - case any (flip M.member pat_vals) $ syn_used_vals ext of - True -> Nothing - False -> Just UnhelpfulRecursion - - -restrictPositionForApplication :: TacticsM () -> TacticsM () -> TacticsM () -restrictPositionForApplication f app = do - -- NOTE(sandy): Safe use of head; context is guaranteed to have a defining - -- binding - name <- head . fmap fst <$> getCurrentDefinitions - f <@> - fmap - (localTactic app . filterPosition name) [0..] - - ------------------------------------------------------------------------------- --- | Introduce a lambda binding every variable. -intros :: TacticsM () -intros = intros' IntroduceAllUnnamed - - -data IntroParams - = IntroduceAllUnnamed - | IntroduceOnlyNamed [OccName] - | IntroduceOnlyUnnamed Int - deriving stock (Eq, Ord, Show) - - ------------------------------------------------------------------------------- --- | Introduce a lambda binding every variable. -intros' - :: IntroParams - -> TacticsM () -intros' params = rule $ \jdg -> do - let g = jGoal jdg - case tacticsSplitFunTy $ unCType g of - (_, _, [], _) -> cut -- failure $ GoalMismatch "intros" g - (_, _, scaledArgs, res) -> do - let args = fmap scaledThing scaledArgs - ctx <- ask - let gen_names = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) args - occs = case params of - IntroduceAllUnnamed -> gen_names - IntroduceOnlyNamed names -> names - IntroduceOnlyUnnamed n -> take n gen_names - num_occs = length occs - top_hole = isTopHole ctx jdg - bindings = zip occs $ coerce args - bound_occs = fmap fst bindings - hy' = lambdaHypothesis top_hole bindings - jdg' = introduce ctx hy' - $ withNewGoal (CType $ mkVisFunTys (drop num_occs scaledArgs) res) jdg - ext <- newSubgoal jdg' - pure $ - ext - & #syn_trace %~ rose ("intros {" <> intercalate ", " (fmap show bound_occs) <> "}") - . pure - & #syn_scoped <>~ hy' - & #syn_val %~ noLoc . lambda (fmap bvar' bound_occs) . unLoc - - ------------------------------------------------------------------------------- --- | Introduce a single lambda argument, and immediately destruct it. -introAndDestruct :: TacticsM () -introAndDestruct = do - hy <- fmap unHypothesis $ hyDiff $ intros' $ IntroduceOnlyUnnamed 1 - -- This case should never happen, but I'm validating instead of parsing. - -- Adding a log to be reminded if the invariant ever goes false. - -- - -- But note that this isn't a game-ending bug. In the worst case, we'll - -- accidentally bind too many variables, and incorrectly unify between them. - -- Which means some GADT cases that should be eliminated won't be --- not the - -- end of the world. - unless (length hy == 1) $ - traceMX "BUG: Introduced too many variables for introAndDestruct! Please report me if you see this! " hy - - for_ hy destruct - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. -destructAuto :: HyInfo CType -> TacticsM () -destructAuto hi = requireConcreteHole $ tracing "destruct(auto)" $ do - jdg <- goal - let subtactic = destructOrHomoAuto hi - case isPatternMatch $ hi_provenance hi of - True -> - pruning subtactic $ \jdgs -> - let getHyTypes = S.fromList . fmap hi_type . unHypothesis . jHypothesis - new_hy = foldMap getHyTypes jdgs - old_hy = getHyTypes jdg - in case S.null $ new_hy S.\\ old_hy of - True -> Just $ UnhelpfulDestruct $ hi_name hi - False -> Nothing - False -> subtactic - - ------------------------------------------------------------------------------- --- | When running auto, in order to prune the auto search tree, we try --- a homomorphic destruct whenever possible. If that produces any results, we --- can probably just prune the other side. -destructOrHomoAuto :: HyInfo CType -> TacticsM () -destructOrHomoAuto hi = tracing "destructOrHomoAuto" $ do - jdg <- goal - let g = unCType $ jGoal jdg - ty = unCType $ hi_type hi - - attemptWhen - (rule $ destruct' False (\dc jdg -> - buildDataCon False jdg dc $ snd $ splitAppTys g) hi) - (rule $ destruct' False (const newSubgoal) hi) - $ case (splitTyConApp_maybe g, splitTyConApp_maybe ty) of - (Just (gtc, _), Just (tytc, _)) -> gtc == tytc - _ -> False - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. -destruct :: HyInfo CType -> TacticsM () -destruct hi = requireConcreteHole $ tracing "destruct(user)" $ - rule $ destruct' False (const newSubgoal) hi - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. Performs record punning. -destructPun :: HyInfo CType -> TacticsM () -destructPun hi = requireConcreteHole $ tracing "destructPun(user)" $ - rule $ destruct' True (const newSubgoal) hi - - ------------------------------------------------------------------------------- --- | Case split, using the same data constructor in the matches. -homo :: HyInfo CType -> TacticsM () -homo hi = requireConcreteHole . tracing "homo" $ do - jdg <- goal - let g = jGoal jdg - - -- Ensure that every data constructor in the domain type is covered in the - -- codomain; otherwise 'homo' will produce an ill-typed program. - case uncoveredDataCons (coerce $ hi_type hi) (coerce g) of - Just uncovered_dcs -> - unless (S.null uncovered_dcs) $ - failure $ TacticPanic "Can't cover every datacon in domain" - _ -> failure $ TacticPanic "Unable to fetch datacons" - - rule - $ destruct' - False - (\dc jdg -> buildDataCon False jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg) - hi - - ------------------------------------------------------------------------------- --- | LambdaCase split, and leave holes in the matches. -destructLambdaCase :: TacticsM () -destructLambdaCase = - tracing "destructLambdaCase" $ rule $ destructLambdaCase' False (const newSubgoal) - - ------------------------------------------------------------------------------- --- | LambdaCase split, using the same data constructor in the matches. -homoLambdaCase :: TacticsM () -homoLambdaCase = - tracing "homoLambdaCase" $ - rule $ destructLambdaCase' False $ \dc jdg -> - buildDataCon False jdg dc - . snd - . splitAppTys - . unCType - $ jGoal jdg - - -newtype Saturation = Unsaturated Int - deriving (Eq, Ord, Show) - -pattern Saturated :: Saturation -pattern Saturated = Unsaturated 0 - - -apply :: Saturation -> HyInfo CType -> TacticsM () -apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do - jdg <- goal - let g = jGoal jdg - ty = unCType $ hi_type hi - func = hi_name hi - ty' <- freshTyvars ty - let (_, theta, all_args, ret) = tacticsSplitFunTy ty' - saturated_args = dropEnd n all_args - unsaturated_args = takeEnd n all_args - rule $ \jdg -> do - unify g (CType $ mkVisFunTys unsaturated_args ret) - learnFromFundeps theta - ext - <- fmap unzipTrace - $ traverse ( newSubgoal - . blacklistingDestruct - . flip withNewGoal jdg - . CType - . scaledThing - ) saturated_args - pure $ - ext - & #syn_used_vals %~ (\x -> S.insert func x <> getAncestry jdg func) - & #syn_val %~ mkApply func . fmap unLoc - -application :: TacticsM () -application = overFunctions $ apply Saturated - - ------------------------------------------------------------------------------- --- | Choose between each of the goal's data constructors. -split :: TacticsM () -split = tracing "split(user)" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Nothing -> failure $ GoalMismatch "split" g - Just (dcs, _) -> choice $ fmap splitDataCon dcs - - ------------------------------------------------------------------------------- --- | Choose between each of the goal's data constructors. Different than --- 'split' because it won't split a data con if it doesn't result in any new --- goals. -splitAuto :: TacticsM () -splitAuto = requireConcreteHole $ tracing "split(auto)" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Nothing -> failure $ GoalMismatch "split" g - Just (dcs, _) -> do - case isSplitWhitelisted jdg of - True -> choice $ fmap splitDataCon dcs - False -> do - choice $ flip fmap dcs $ \dc -> requireNewHoles $ - splitDataCon dc - - ------------------------------------------------------------------------------- --- | Like 'split', but only works if there is a single matching data --- constructor for the goal. -splitSingle :: TacticsM () -splitSingle = tracing "splitSingle" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Just ([dc], _) -> do - splitDataCon dc - _ -> failure $ GoalMismatch "splitSingle" g - ------------------------------------------------------------------------------- --- | Like 'split', but prunes any data constructors which have holes. -obvious :: TacticsM () -obvious = tracing "obvious" $ do - pruning split $ bool (Just NoProgress) Nothing . null - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -sorry :: TacticsM () -sorry = exact $ var' $ mkVarOcc "_" - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -metaprogram :: TacticsM () -metaprogram = exact $ MetaprogramSyntax "" - - ------------------------------------------------------------------------------- --- | Allow the given tactic to proceed if and only if it introduces holes that --- have a different goal than current goal. -requireNewHoles :: TacticsM () -> TacticsM () -requireNewHoles m = do - jdg <- goal - pruning m $ \jdgs -> - case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of - True -> Nothing - False -> Just NoProgress - - ------------------------------------------------------------------------------- --- | Attempt to instantiate the given ConLike to solve the goal. --- --- INVARIANT: Assumes the given ConLike is appropriate to construct the type --- with. -splitConLike :: ConLike -> TacticsM () -splitConLike dc = - requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do - let g = jGoal jdg - case splitTyConApp_maybe $ unCType g of - Just (_, apps) -> do - buildDataCon True (unwhitelistingSplit jdg) dc apps - Nothing -> cut -- failure $ GoalMismatch "splitDataCon" g - ------------------------------------------------------------------------------- --- | Attempt to instantiate the given data constructor to solve the goal. --- --- INVARIANT: Assumes the given datacon is appropriate to construct the type --- with. -splitDataCon :: DataCon -> TacticsM () -splitDataCon = splitConLike . RealDataCon - - ------------------------------------------------------------------------------- --- | Perform a case split on each top-level argument. Used to implement the --- "Destruct all function arguments" action. -destructAll :: TacticsM () -destructAll = do - jdg <- goal - let args = fmap fst - $ sortOn snd - $ mapMaybe (\(hi, prov) -> - case prov of - TopLevelArgPrv _ idx _ -> pure (hi, idx) - _ -> Nothing - ) - $ fmap (\hi -> (hi, hi_provenance hi)) - $ filter (isAlgType . unCType . hi_type) - $ unHypothesis - $ jHypothesis jdg - for_ args $ \arg -> do - subst <- getSubstForJudgement =<< goal - destruct $ fmap (coerce substTy subst) arg - --------------------------------------------------------------------------------- --- | User-facing tactic to implement "Use constructor " -userSplit :: OccName -> TacticsM () -userSplit occ = do - jdg <- goal - let g = jGoal jdg - -- TODO(sandy): It's smelly that we need to find the datacon to generate the - -- code action, send it as a string, and then look it up again. Can we push - -- this over LSP somehow instead? - case splitTyConApp_maybe $ unCType g of - Just (tc, _) -> do - case find (sloppyEqOccName occ . occName . dataConName) - $ tyConDataCons tc of - Just dc -> splitDataCon dc - Nothing -> failure $ NotInScope occ - Nothing -> failure $ NotInScope occ - - ------------------------------------------------------------------------------- --- | @matching f@ takes a function from a judgement to a @Tactic@, and --- then applies the resulting @Tactic@. -matching :: (Judgement -> TacticsM ()) -> TacticsM () -matching f = TacticT $ StateT $ \s -> runStateT (unTacticT $ f s) s - - -attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM () -attemptOn getNames tac = matching (choice . fmap tac . getNames) - - -localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a -localTactic t f = do - TacticT $ StateT $ \jdg -> - runStateT (unTacticT t) $ f jdg - - -refine :: TacticsM () -refine = intros <%> splitSingle - - -auto' :: Int -> TacticsM () -auto' 0 = failure OutOfGas -auto' n = do - let loop = auto' (n - 1) - try intros - assumption <|> - choice - [ overFunctions $ \fname -> do - requireConcreteHole $ apply Saturated fname - loop - , overAlgebraicTerms $ \aname -> do - destructAuto aname - loop - , splitAuto >> loop - , recursion - ] - -overFunctions :: (HyInfo CType -> TacticsM ()) -> TacticsM () -overFunctions = - attemptOn $ filter (isFunction . unCType . hi_type) - . unHypothesis - . jHypothesis - -overAlgebraicTerms :: (HyInfo CType -> TacticsM ()) -> TacticsM () -overAlgebraicTerms = - attemptOn jAcceptableDestructTargets - - -allNames :: Judgement -> Set OccName -allNames = hyNamesInScope . jHypothesis - - -applyMethod :: Class -> PredType -> OccName -> TacticsM () -applyMethod cls df method_name = do - case find ((== method_name) . occName) $ classMethods cls of - Just method -> do - let (_, apps) = splitAppTys df - let ty = piResultTys (idType method) apps - apply Saturated $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty - Nothing -> failure $ NotInScope method_name - - -applyByName :: OccName -> TacticsM () -applyByName name = do - g <- goal - choice $ unHypothesis (jHypothesis g) <&> \hi -> - case hi_name hi == name of - True -> apply Saturated hi - False -> empty - - ------------------------------------------------------------------------------- --- | Make a function application where the function being applied itself is --- a hole. -applyByType :: Type -> TacticsM () -applyByType ty = tracing ("applyByType " <> show ty) $ do - jdg <- goal - let g = jGoal jdg - ty' <- freshTyvars ty - let (_, _, args, ret) = tacticsSplitFunTy ty' - rule $ \jdg -> do - unify g (CType ret) - ext - <- fmap unzipTrace - $ traverse ( newSubgoal - . blacklistingDestruct - . flip withNewGoal jdg - . CType - . scaledThing - ) args - app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg - pure $ - fmap noLoc $ - foldl' (@@) - <$> fmap unLoc app - <*> fmap (fmap unLoc) ext - - ------------------------------------------------------------------------------- --- | Make an n-ary function call of the form --- @(_ :: forall a b. a -> a -> b) _ _@. -nary :: Int -> TacticsM () -nary n = do - a <- newUnivar - b <- newUnivar - applyByType $ mkVisFunTys (replicate n $ unrestricted a) b - - -self :: TacticsM () -self = - fmap listToMaybe getCurrentDefinitions >>= \case - Just (self, _) -> useNameFromContext (apply Saturated) self - Nothing -> failure $ TacticPanic "no defining function" - - ------------------------------------------------------------------------------- --- | Perform a catamorphism when destructing the given 'HyInfo'. This will --- result in let binding, making values that call the defining function on each --- destructed value. -cata :: HyInfo CType -> TacticsM () -cata hi = do - (_, _, calling_args, _) - <- tacticsSplitFunTy . unCType <$> getDefiningType - freshened_args <- traverse (freshTyvars . scaledThing) calling_args - diff <- hyDiff $ destruct hi - - -- For for every destructed term, check to see if it can unify with any of - -- the arguments to the calling function. If it doesn't, we don't try to - -- perform a cata on it. - unifiable_diff <- flip filterM (unHypothesis diff) $ \hi -> - flip anyM freshened_args $ \ty -> - canUnify (hi_type hi) $ CType ty - - rule $ - letForEach - (mkVarOcc . flip mappend "_c" . occNameString) - (\hi -> self >> commit (assume $ hi_name hi) assumption) - $ Hypothesis unifiable_diff - - -letBind :: [OccName] -> TacticsM () -letBind occs = do - jdg <- goal - occ_tys <- for occs - $ \occ - -> fmap (occ, ) - $ fmap (<$ jdg) - $ fmap CType newUnivar - rule $ nonrecLet occ_tys - - ------------------------------------------------------------------------------- --- | Deeply nest an unsaturated function onto itself -nested :: OccName -> TacticsM () -nested = deepening . use (Unsaturated 1) - - ------------------------------------------------------------------------------- --- | Repeatedly bind a tactic on its first hole -deep :: Int -> TacticsM () -> TacticsM () -deep 0 _ = pure () -deep n t = foldr1 bindOne $ replicate n t - - ------------------------------------------------------------------------------- --- | Try 'deep' for arbitrary depths. -deepening :: TacticsM () -> TacticsM () -deepening t = - asum $ fmap (flip deep t) [0 .. 100] - - -bindOne :: TacticsM a -> TacticsM a -> TacticsM a -bindOne t t1 = t <@> [t1] - - -collapse :: TacticsM () -collapse = do - g <- goal - let terms = unHypothesis $ hyFilter ((jGoal g ==) . hi_type) $ jLocalHypothesis g - case terms of - [hi] -> assume $ hi_name hi - _ -> nary (length terms) <@> fmap (assume . hi_name) terms - - -with_arg :: TacticsM () -with_arg = rule $ \jdg -> do - let g = jGoal jdg - fresh_ty <- newUnivar - a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg - f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [unrestricted fresh_ty] g) jdg - pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a - - ------------------------------------------------------------------------------- --- | Determine the difference in hypothesis due to running a tactic. Also, it --- runs the tactic. -hyDiff :: TacticsM () -> TacticsM (Hypothesis CType) -hyDiff m = do - g <- unHypothesis . jEntireHypothesis <$> goal - let g_len = length g - m - g' <- unHypothesis . jEntireHypothesis <$> goal - pure $ Hypothesis $ take (length g' - g_len) g' - - ------------------------------------------------------------------------------- --- | Attempt to run the given tactic in "idiom bracket" mode. For example, if --- the current goal is --- --- (_ :: [r]) --- --- then @idiom apply@ will remove the applicative context, resulting in a hole: --- --- (_ :: r) --- --- and then use @apply@ to solve it. Let's say this results in: --- --- (f (_ :: a) (_ :: b)) --- --- Finally, @idiom@ lifts this back into the original applicative: --- --- (f <$> (_ :: [a]) <*> (_ :: [b])) --- --- Idiom will fail fast if the current goal doesn't have an applicative --- instance. -idiom :: TacticsM () -> TacticsM () -idiom m = do - jdg <- goal - let hole = unCType $ jGoal jdg - when (isFunction hole) $ - failure $ GoalMismatch "idiom" $ jGoal jdg - case splitAppTy_maybe hole of - Just (applic, ty) -> do - minst <- getKnownInstance (mkClsOcc "Applicative") - . pure - $ applic - case minst of - Nothing -> failure $ GoalMismatch "idiom" $ CType applic - Just (_, _) -> do - rule $ \jdg -> do - expr <- subgoalWith (withNewGoal (CType ty) jdg) m - case unLoc $ syn_val expr of - HsApp{} -> pure $ fmap idiomize expr - RecordCon{} -> pure $ fmap idiomize expr - _ -> unsolvable $ GoalMismatch "idiom" $ jGoal jdg - rule $ newSubgoal . withModifiedGoal (CType . mkAppTy applic . unCType) - Nothing -> - failure $ GoalMismatch "idiom" $ jGoal jdg - -subgoalWith :: Judgement -> TacticsM () -> RuleM (Synthesized (LHsExpr GhcPs)) -subgoalWith jdg t = RuleT $ flip execStateT jdg $ unTacticT t - diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs deleted file mode 100644 index 621cc9752e..0000000000 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs +++ /dev/null @@ -1,562 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Wingman.Types - ( module Wingman.Types - , module Wingman.Debug - , OccName - , Name - , Type - , TyVar - , Span - ) where - -import Control.Lens hiding (Context) -import Control.Monad.Reader -import Control.Monad.State -import qualified Control.Monad.State.Strict as Strict -import Data.Coerce -import Data.Function -import Data.Generics (mkM, everywhereM, Data, Typeable) -import Data.Generics.Labels () -import Data.Generics.Product (field) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tree -import Development.IDE (Range) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (Node) -import qualified Development.IDE.GHC.Compat.Util as Util -import Development.IDE.GHC.Orphans () -import GHC.Exts (fromString) -import GHC.Generics -import GHC.SourceGen (var) -import Refinery.ProofState -import Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT)) -import System.IO.Unsafe (unsafePerformIO) -import Wingman.Debug -import Data.IORef - - ------------------------------------------------------------------------------- --- | The list of tactics exposed to the outside world. These are attached to --- actual tactics via 'commandTactic' and are contextually provided to the --- editor via 'commandProvider'. -data TacticCommand - = Auto - | Intros - | IntroAndDestruct - | Destruct - | DestructPun - | Homomorphism - | DestructLambdaCase - | HomomorphismLambdaCase - | DestructAll - | UseDataCon - | Refine - | BeginMetaprogram - | RunMetaprogram - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Generate a title for the command. -tacticTitle :: TacticCommand -> T.Text -> T.Text -tacticTitle = (mappend "Wingman: " .) . go - where - go Auto _ = "Attempt to fill hole" - go Intros _ = "Introduce lambda" - go IntroAndDestruct _ = "Introduce and destruct term" - go Destruct var = "Case split on " <> var - go DestructPun var = "Split on " <> var <> " with NamedFieldPuns" - go Homomorphism var = "Homomorphic case split on " <> var - go DestructLambdaCase _ = "Lambda case split" - go HomomorphismLambdaCase _ = "Homomorphic lambda case split" - go DestructAll _ = "Split all function arguments" - go UseDataCon dcon = "Use constructor " <> dcon - go Refine _ = "Refine hole" - go BeginMetaprogram _ = "Use custom tactic block" - go RunMetaprogram _ = "Run custom tactic" - - ------------------------------------------------------------------------------- --- | Plugin configuration for tactics -data Config = Config - { cfg_max_use_ctor_actions :: Int - , cfg_timeout_seconds :: Int - , cfg_auto_gas :: Int - , cfg_proofstate_styling :: Bool - } - deriving (Eq, Ord, Show) - -emptyConfig :: Config -emptyConfig = Config - { cfg_max_use_ctor_actions = 5 - , cfg_timeout_seconds = 2 - , cfg_auto_gas = 4 - , cfg_proofstate_styling = True - } - ------------------------------------------------------------------------------- --- | A wrapper around 'Type' which supports equality and ordering. -newtype CType = CType { unCType :: Type } - deriving stock (Data, Typeable) - -instance Eq CType where - (==) = eqType `on` unCType - -instance Ord CType where - compare = nonDetCmpType `on` unCType - -instance Show CType where - show = unsafeRender . unCType - -instance Show Name where - show = unsafeRender - -instance Show Type where - show = unsafeRender - -instance Show Var where - show = unsafeRender - -instance Show TCvSubst where - show = unsafeRender - -instance Show DataCon where - show = unsafeRender - -instance Show Class where - show = unsafeRender - -instance Show (HsExpr GhcPs) where - show = unsafeRender - -instance Show (HsExpr GhcTc) where - show = unsafeRender - -instance Show (HsDecl GhcPs) where - show = unsafeRender - -instance Show (Pat GhcPs) where - show = unsafeRender - -instance Show (LHsSigType GhcPs) where - show = unsafeRender - -instance Show TyCon where - show = unsafeRender - -instance Show ConLike where - show = unsafeRender - -instance Show LexicalFixity where - show = unsafeRender - - ------------------------------------------------------------------------------- --- | The state that should be shared between subgoals. Extracts move towards --- the root, judgments move towards the leaves, and the state moves *sideways*. -data TacticState = TacticState - { ts_skolems :: !(Set TyVar) - -- ^ The known skolems. - , ts_unifier :: !TCvSubst - , ts_unique_gen :: !UniqSupply - } deriving stock (Show, Generic) - -instance Show UniqSupply where - show _ = "" - - ------------------------------------------------------------------------------- --- | A 'UniqSupply' to use in 'defaultTacticState' -unsafeDefaultUniqueSupply :: UniqSupply -unsafeDefaultUniqueSupply = - unsafePerformIO $ mkSplitUniqSupply 'w' -{-# NOINLINE unsafeDefaultUniqueSupply #-} - - -defaultTacticState :: TacticState -defaultTacticState = - TacticState - { ts_skolems = mempty - , ts_unifier = emptyTCvSubst - , ts_unique_gen = unsafeDefaultUniqueSupply - } - - ------------------------------------------------------------------------------- --- | Generate a new 'Unique' -freshUnique :: MonadState TacticState m => m Util.Unique -freshUnique = do - (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen - modify' $! field @"ts_unique_gen" .~ supply - pure uniq - - ------------------------------------------------------------------------------- --- | Describes where hypotheses came from. Used extensively to prune stupid --- solutions from the search space. -data Provenance - = -- | An argument given to the topmost function that contains the current - -- hole. Recursive calls are restricted to values whose provenance lines up - -- with the same argument. - TopLevelArgPrv - OccName -- ^ Binding function - Int -- ^ Argument Position - Int -- ^ of how many arguments total? - -- | A binding created in a pattern match. - | PatternMatchPrv PatVal - -- | A class method from the given context. - | ClassMethodPrv - (Uniquely Class) -- ^ Class - -- | A binding explicitly written by the user. - | UserPrv - -- | A binding explicitly imported by the user. - | ImportPrv - -- | The recursive hypothesis. Present only in the context of the recursion - -- tactic. - | RecursivePrv - -- | A hypothesis which has been disallowed for some reason. It's important - -- to keep these in the hypothesis set, rather than filtering it, in order - -- to continue tracking downstream provenance. - | DisallowedPrv DisallowReason Provenance - deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Why was a hypothesis disallowed? -data DisallowReason - = WrongBranch Int - | Shadowed - | RecursiveCall - | AlreadyDestructed - deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Provenance of a pattern value. -data PatVal = PatVal - { pv_scrutinee :: Maybe OccName - -- ^ Original scrutinee which created this PatVal. Nothing, for lambda - -- case. - , pv_ancestry :: Set OccName - -- ^ The set of values which had to be destructed to discover this term. - -- Always contains the scrutinee. - , pv_datacon :: Uniquely ConLike - -- ^ The datacon which introduced this term. - , pv_position :: Int - -- ^ The position of this binding in the datacon's arguments. - } deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | A wrapper which uses a 'Uniquable' constraint for providing 'Eq' and 'Ord' --- instances. -newtype Uniquely a = Uniquely { getViaUnique :: a } - deriving Show via a - deriving stock (Data, Typeable) - -instance Util.Uniquable a => Eq (Uniquely a) where - (==) = (==) `on` Util.getUnique . getViaUnique - -instance Util.Uniquable a => Ord (Uniquely a) where - compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique - - --- NOTE(sandy): The usage of list here is mostly for convenience, but if it's --- ever changed, make sure to correspondingly update --- 'jAcceptableDestructTargets' so that it correctly identifies newly --- introduced terms. -newtype Hypothesis a = Hypothesis - { unHypothesis :: [HyInfo a] - } - deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable) - deriving newtype (Semigroup, Monoid) - - ------------------------------------------------------------------------------- --- | The provenance and type of a hypothesis term. -data HyInfo a = HyInfo - { hi_name :: OccName - , hi_provenance :: Provenance - , hi_type :: a - } - deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Map a function over the provenance. -overProvenance :: (Provenance -> Provenance) -> HyInfo a -> HyInfo a -overProvenance f (HyInfo name prv ty) = HyInfo name (f prv) ty - - ------------------------------------------------------------------------------- --- | The current bindings and goal for a hole to be filled by refinery. -data Judgement' a = Judgement - { _jHypothesis :: !(Hypothesis a) - , _jBlacklistDestruct :: !Bool - , _jWhitelistSplit :: !Bool - , _jIsTopHole :: !Bool - , _jGoal :: !a - , j_coercion :: TCvSubst - } - deriving stock (Generic, Functor, Show) - -type Judgement = Judgement' CType - - -newtype ExtractM a = ExtractM { unExtractM :: ReaderT Context IO a } - deriving newtype (Functor, Applicative, Monad, MonadReader Context) - ------------------------------------------------------------------------------- --- | Used to ensure hole names are unique across invocations of runTactic -globalHoleRef :: IORef Int -globalHoleRef = unsafePerformIO $ newIORef 10 -{-# NOINLINE globalHoleRef #-} - -instance MonadExtract Int (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM where - hole = do - u <- lift $ ExtractM $ lift $ - readIORef globalHoleRef <* modifyIORef' globalHoleRef (+ 1) - pure - ( u - , pure . noLoc $ var $ fromString $ occNameString $ occName $ mkMetaHoleName u - ) - - unsolvableHole _ = hole - - -instance MonadReader r m => MonadReader r (TacticT jdg ext err s m) where - ask = TacticT $ lift $ Effect $ asks pure - local f (TacticT m) = TacticT $ Strict.StateT $ \jdg -> - Effect $ local f $ pure $ Strict.runStateT m jdg - -instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where - ask = RuleT $ Effect $ asks Axiom - local f (RuleT m) = RuleT $ Effect $ local f $ pure m - -mkMetaHoleName :: Int -> RdrName -mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u) - -instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where - -- TODO(sandy): This join is to combine the synthesizeds - substMeta u val a = join $ a <&> - everywhereM (mkM $ \case - (L _ (HsVar _ (L _ name))) - | name == mkMetaHoleName u -> val - (t :: LHsExpr GhcPs) -> pure t) - - ------------------------------------------------------------------------------- --- | Reasons a tactic might fail. -data TacticError - = OutOfGas - | GoalMismatch String CType - | NoProgress - | NoApplicableTactic - | UnhelpfulRecursion - | UnhelpfulDestruct OccName - | TooPolymorphic - | NotInScope OccName - | TacticPanic String - deriving (Eq) - -instance Show TacticError where - show OutOfGas = "Auto ran out of gas" - show (GoalMismatch tac (CType typ)) = - mconcat - [ "The tactic " - , tac - , " doesn't apply to goal type " - , unsafeRender typ - ] - show NoProgress = - "Unable to make progress" - show NoApplicableTactic = - "No tactic could be applied" - show UnhelpfulRecursion = - "Recursion wasn't productive" - show (UnhelpfulDestruct n) = - "Destructing patval " <> show n <> " leads to no new types" - show TooPolymorphic = - "The tactic isn't applicable because the goal is too polymorphic" - show (NotInScope name) = - "Tried to do something with the out of scope name " <> show name - show (TacticPanic err) = - "Tactic panic: " <> err - - ------------------------------------------------------------------------------- -type TacticsM = TacticT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM -type RuleM = RuleT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM -type Rule = RuleM (Synthesized (LHsExpr GhcPs)) - -type Trace = Rose String - ------------------------------------------------------------------------------- --- | The extract for refinery. Represents a "synthesized attribute" in the --- context of attribute grammars. In essence, 'Synthesized' describes --- information we'd like to pass from leaves of the tactics search upwards. --- This includes the actual AST we've generated (in 'syn_val'). -data Synthesized a = Synthesized - { syn_trace :: Trace - -- ^ A tree describing which tactics were used produce the 'syn_val'. - -- Mainly for debugging when you get the wrong answer, to see the other - -- things it tried. - , syn_scoped :: Hypothesis CType - -- ^ All of the bindings created to produce the 'syn_val'. - , syn_used_vals :: Set OccName - -- ^ The values used when synthesizing the 'syn_val'. - , syn_recursion_count :: Sum Int - -- ^ The number of recursive calls - , syn_val :: a - } - deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) - -instance Monad Synthesized where - return = pure - Synthesized tr1 sc1 uv1 rc1 a >>= f = - case f a of - Synthesized tr2 sc2 uv2 rc2 b -> - Synthesized - { syn_trace = tr1 <> tr2 - , syn_scoped = sc1 <> sc2 - , syn_used_vals = uv1 <> uv2 - , syn_recursion_count = rc1 <> rc2 - , syn_val = b - } - -mapTrace :: (Trace -> Trace) -> Synthesized a -> Synthesized a -mapTrace f (Synthesized tr sc uv rc a) = Synthesized (f tr) sc uv rc a - - ------------------------------------------------------------------------------- --- | This might not be lawful, due to the semigroup on 'Trace' maybe not being --- lawful. But that's only for debug output, so it's not anything I'm concerned --- about. -instance Applicative Synthesized where - pure = Synthesized mempty mempty mempty mempty - Synthesized tr1 sc1 uv1 rc1 f <*> Synthesized tr2 sc2 uv2 rc2 a = - Synthesized (tr1 <> tr2) (sc1 <> sc2) (uv1 <> uv2) (rc1 <> rc2) $ f a - - ------------------------------------------------------------------------------- --- | The Reader context of tactics and rules -data Context = Context - { ctxDefiningFuncs :: [(OccName, CType)] - -- ^ The functions currently being defined - , ctxModuleFuncs :: [(OccName, CType)] - -- ^ Everything defined in the current module - , ctxConfig :: Config - , ctxInstEnvs :: InstEnvs - , ctxFamInstEnvs :: FamInstEnvs - , ctxTheta :: Set CType - , ctx_hscEnv :: HscEnv - , ctx_occEnv :: OccEnv [GlobalRdrElt] - , ctx_module :: Module - } - -instance Show Context where - show Context{..} = mconcat - [ "Context " - , showsPrec 10 ctxDefiningFuncs "" - , showsPrec 10 ctxModuleFuncs "" - , showsPrec 10 ctxConfig "" - , showsPrec 10 ctxTheta "" - ] - - ------------------------------------------------------------------------------- --- | An empty context -emptyContext :: Context -emptyContext - = Context - { ctxDefiningFuncs = mempty - , ctxModuleFuncs = mempty - , ctxConfig = emptyConfig - , ctxFamInstEnvs = mempty - , ctxInstEnvs = InstEnvs mempty mempty mempty - , ctxTheta = mempty - , ctx_hscEnv = error "empty hsc env from emptyContext" - , ctx_occEnv = emptyOccEnv - , ctx_module = error "empty module from emptyContext" - } - - -newtype Rose a = Rose (Tree a) - deriving stock (Eq, Functor, Generic, Data, Typeable) - -instance Show (Rose String) where - show = unlines . dropEveryOther . lines . drawTree . coerce - -dropEveryOther :: [a] -> [a] -dropEveryOther [] = [] -dropEveryOther [a] = [a] -dropEveryOther (a : _ : as) = a : dropEveryOther as - ------------------------------------------------------------------------------- --- | This might not be lawful! I didn't check, and it feels sketchy. -instance (Eq a, Monoid a) => Semigroup (Rose a) where - Rose (Node a as) <> Rose (Node b bs) = Rose $ Node (a <> b) (as <> bs) - sconcat (a :| as) = rose mempty $ a : as - -instance (Eq a, Monoid a) => Monoid (Rose a) where - mempty = Rose $ Node mempty mempty - -rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a -rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs -rose a rs = Rose $ Node a $ coerce rs - - ------------------------------------------------------------------------------- --- | The results of 'Wingman.Machinery.runTactic' -data RunTacticResults = RunTacticResults - { rtr_trace :: Trace - , rtr_extract :: LHsExpr GhcPs - , rtr_subgoals :: [Judgement] - , rtr_other_solns :: [Synthesized (LHsExpr GhcPs)] - , rtr_jdg :: Judgement - , rtr_ctx :: Context - , rtr_timed_out :: Bool - } deriving Show - - -data AgdaMatch = AgdaMatch - { amPats :: [Pat GhcPs] - , amBody :: HsExpr GhcPs - } - deriving (Show) - - -data UserFacingMessage - = NotEnoughGas - | TacticErrors - | TimedOut - | NothingToDo - | InfrastructureError Text - deriving Eq - -instance Show UserFacingMessage where - show NotEnoughGas = "Wingman ran out of gas when trying to find a solution. \nTry increasing the `auto_gas` setting." - show TacticErrors = "Wingman couldn't find a solution" - show TimedOut = "Wingman timed out while finding a solution. \nYou might get a better result if you increase the timeout duration." - show NothingToDo = "Nothing to do" - show (InfrastructureError t) = "Internal error: " <> T.unpack t - - -data HoleSort = Hole | Metaprogram T.Text - deriving (Eq, Ord, Show) - -data HoleJudgment = HoleJudgment - { hj_range :: Tracked 'Current Range - , hj_jdg :: Judgement - , hj_ctx :: Context - , hj_dflags :: DynFlags - , hj_hole_sort :: HoleSort - } - diff --git a/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs b/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs deleted file mode 100644 index 11ba11e2ae..0000000000 --- a/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE NumDecimals #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module AutoTupleSpec where - -import Control.Monad (replicateM) -import Control.Monad.State (evalState) -import Data.Either (isRight) -import Development.IDE.GHC.Compat.Core ( mkVarOcc, mkBoxedTupleTy ) -import System.IO.Unsafe -import Test.Hspec -import Test.QuickCheck -import Wingman.Judgements (mkFirstJudgement) -import Wingman.Machinery -import Wingman.Tactics (auto') -import Wingman.Types - - -spec :: Spec -spec = describe "auto for tuple" $ do - it "should always be able to discover an auto solution" $ do - property $ do - -- Pick some number of variables - n <- choose (1, 7) - let vars = flip evalState defaultTacticState - $ replicateM n newUnivar - -- Pick a random ordering - in_vars <- shuffle vars - -- Randomly associate them into tuple types - in_type <- mkBoxedTupleTy - . fmap mkBoxedTupleTy - <$> randomGroups in_vars - out_type <- mkBoxedTupleTy - . fmap mkBoxedTupleTy - <$> randomGroups vars - pure $ - -- We should always be able to find a solution - unsafePerformIO - (runTactic - 2e6 - emptyContext - (mkFirstJudgement - emptyContext - (Hypothesis $ pure $ HyInfo (mkVarOcc "x") UserPrv $ CType in_type) - True - out_type) - (auto' $ n * 2)) `shouldSatisfy` isRight - - -randomGroups :: [a] -> Gen [[a]] -randomGroups [] = pure [] -randomGroups as = do - n <- choose (1, length as) - (:) <$> pure (take n as) - <*> randomGroups (drop n as) - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs deleted file mode 100644 index 4075183ee6..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.AutoSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let autoTest = goldenTest Auto "" - autoTestNoWhitespace = goldenTestNoWhitespace Auto "" - - describe "golden" $ do - autoTest 11 8 "AutoSplitGADT" - autoTest 2 11 "GoldenEitherAuto" - autoTest 4 12 "GoldenJoinCont" - autoTest 3 11 "GoldenIdentityFunctor" - autoTest 7 11 "GoldenIdTypeFam" - autoTest 2 15 "GoldenEitherHomomorphic" - autoTest 2 8 "GoldenNote" - autoTest 2 12 "GoldenPureList" - autoTest 2 12 "GoldenListFmap" - autoTest 2 13 "GoldenFromMaybe" - autoTest 2 10 "GoldenFoldr" - autoTest 2 8 "GoldenSwap" - autoTest 4 11 "GoldenFmapTree" - autoTest 7 13 "GoldenGADTAuto" - autoTest 2 12 "GoldenSwapMany" - autoTest 4 12 "GoldenBigTuple" - autoTest 2 10 "GoldenShow" - autoTest 2 15 "GoldenShowCompose" - autoTest 2 8 "GoldenShowMapChar" - autoTest 7 8 "GoldenSuperclass" - autoTest 2 12 "GoldenSafeHead" - autoTest 2 12 "FmapBoth" - autoTest 7 8 "RecordCon" - autoTest 6 8 "NewtypeRecord" - autoTest 2 14 "FmapJoin" - autoTest 2 9 "Fgmap" - autoTest 4 19 "FmapJoinInLet" - autoTest 9 12 "AutoEndo" - autoTest 2 16 "AutoEmptyString" - autoTest 7 35 "AutoPatSynUse" - autoTest 2 28 "AutoZip" - autoTest 2 17 "AutoInfixApply" - autoTest 2 19 "AutoInfixApplyMany" - autoTest 2 25 "AutoInfixInfix" - autoTest 19 12 "AutoTypeLevel" - autoTest 11 9 "AutoForallClassMethod" - autoTest 2 8 "AutoUnusedPatternMatch" - - failing "flaky in CI" $ - autoTest 2 11 "GoldenApplicativeThen" - - failing "not enough auto gas" $ - autoTest 5 18 "GoldenFish" - - describe "theta" $ do - autoTest 12 10 "AutoThetaFix" - autoTest 7 27 "AutoThetaRankN" - autoTest 6 10 "AutoThetaGADT" - autoTest 6 8 "AutoThetaGADTDestruct" - autoTest 4 8 "AutoThetaEqCtx" - autoTest 6 10 "AutoThetaEqGADT" - autoTest 6 8 "AutoThetaEqGADTDestruct" - autoTest 6 10 "AutoThetaRefl" - autoTest 6 8 "AutoThetaReflDestruct" - autoTest 19 30 "AutoThetaMultipleUnification" - autoTest 16 9 "AutoThetaSplitUnification" - - describe "known" $ do - autoTest 25 13 "GoldenArbitrary" - autoTest 6 13 "GoldenArbitrarySingleConstructor" - autoTestNoWhitespace - 6 10 "KnownBigSemigroup" - autoTest 4 10 "KnownThetaSemigroup" - autoTest 6 10 "KnownCounterfactualSemigroup" - autoTest 10 10 "KnownModuleInstanceSemigroup" - autoTest 4 22 "KnownDestructedSemigroup" - autoTest 4 10 "KnownMissingSemigroup" - autoTest 7 12 "KnownMonoid" - autoTest 7 12 "KnownPolyMonoid" - autoTest 7 12 "KnownMissingMonoid" - - - describe "messages" $ do - mkShowMessageTest Auto "" 2 8 "MessageForallA" TacticErrors - mkShowMessageTest Auto "" 7 8 "MessageCantUnify" TacticErrors - mkShowMessageTest Auto "" 12 8 "MessageNotEnoughGas" NotEnoughGas - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs deleted file mode 100644 index 488fb3ebad..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructAllSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructAllTest = goldenTest DestructAll "" - describe "provider" $ do - mkTest - "Requires args on lhs of =" - "DestructAllProvider" 3 21 - [ (not, DestructAll, "") - ] - mkTest - "Can't be a non-top-hole" - "DestructAllProvider" 8 19 - [ (not, DestructAll, "") - , (id, Destruct, "a") - , (id, Destruct, "b") - ] - mkTest - "Provides a destruct all otherwise" - "DestructAllProvider" 12 22 - [ (id, DestructAll, "") - ] - - describe "golden" $ do - destructAllTest 2 11 "DestructAllAnd" - destructAllTest 4 23 "DestructAllMany" - destructAllTest 2 18 "DestructAllNonVarTopMatch" - destructAllTest 2 18 "DestructAllFunc" - destructAllTest 19 18 "DestructAllGADTEvidence" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs deleted file mode 100644 index 7d17aa1d2c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructPunSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructTest = goldenTest DestructPun - - describe "golden" $ do - destructTest "x" 4 9 "PunSimple" - destructTest "x" 6 10 "PunMany" - destructTest "x" 11 11 "PunGADT" - destructTest "x" 17 11 "PunManyGADT" - destructTest "x" 4 12 "PunShadowing" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs deleted file mode 100644 index 2251abfeb2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructTest = goldenTest Destruct - - describe "golden" $ do - destructTest "gadt" 7 17 "GoldenGADTDestruct" - destructTest "gadt" 8 17 "GoldenGADTDestructCoercion" - destructTest "a" 7 25 "SplitPattern" - destructTest "a" 6 18 "DestructPun" - destructTest "fp" 31 14 "DestructCthulhu" - destructTest "b" 7 10 "DestructTyFam" - destructTest "b" 7 10 "DestructDataFam" - destructTest "b" 17 10 "DestructTyToDataFam" - destructTest "t" 6 10 "DestructInt" - - describe "layout" $ do - destructTest "b" 4 3 "LayoutBind" - destructTest "b" 2 15 "LayoutDollarApp" - destructTest "b" 2 18 "LayoutOpApp" - destructTest "b" 2 14 "LayoutLam" - destructTest "x" 11 15 "LayoutSplitWhere" - destructTest "x" 3 12 "LayoutSplitClass" - destructTest "b" 3 9 "LayoutSplitGuard" - destructTest "b" 4 13 "LayoutSplitLet" - destructTest "a" 4 7 "LayoutSplitIn" - destructTest "a" 4 31 "LayoutSplitViewPat" - destructTest "a" 7 17 "LayoutSplitPattern" - destructTest "a" 8 26 "LayoutSplitPatSyn" - - describe "providers" $ do - mkTest - "Produces destruct and homomorphism code actions" - "T2" 2 21 - [ (id, Destruct, "eab") - , (id, Homomorphism, "eab") - , (not, DestructPun, "eab") - ] - - mkTest - "Won't suggest homomorphism on the wrong type" - "T2" 8 8 - [ (not, Homomorphism, "global") - ] - - mkTest - "Produces (homomorphic) lambdacase code actions" - "T3" 4 24 - [ (id, HomomorphismLambdaCase, "") - , (id, DestructLambdaCase, "") - ] - - mkTest - "Produces lambdacase code actions" - "T3" 7 13 - [ (id, DestructLambdaCase, "") - ] - - mkTest - "Doesn't suggest lambdacase without -XLambdaCase" - "T2" 11 25 - [ (not, DestructLambdaCase, "") - ] - - mkTest - "Doesn't suggest destruct if already destructed" - "ProvideAlreadyDestructed" 6 18 - [ (not, Destruct, "x") - ] - - mkTest - "...but does suggest destruct if destructed in a different branch" - "ProvideAlreadyDestructed" 9 7 - [ (id, Destruct, "x") - ] - - mkTest - "Doesn't suggest destruct on class methods" - "ProvideLocalHyOnly" 2 12 - [ (not, Destruct, "mempty") - ] - - mkTest - "Suggests homomorphism if the domain is bigger than the codomain" - "ProviderHomomorphism" 12 13 - [ (id, Homomorphism, "g") - ] - - mkTest - "Doesn't suggest homomorphism if the domain is smaller than the codomain" - "ProviderHomomorphism" 15 14 - [ (not, Homomorphism, "g") - , (id, Destruct, "g") - ] - - mkTest - "Suggests lambda homomorphism if the domain is bigger than the codomain" - "ProviderHomomorphism" 18 14 - [ (id, HomomorphismLambdaCase, "") - ] - - mkTest - "Doesn't suggest lambda homomorphism if the domain is smaller than the codomain" - "ProviderHomomorphism" 21 15 - [ (not, HomomorphismLambdaCase, "") - , (id, DestructLambdaCase, "") - ] - - -- test layouts that maintain user-written fixities - destructTest "b" 3 13 "LayoutInfixKeep" - destructTest "b" 2 12 "LayoutPrefixKeep" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs deleted file mode 100644 index 5c3b809c1d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.IntroDestructSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let test l c = goldenTest IntroAndDestruct "" l c - . mappend "IntroDestruct" - - describe "golden" $ do - test 4 5 "One" - test 2 5 "Many" - test 4 11 "LetBinding" - - describe "provider" $ do - mkTest - "Can intro and destruct an algebraic ty" - "IntroDestructProvider" 2 12 - [ (id, IntroAndDestruct, "") - ] - mkTest - "Won't intro and destruct a non-algebraic ty" - "IntroDestructProvider" 5 12 - [ (not, IntroAndDestruct, "") - ] - mkTest - "Can't intro, so no option" - "IntroDestructProvider" 8 17 - [ (not, IntroAndDestruct, "") - ] - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs deleted file mode 100644 index da2aaaa273..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.IntrosSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let introsTest = goldenTest Intros "" - - describe "golden" $ do - introsTest 2 8 "GoldenIntros" - - describe "layout" $ do - introsTest 4 24 "LayoutRec" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs deleted file mode 100644 index 205054c652..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.RefineSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let refineTest = goldenTest Refine "" - - describe "golden" $ do - refineTest 2 8 "RefineIntro" - refineTest 2 8 "RefineCon" - refineTest 4 10 "RefineReader" - refineTest 8 10 "RefineGADT" - refineTest 2 8 "RefineIntroWhere" - - describe "messages" $ do - mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs deleted file mode 100644 index e366c34efe..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.RunMetaprogramSpec where - -import Utils -import Test.Hspec -import Wingman.Types - - -spec :: Spec -spec = do - let metaTest l c f = - goldenTest RunMetaprogram "" l c f - - describe "beginMetaprogram" $ do - goldenTest BeginMetaprogram "" 1 7 "MetaBegin" - goldenTest BeginMetaprogram "" 1 9 "MetaBeginNoWildify" - - describe "golden" $ do - metaTest 6 11 "MetaMaybeAp" - metaTest 2 32 "MetaBindOne" - metaTest 2 32 "MetaBindAll" - metaTest 2 13 "MetaTry" - metaTest 2 74 "MetaChoice" - metaTest 5 40 "MetaUseImport" - metaTest 6 31 "MetaUseLocal" - metaTest 11 11 "MetaUseMethod" - metaTest 9 38 "MetaCataCollapse" - metaTest 7 16 "MetaCataCollapseUnary" - metaTest 10 32 "MetaCataAST" - metaTest 6 46 "MetaPointwise" - metaTest 4 28 "MetaUseSymbol" - metaTest 7 53 "MetaDeepOf" - metaTest 2 34 "MetaWithArg" - metaTest 2 18 "MetaLetSimple" - metaTest 5 9 "MetaIdiom" - metaTest 7 9 "MetaIdiomRecord" - - metaTest 14 10 "MetaFundeps" - - metaTest 2 12 "IntrosTooMany" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs deleted file mode 100644 index 94a1d17550..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.UseDataConSpec where - -import qualified Data.Text as T -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let useTest = goldenTest UseDataCon - - describe "provider" $ do - mkTest - "Suggests all data cons for Either" - "ConProviders" 5 6 - [ (id, UseDataCon, "Left") - , (id, UseDataCon, "Right") - , (not, UseDataCon, ":") - , (not, UseDataCon, "[]") - , (not, UseDataCon, "C1") - ] - mkTest - "Suggests no data cons for big types" - "ConProviders" 11 17 $ do - c <- [1 :: Int .. 10] - pure $ (not, UseDataCon, T.pack $ show c) - mkTest - "Suggests only matching data cons for GADT" - "ConProviders" 20 12 - [ (id, UseDataCon, "IntGADT") - , (id, UseDataCon, "VarGADT") - , (not, UseDataCon, "BoolGADT") - ] - - describe "golden" $ do - useTest "(,)" 2 8 "UseConPair" - useTest "Left" 2 8 "UseConLeft" - useTest "Right" 2 8 "UseConRight" - diff --git a/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs deleted file mode 100644 index 9ebf7d5043..0000000000 --- a/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeLens.EmptyCaseSpec where - -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let test = mkCodeLensTest - noTest = mkNoCodeLensTest - - describe "golden" $ do - test "EmptyCaseADT" - test "EmptyCaseShadow" - test "EmptyCaseParens" - test "EmptyCaseNested" - test "EmptyCaseApply" - test "EmptyCaseGADT" - test "EmptyCaseLamCase" - - describe "no code lenses" $ do - noTest "EmptyCaseSpuriousGADT" - diff --git a/plugins/hls-tactics-plugin/new/test/Main.hs b/plugins/hls-tactics-plugin/new/test/Main.hs deleted file mode 100644 index 00a71905e1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import qualified Spec -import Test.Hls -import Test.Tasty.Hspec - -main :: IO () -main = testSpecs Spec.spec >>= defaultTestRunner . testGroup "tactics" diff --git a/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs deleted file mode 100644 index 4eea30f5b3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ProviderSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - mkTest - "Produces intros code action" - "T1" 2 14 - [ (id, Intros, "") - ] - - mkTest - "Won't suggest intros on the wrong type" - "T2" 8 8 - [ (not, Intros, "") - ] - - goldenTestMany "SubsequentTactics" - [ InvokeTactic Intros "" 4 5 - , InvokeTactic Destruct "du" 4 8 - , InvokeTactic Auto "" 4 15 - ] diff --git a/plugins/hls-tactics-plugin/new/test/Spec.hs b/plugins/hls-tactics-plugin/new/test/Spec.hs deleted file mode 100644 index 5416ef6a86..0000000000 --- a/plugins/hls-tactics-plugin/new/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs b/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs deleted file mode 100644 index 148a40eaaa..0000000000 --- a/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnificationSpec where - -import Control.Arrow -import Control.Monad (replicateM, join) -import Control.Monad.State (evalState) -import Data.Bool (bool) -import Data.Functor ((<&>)) -import Data.Maybe (mapMaybe) -import qualified Data.Set as S -import Data.Traversable -import Data.Tuple (swap) -import Development.IDE.GHC.Compat.Core (substTy, mkBoxedTupleTy) -import Test.Hspec -import Test.QuickCheck -import Wingman.GHC -import Wingman.Machinery (newUnivar) -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType (tcGetTyVar_maybe) -#else -import TcType (tcGetTyVar_maybe) -#endif - - -spec :: Spec -spec = describe "unification" $ do - it "should be able to unify univars with skolems on either side of the equality" $ do - property $ do - -- Pick some number of unification vars and skolem - n <- choose (1, 20) - let (skolems, take n -> univars) - = splitAt n - $ flip evalState defaultTacticState - $ replicateM (n * 2) newUnivar - -- Randomly pair them - skolem_uni_pairs <- - for (zip skolems univars) randomSwap - let (lhs, rhs) - = mkBoxedTupleTy *** mkBoxedTupleTy - $ unzip skolem_uni_pairs - pure $ - counterexample (show skolems) $ - counterexample (show lhs) $ - counterexample (show rhs) $ - case tryUnifyUnivarsButNotSkolems - (S.fromList $ mapMaybe tcGetTyVar_maybe skolems) - (CType lhs) - (CType rhs) of - Just subst -> - conjoin $ join $ - [ -- For each pair, running the unification over the univar should - -- result in the skolem - zip univars skolems <&> \(uni, skolem) -> - let substd = substTy subst uni - in counterexample (show substd) $ - counterexample (show skolem) $ - CType substd === CType skolem - - -- And also, no two univars should equal to one another - -- before or after substitution. - , zip univars (tail univars) <&> \(uni1, uni2) -> - let uni1_sub = substTy subst uni1 - uni2_sub = substTy subst uni2 - in counterexample (show uni1) $ - counterexample (show uni2) $ - CType uni1 =/= CType uni2 .&&. - CType uni1_sub =/= CType uni2_sub - ] - Nothing -> True === False - - -randomSwap :: (a, a) -> Gen (a, a) -randomSwap ab = do - which <- arbitrary - pure $ bool swap id which ab - - diff --git a/plugins/hls-tactics-plugin/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs deleted file mode 100644 index 6d5ead1bfb..0000000000 --- a/plugins/hls-tactics-plugin/new/test/Utils.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} - -module Utils where - -import Control.DeepSeq (deepseq) -import qualified Control.Exception as E -import Control.Lens hiding (List, failing, (<.>), (.=)) -import Control.Monad (unless, void) -import Control.Monad.IO.Class -import Data.Aeson -import Data.Foldable -import Data.Function (on) -import Data.IORef (writeIORef) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Ide.Plugin.Tactic as Tactic -import Language.LSP.Types -import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) -import qualified Language.LSP.Types.Lens as J -import System.Directory (doesFileExist) -import System.FilePath -import Test.Hls -import Test.Hspec -import Test.Hspec.Formatters (FailureReason(ExpectedButGot)) -import Wingman.LanguageServer (mkShowMessageParams) -import Wingman.Types - - -plugin :: PluginDescriptor IdeState -plugin = Tactic.descriptor mempty "tactics" - ------------------------------------------------------------------------------- --- | Get a range at the given line and column corresponding to having nothing --- selected. --- --- NB: These coordinates are in "file space", ie, 1-indexed. -pointRange :: Int -> Int -> Range -pointRange - (subtract 1 -> fromIntegral -> line) - (subtract 1 -> fromIntegral -> col) = - Range (Position line col) (Position line $ col + 1) - - ------------------------------------------------------------------------------- --- | Get the title of a code action. -codeActionTitle :: (Command |? CodeAction) -> Maybe Text -codeActionTitle InL{} = Nothing -codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title - - -resetGlobalHoleRef :: IO () -resetGlobalHoleRef = writeIORef globalHoleRef 0 - - -runSessionForTactics :: Session a -> IO a -runSessionForTactics = - runSessionWithServer' - (IdePlugins [plugin]) - def - (def { ignoreLogNotifications = False } ) - fullCaps - tacticPath - ------------------------------------------------------------------------------- --- | Make a tactic unit test. -mkTest - :: Foldable t - => String -- ^ The test name - -> FilePath -- ^ The file name stem (without extension) to load - -> Int -- ^ Cursor line - -> Int -- ^ Cursor column - -> t ( Bool -> Bool -- Use 'not' for actions that shouldn't be present - , TacticCommand -- An expected command ... - , Text -- ... for this variable - ) -- ^ A collection of (un)expected code actions. - -> SpecWith (Arg Bool) -mkTest name fp line col ts = it name $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (fp <.> "hs") "haskell" - -- wait for diagnostics to start coming - void waitForDiagnostics - -- wait for the entire build to finish, so that Tactics code actions that - -- use stale data will get uptodate stuff - void $ waitForTypecheck doc - actions <- getCodeActions doc $ pointRange line col - let titles = mapMaybe codeActionTitle actions - for_ ts $ \(f, tc, var) -> do - let title = tacticTitle tc var - liftIO $ - (title `elem` titles) `shouldSatisfy` f - -data InvokeTactic = InvokeTactic - { it_command :: TacticCommand - , it_argument :: Text - , it_line :: Int - , it_col :: Int - } - -invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session () -invokeTactic doc InvokeTactic{..} = do - -- wait for the entire build to finish, so that Tactics code actions that - -- use stale data will get uptodate stuff - void waitForDiagnostics - void $ waitForTypecheck doc - actions <- getCodeActions doc $ pointRange it_line it_col - case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of - Just (InR CodeAction {_command = Just c}) -> do - executeCommand c - void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit - _ -> error $ show actions - - -mkGoldenTest - :: (Text -> Text -> Assertion) - -> [InvokeTactic] - -> FilePath - -> SpecWith () -mkGoldenTest eq invocations input = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - traverse_ (invokeTactic doc) invocations - edited <- documentContents doc - let expected_name = input <.> "expected" <.> "hs" - -- Write golden tests if they don't already exist - liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited `eq` expected - - -mkCodeLensTest - :: FilePath - -> SpecWith () -mkCodeLensTest input = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForDiagnostics - lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc - for_ lenses $ \(CodeLens _ (Just cmd) _) -> - executeCommand cmd - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) - edited <- documentContents doc - let expected_name = input <.> "expected" <.> "hs" - -- Write golden tests if they don't already exist - liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited `shouldBe` expected - - ------------------------------------------------------------------------------- --- | A test that no code lenses can be run in the file -mkNoCodeLensTest - :: FilePath - -> SpecWith () -mkNoCodeLensTest input = - it (input <> " (no code lenses)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForBuildQueue - lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc - liftIO $ lenses `shouldBe` [] - - - -isWingmanLens :: CodeLens -> Bool -isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _) - = T.isInfixOf ":tactics:" cmd -isWingmanLens _ = False - - -mkShowMessageTest - :: TacticCommand - -> Text - -> Int - -> Int - -> FilePath - -> UserFacingMessage - -> SpecWith () -mkShowMessageTest tc occ line col input ufm = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForDiagnostics - actions <- getCodeActions doc $ pointRange line col - Just (InR CodeAction {_command = Just c}) - <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions - executeCommand c - NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage) - liftIO $ err `shouldBe` mkShowMessageParams ufm - - -goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col] - -goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith () -goldenTestMany = flip $ mkGoldenTest shouldBe - -goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col] - - -shouldBeIgnoringSpaces :: Text -> Text -> Assertion -shouldBeIgnoringSpaces = assertFun f "" - where - f = (==) `on` T.unwords . T.words - - -assertFun - :: Show a - => (a -> a -> Bool) - -> String -- ^ The message prefix - -> a -- ^ The expected value - -> a -- ^ The actual value - -> Assertion -assertFun eq preface expected actual = - unless (eq actual expected) $ do - (prefaceMsg - `deepseq` expectedMsg - `deepseq` actualMsg - `deepseq` - E.throwIO - (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg)) - where - prefaceMsg - | null preface = Nothing - | otherwise = Just preface - expectedMsg = show expected - actualMsg = show actual - - - ------------------------------------------------------------------------------- --- | Don't run a test. -failing :: Applicative m => String -> b -> m () -failing _ _ = pure () - - -tacticPath :: FilePath -tacticPath = "old/test/golden" - - -executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand) -executeCommandWithResp cmd = do - let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SWorkspaceExecuteCommand execParams - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs deleted file mode 100644 index 8ccb9f083d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = "" diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs deleted file mode 100644 index f04451e24c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs deleted file mode 100644 index 4b50c6c074..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Synthesized b a = Synthesized - { syn_trace :: b - , syn_val :: a - } - deriving (Eq, Show) - - -mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a -mapTrace fbb (Synthesized b a) - = Synthesized {syn_trace = fbb b, syn_val = a} - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs deleted file mode 100644 index c92e6adb5b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs +++ /dev/null @@ -1,10 +0,0 @@ -data Synthesized b a = Synthesized - { syn_trace :: b - , syn_val :: a - } - deriving (Eq, Show) - - -mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a -mapTrace = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs deleted file mode 100644 index 5846428ee7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -import Data.Functor.Contravariant - -class Semigroupal cat t1 t2 to f where - combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y')) - -comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d) -comux = case combine of { (Op f) -> f } - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs deleted file mode 100644 index 9ee00c9255..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -import Data.Functor.Contravariant - -class Semigroupal cat t1 t2 to f where - combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y')) - -comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d) -comux = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs deleted file mode 100644 index 367f6e54d9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = a /: f a - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs deleted file mode 100644 index 4675331aea..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs deleted file mode 100644 index ce40bf0cd6..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = (a /: f a) x - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs deleted file mode 100644 index 55a706ab9b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs deleted file mode 100644 index 7adea169d1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = (a /: f a) --> x diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs deleted file mode 100644 index 729e1a2227..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs deleted file mode 100644 index 8addba654f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - -amIASingleton :: Maybe [a] -> Maybe a -amIASingleton (JustSingleton a) = Just a - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs deleted file mode 100644 index 25a44666e7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - -amIASingleton :: Maybe [a] -> Maybe a -amIASingleton (JustSingleton a) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs deleted file mode 100644 index 2521b651eb..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT b a where - GBool :: b -> GADT b Bool - GInt :: GADT b Int - --- wingman would prefer to use GBool since then it can use its argument. But --- that won't unify with GADT Int, so it is forced to pick GInt and ignore the --- argument. -test :: b -> GADT b Int -test _ = GInt - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs deleted file mode 100644 index b15621e091..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT b a where - GBool :: b -> GADT b Bool - GInt :: GADT b Int - --- wingman would prefer to use GBool since then it can use its argument. But --- that won't unify with GADT Int, so it is forced to pick GInt and ignore the --- argument. -test :: b -> GADT b Int -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs deleted file mode 100644 index cdb8506d01..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = id -- id - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs deleted file mode 100644 index 448a7f5de5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = _ -- id - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs deleted file mode 100644 index cea9517794..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = id - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs deleted file mode 100644 index eae2246722..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs deleted file mode 100644 index 9f2b954867..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y a = a - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs deleted file mode 100644 index 2292a3972f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 = _ - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs deleted file mode 100644 index ba8df349e4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -data Fix f a = Fix (f (Fix f a)) - -instance ( Functor f - -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire - -- on this case. By explicitly adding the @Functor (Fix f)@ - -- dictionary, we can get Wingman to generate the right definition. - , Functor (Fix f) - ) => Functor (Fix f) where - fmap fab (Fix f) = Fix (fmap (fmap fab) f) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs deleted file mode 100644 index 014e6441da..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -data Fix f a = Fix (f (Fix f a)) - -instance ( Functor f - -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire - -- on this case. By explicitly adding the @Functor (Fix f)@ - -- dictionary, we can get Wingman to generate the right definition. - , Functor (Fix f) - ) => Functor (Fix f) where - fmap = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs deleted file mode 100644 index e74f2aba40..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = pure - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs deleted file mode 100644 index e1b20a4b3b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs deleted file mode 100644 index 4d4b1f9579..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X a = pure a - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs deleted file mode 100644 index d92d0bd97d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs deleted file mode 100644 index 446a4d73b3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t _) = t -lookMeUp (AtS ea') (HCons t hl') = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs deleted file mode 100644 index b0b520347d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t hl') = _ -lookMeUp (AtS ea') (HCons t hl') = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs deleted file mode 100644 index 23d96223f3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -showMe :: (forall x. Show x => x -> String) -> Int -> String -showMe f = f - -showedYou :: Int -> String -showedYou = showMe (\x -> show x) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs deleted file mode 100644 index 0e92ac35f3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -showMe :: (forall x. Show x => x -> String) -> Int -> String -showMe f = f - -showedYou :: Int -> String -showedYou = showMe (\x -> _) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs deleted file mode 100644 index 9e42bc946e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = id -- id - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs deleted file mode 100644 index df15580ad2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = _ -- id - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs deleted file mode 100644 index 36aed1af65..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z a = a -- id - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs deleted file mode 100644 index 3beccba7a5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 = _ -- id - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs deleted file mode 100644 index e680f0265c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -data A = A -data B = B -data X = X -data Y = Y - - -data Pairrow ax by where - Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y) - -test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y) -test2 = Pairrow - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs deleted file mode 100644 index e6ceeb1bcd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -data A = A -data B = B -data X = X -data Y = Y - - -data Pairrow ax by where - Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y) - -test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y) -test2 = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs deleted file mode 100644 index 3668830620..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t _) = t -lookMeUp (AtS ea') (HCons _ hl') = lookMeUp ea' hl' - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs deleted file mode 100644 index 40226739db..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs deleted file mode 100644 index 2885a1ca05..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test _ = () diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs deleted file mode 100644 index 5345192969..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs deleted file mode 100644 index 997bc09a33..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] -zip_it_up_and_zip_it_out _ [] = [] -zip_it_up_and_zip_it_out [] (_ : _) = [] -zip_it_up_and_zip_it_out (a : as') (b : bs') - = (a, b) : zip_it_up_and_zip_it_out as' bs' - diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs deleted file mode 100644 index 98d6335988..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs +++ /dev/null @@ -1,3 +0,0 @@ -zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] -zip_it_up_and_zip_it_out = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs b/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs deleted file mode 100644 index 19dbc3c6e5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- Should suggest Left and Right, but not [] -t1 :: Either a b -t1 = _ - - -data ManyConstructors = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 - -noCtorsIfMany :: ManyConstructors -noCtorsIfMany = _ - - -data GADT a where - IntGADT :: GADT Int - BoolGADT :: GADT Bool - VarGADT :: GADT a - -gadtCtor :: GADT Int -gadtCtor = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs deleted file mode 100644 index 392bd9d2cd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -and :: Bool -> Bool -> Bool -and False False = _w0 -and False True = _w1 -and True False = _w2 -and True True = _w3 diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs deleted file mode 100644 index 892eab679c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs +++ /dev/null @@ -1,2 +0,0 @@ -and :: Bool -> Bool -> Bool -and x y = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs deleted file mode 100644 index 536d15b107..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func False y = _w0 -has_a_func True y = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs deleted file mode 100644 index 6996698400..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs +++ /dev/null @@ -1,3 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func x y = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs deleted file mode 100644 index 0e4c0985fa..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t hl') = _w0 -lookMeUp (AtS ea') (HCons t hl') = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs deleted file mode 100644 index 3ac66d5444..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp ea hl = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs deleted file mode 100644 index 366a3eac70..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs +++ /dev/null @@ -1,27 +0,0 @@ -data ABC = A | B | C - -many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () -many () (Left a) False Nothing A = _w0 -many () (Left a) False Nothing B = _w1 -many () (Left a) False Nothing C = _w2 -many () (Left a) False (Just abc') A = _w3 -many () (Left a) False (Just abc') B = _w4 -many () (Left a) False (Just abc') C = _w5 -many () (Left a) True Nothing A = _w6 -many () (Left a) True Nothing B = _w7 -many () (Left a) True Nothing C = _w8 -many () (Left a) True (Just abc') A = _w9 -many () (Left a) True (Just abc') B = _wa -many () (Left a) True (Just abc') C = _wb -many () (Right b') False Nothing A = _wc -many () (Right b') False Nothing B = _wd -many () (Right b') False Nothing C = _we -many () (Right b') False (Just abc') A = _wf -many () (Right b') False (Just abc') B = _wg -many () (Right b') False (Just abc') C = _wh -many () (Right b') True Nothing A = _wi -many () (Right b') True Nothing B = _wj -many () (Right b') True Nothing C = _wk -many () (Right b') True (Just abc') A = _wl -many () (Right b') True (Just abc') B = _wm -many () (Right b') True (Just abc') C = _wn diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs deleted file mode 100644 index ab0a4dccb9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs +++ /dev/null @@ -1,4 +0,0 @@ -data ABC = A | B | C - -many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () -many u e b mabc abc = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs deleted file mode 100644 index dc1ea66c51..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -and :: (a, b) -> Bool -> Bool -> Bool -and (a, b) False False = _w0 -and (a, b) False True = _w1 -and (a, b) True False = _w2 -and (a, b) True True = _w3 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs deleted file mode 100644 index 358223ae67..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs +++ /dev/null @@ -1,3 +0,0 @@ -and :: (a, b) -> Bool -> Bool -> Bool -and (a, b) x y = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs deleted file mode 100644 index 8d115e828d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs +++ /dev/null @@ -1,12 +0,0 @@ --- we need to name the args ourselves first -nothingToDestruct :: [a] -> [a] -> [a] -nothingToDestruct = _ - - --- can't destruct all for non-top-level holes -notTop :: Bool -> Bool -> Bool -notTop a b = a && _ - --- destruct all is ok -canDestructAll :: Bool -> Bool -> Bool -canDestructAll a b = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs deleted file mode 100644 index e885b489a1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data FreePro r c a b where - ID :: FreePro r c x x - Comp :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z - Copy :: FreePro r c x (x, x) - Consume :: FreePro r c x () - Swap :: FreePro r c (a, b) (b, a) - SwapE :: FreePro r c (Either a b) (Either b a) - Fst :: FreePro r c (a, b) a - Snd :: FreePro r c (a, b) b - InjectL :: FreePro r c a (Either a b) - InjectR :: FreePro r c b (Either a b) - Unify :: FreePro r c (Either a a) a - First :: FreePro r c a b -> FreePro r c (a, m) (b, m) - Second :: FreePro r c a b -> FreePro r c (m, a) (m, b) - Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b') - Fanout :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b') - Left' :: FreePro r c a b -> FreePro r c (Either a x) (Either b x) - Right' :: FreePro r c a b -> FreePro r c (Either x a) (Either x b) - EitherOf :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b') - Fanin :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b - LiftC :: c a b -> FreePro r c a b - Zero :: FreePro r c x y - Plus :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y - Unleft :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b - Unright :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b - - -cthulhu :: FreePro r c a b -> FreePro r c a b -cthulhu ID = _w0 -cthulhu (Comp fp' fp_rcyb) = _w1 -cthulhu Copy = _w2 -cthulhu Consume = _w3 -cthulhu Swap = _w4 -cthulhu SwapE = _w5 -cthulhu Fst = _w6 -cthulhu Snd = _w7 -cthulhu InjectL = _w8 -cthulhu InjectR = _w9 -cthulhu Unify = _wa -cthulhu (First fp') = _wb -cthulhu (Second fp') = _wc -cthulhu (Alongside fp' fp_rca'b') = _wd -cthulhu (Fanout fp' fp_rcab') = _we -cthulhu (Left' fp') = _wf -cthulhu (Right' fp') = _wg -cthulhu (EitherOf fp' fp_rca'b') = _wh -cthulhu (Fanin fp' fp_rca'b) = _wi -cthulhu (LiftC cab) = _wj -cthulhu Zero = _wk -cthulhu (Plus fp' fp_rcab) = _wl -cthulhu (Unleft fp') = _wm -cthulhu (Unright fp') = _wn diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs deleted file mode 100644 index a2d04bb6a2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data FreePro r c a b where - ID :: FreePro r c x x - Comp :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z - Copy :: FreePro r c x (x, x) - Consume :: FreePro r c x () - Swap :: FreePro r c (a, b) (b, a) - SwapE :: FreePro r c (Either a b) (Either b a) - Fst :: FreePro r c (a, b) a - Snd :: FreePro r c (a, b) b - InjectL :: FreePro r c a (Either a b) - InjectR :: FreePro r c b (Either a b) - Unify :: FreePro r c (Either a a) a - First :: FreePro r c a b -> FreePro r c (a, m) (b, m) - Second :: FreePro r c a b -> FreePro r c (m, a) (m, b) - Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b') - Fanout :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b') - Left' :: FreePro r c a b -> FreePro r c (Either a x) (Either b x) - Right' :: FreePro r c a b -> FreePro r c (Either x a) (Either x b) - EitherOf :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b') - Fanin :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b - LiftC :: c a b -> FreePro r c a b - Zero :: FreePro r c x y - Plus :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y - Unleft :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b - Unright :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b - - -cthulhu :: FreePro r c a b -> FreePro r c a b -cthulhu fp = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs deleted file mode 100644 index e463935583..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test (Heya n) = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs deleted file mode 100644 index a93e1974fb..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs deleted file mode 100644 index 0f14deef83..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test (Test in') = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs deleted file mode 100644 index 432a6d4074..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test t = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs deleted file mode 100644 index bfd8d09074..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a = False, b} = _w0 -foo Foo {a = True, b} = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs deleted file mode 100644 index c7b410c5e3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a, b} = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs deleted file mode 100644 index eee4cbd587..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test False = _w0 -test True = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs deleted file mode 100644 index 30a9d884b7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs deleted file mode 100644 index 3016c4ef4e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -type family T1 a where - T1 a = T2 Int - -type family T2 a -type instance T2 Int = T3 - -type family T3 where - T3 = Yo - -data family Yo -data instance Yo = Heya Int - -test :: T1 Bool -> Int -test (Heya n) = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs deleted file mode 100644 index 191fa7b044..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -type family T1 a where - T1 a = T2 Int - -type family T2 a -type instance T2 Int = T3 - -type family T3 where - T3 = Yo - -data family Yo -data instance Yo = Heya Int - -test :: T1 Bool -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs deleted file mode 100644 index 84d2b80d0e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - A n -> _ - B b -> _ - C -> _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs deleted file mode 100644 index 37d3b6c357..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs deleted file mode 100644 index 1895dd6256..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -blah = case show 5 of - [] -> _ - c : s -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs deleted file mode 100644 index 29647e2cda..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs +++ /dev/null @@ -1 +0,0 @@ -blah = case show 5 of diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs deleted file mode 100644 index 409be2aa03..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - MyInt :: GADT Int - MyBool :: GADT Bool - MyVar :: GADT a - - -test :: GADT Int -> GADT Bool -test x = case x of - MyInt -> _ - MyVar -> _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs deleted file mode 100644 index ba08ddae54..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - MyInt :: GADT Int - MyBool :: GADT Bool - MyVar :: GADT a - - -test :: GADT Int -> GADT Bool -test x = case x of - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs deleted file mode 100644 index 048f437368..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case - False -> _ - True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs deleted file mode 100644 index ef490eb751..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs deleted file mode 100644 index ef873a7c41..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test = - case (case (Just "") of - Nothing -> _ - Just s -> _) of - True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs deleted file mode 100644 index a72781a7c6..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = - case (case (Just "") of) of - True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs deleted file mode 100644 index 18aacf2ae2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = True && (case True of - False -> _ - True -> _) diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs deleted file mode 100644 index 2ac71b042e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs +++ /dev/null @@ -1 +0,0 @@ -test = True && case True of diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs deleted file mode 100644 index 2c5158b856..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -data Foo = A Int | B Bool | C - --- Make sure we don't shadow the i and b bindings when we empty case --- split -foo :: Int -> Bool -> Foo -> () -foo i b x = case x of - A n -> _ - B b' -> _ - C -> _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs deleted file mode 100644 index c57af5b849..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Foo = A Int | B Bool | C - --- Make sure we don't shadow the i and b bindings when we empty case --- split -foo :: Int -> Bool -> Foo -> () -foo i b x = case x of - diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs deleted file mode 100644 index 25906fe536..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Foo a where - Foo :: Foo Int - -foo :: Foo Bool -> () -foo x = case x of - diff --git a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs deleted file mode 100644 index 4f4921fa05..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = fmap . fmap diff --git a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs deleted file mode 100644 index de1968474e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs deleted file mode 100644 index 825b00ebea..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth fab (fa, ga) = (fmap fab fa, fmap fab ga) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs deleted file mode 100644 index 29d8ea62b2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs deleted file mode 100644 index 5dc5026f8b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap (\ m -> m >>= id) diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs deleted file mode 100644 index 98a40133ea..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs deleted file mode 100644 index ac4b54ae9d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = let f = ( (\ m -> m >>= id) :: m (m a) -> m a) in fmap f diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs deleted file mode 100644 index e6fe6cbd0d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = let f = (_ :: m (m a) -> m a) in fmap f diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs deleted file mode 100644 index 29ce9f5132..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs +++ /dev/null @@ -1,2 +0,0 @@ -useThen :: Applicative f => f Int -> f a -> f a -useThen = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs deleted file mode 100644 index 6f7af5c3fd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs +++ /dev/null @@ -1,53 +0,0 @@ --- Emulate a quickcheck import; deriveArbitrary works on any type with the --- right name and kind -data Gen a - -data Obj - = Square Int Int - | Circle Int - | Polygon [(Int, Int)] - | Rotate2 Double Obj - | Empty - | Full - | Complement Obj - | UnionR Double [Obj] - | DifferenceR Double Obj [Obj] - | IntersectR Double [Obj] - | Translate Double Double Obj - | Scale Double Double Obj - | Mirror Double Double Obj - | Outset Double Obj - | Shell Double Obj - | WithRounding Double Obj - - -arbitrary :: Gen Obj -arbitrary - = let - terminal - = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary, - Polygon <$> arbitrary, pure Empty, pure Full] - in - sized - $ (\ n - -> case n <= 1 of - True -> oneof terminal - False - -> oneof - $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary, - Complement <$> scale (subtract 1) arbitrary, - (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary) - <*> scale (flip div 2) arbitrary, - (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((Translate <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Scale <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Mirror <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary, - (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary, - (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary] - <> terminal)) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs deleted file mode 100644 index f45d2d1fea..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Emulate a quickcheck import; deriveArbitrary works on any type with the --- right name and kind -data Gen a - -data Obj - = Square Int Int - | Circle Int - | Polygon [(Int, Int)] - | Rotate2 Double Obj - | Empty - | Full - | Complement Obj - | UnionR Double [Obj] - | DifferenceR Double Obj [Obj] - | IntersectR Double [Obj] - | Translate Double Double Obj - | Scale Double Double Obj - | Mirror Double Double Obj - | Outset Double Obj - | Shell Double Obj - | WithRounding Double Obj - - -arbitrary :: Gen Obj -arbitrary = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs deleted file mode 100644 index 786e381ca8..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary - = (((Obj <$> arbitrary) <*> arbitrary) <*> arbitrary) <*> arbitrary \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs deleted file mode 100644 index a6a7d171a3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs +++ /dev/null @@ -1,6 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary = _ \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs deleted file mode 100644 index 1e7ccecde4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ --- There used to be a bug where we were unable to perform a nested split. The --- more serious regression test of this is 'AutoTupleSpec'. -bigTuple :: (a, b, c, d) -> (a, b, (c, d)) -bigTuple (a, b, c, d) = (a, b, (c, d)) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs deleted file mode 100644 index 1ede521a5f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs +++ /dev/null @@ -1,4 +0,0 @@ --- There used to be a bug where we were unable to perform a nested split. The --- more serious regression test of this is 'AutoTupleSpec'. -bigTuple :: (a, b, c, d) -> (a, b, (c, d)) -bigTuple = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs deleted file mode 100644 index f7756898e0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' fac _ (Left a) = fac a -either' _ fbc (Right b) = fbc b diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs deleted file mode 100644 index eb34cd8209..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs +++ /dev/null @@ -1,2 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs deleted file mode 100644 index c18f2ec476..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit a (Left fab) = Left (fab a) -eitherSplit a (Right fac) = Right (fac a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs deleted file mode 100644 index dee865d1a2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs +++ /dev/null @@ -1,2 +0,0 @@ -eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs deleted file mode 100644 index ce38700b58..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs +++ /dev/null @@ -1,5 +0,0 @@ --- There was an old bug where we would only pull skolems from the hole, rather --- than the entire hypothesis. Because of this, the 'b' here would be --- considered a univar, which could then be unified with the skolem 'c'. -fish :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c -fish amb bmc a = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs deleted file mode 100644 index 2b32b3a9cd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Tree a = Leaf a | Branch (Tree a) (Tree a) - -instance Functor Tree where - fmap fab (Leaf a) = Leaf (fab a) - fmap fab (Branch tr' tr_a) = Branch (fmap fab tr') (fmap fab tr_a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs deleted file mode 100644 index 679e7902df..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs +++ /dev/null @@ -1,4 +0,0 @@ -data Tree a = Leaf a | Branch (Tree a) (Tree a) - -instance Functor Tree where - fmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs deleted file mode 100644 index 89db0adb76..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 _ b [] = b -foldr2 fabb b (a : as') = fabb a (foldr2 fabb b as') diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs deleted file mode 100644 index bade9c1e7a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs +++ /dev/null @@ -1,2 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs deleted file mode 100644 index 5b39ea5a4b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe a Nothing = a -fromMaybe _ (Just a') = a' diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs deleted file mode 100644 index e3046a29c3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs +++ /dev/null @@ -1,2 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs deleted file mode 100644 index 88f33dd2da..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = MkCtxGADT () diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs deleted file mode 100644 index 1c47dd0e07..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = _auto diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs deleted file mode 100644 index 3f5f4fa157..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data CtxGADT where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT - -ctxGADT :: CtxGADT -> String -ctxGADT (MkCtxGADT a) = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs deleted file mode 100644 index 588cf362a2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data CtxGADT where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT - -ctxGADT :: CtxGADT -> String -ctxGADT gadt = _decons diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs deleted file mode 100644 index 4f4b2d3a4a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data E a b where - E :: forall a b. (b ~ a, Ord a) => b -> E a [a] - -ctxGADT :: E a b -> String -ctxGADT (E b) = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs deleted file mode 100644 index 9eca759e85..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data E a b where - E :: forall a b. (b ~ a, Ord a) => b -> E a [a] - -ctxGADT :: E a b -> String -ctxGADT gadt = _decons diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs deleted file mode 100644 index 7b3d1beda0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = id diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs deleted file mode 100644 index be8903fec0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs deleted file mode 100644 index 5c509d6507..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap fab (Ident a) = Ident (fab a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs deleted file mode 100644 index 6d1de50992..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs deleted file mode 100644 index 0ae8c4bbac..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah n b fab s = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs deleted file mode 100644 index 5b4e6e241f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs deleted file mode 100644 index e941214796..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Cont r a = ((a -> r) -> r) - -joinCont :: Cont r (Cont r a) -> Cont r a -joinCont f far = f (\ g -> g far) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs deleted file mode 100644 index f2c63714da..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Cont r a = ((a -> r) -> r) - -joinCont :: Cont r (Cont r a) -> Cont r a -joinCont = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs deleted file mode 100644 index ec44241736..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList _ [] = [] -fmapList fab (a : as') = fab a : fmapList fab as' diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs deleted file mode 100644 index 85293daaf4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs deleted file mode 100644 index 99bc0cd6d0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -note :: e -> Maybe a -> Either e a -note e Nothing = Left e -note _ (Just a) = Right a diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs deleted file mode 100644 index c9e0c820e4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs +++ /dev/null @@ -1,2 +0,0 @@ -note :: e -> Maybe a -> Either e a -note = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs deleted file mode 100644 index 8f2bc80ea7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList a = a : [] diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs deleted file mode 100644 index 3a3293b4ec..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs deleted file mode 100644 index 7f8f73e5b7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead [] = Nothing -safeHead (x : _) = Just x diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs deleted file mode 100644 index 6a5d27c0d1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs +++ /dev/null @@ -1,2 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs deleted file mode 100644 index 05ba83e9fe..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = show diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs deleted file mode 100644 index 9ec5e27bcf..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs deleted file mode 100644 index d8a78b3017..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose fba = show . fba diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs deleted file mode 100644 index c99768e4e5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs deleted file mode 100644 index c32357d1a9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test a f = f (show a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs deleted file mode 100644 index 8e6e5eae6b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs deleted file mode 100644 index e0a5dbb565..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = super - diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs deleted file mode 100644 index 86a9fed7bc..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs deleted file mode 100644 index e09cb3800a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap (a, b) = (b, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs deleted file mode 100644 index 9243955c54..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs deleted file mode 100644 index 1d2bc0a605..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany (a, b, c, d, e) = (e, d, c, b, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs deleted file mode 100644 index b1f6c0fb2a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs deleted file mode 100644 index 0039ab768e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x False = _w0 - x True = _w1 - pure () diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs deleted file mode 100644 index bf12200131..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x = _ - pure () diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs deleted file mode 100644 index 462e5edf99..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x False = _w0 -x True = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs deleted file mode 100644 index 98a4bd552c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs deleted file mode 100644 index 4ba80e2455..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Test where - -x :: Bool -> Int -x False = _w0 -x True = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs deleted file mode 100644 index 2afdc50ca5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Test where - -x :: Bool -> Int -x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs deleted file mode 100644 index f0d127dd50..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs +++ /dev/null @@ -1,9 +0,0 @@ -hasAlgTy :: Maybe Int -> Int -hasAlgTy = _ - -hasFunTy :: (Int -> Int) -> Int -hasFunTy = _ - -isSaturated :: Bool -> Int -isSaturated b = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs deleted file mode 100644 index 97668d8c90..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -too_many :: a -> b -> c -too_many a b = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs deleted file mode 100644 index 066f123a47..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -too_many :: a -> b -> c -too_many = [wingman| intros a b c d e f g h i j k l m n o p q r s t u v w x y z |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs deleted file mode 100644 index c97ba98a6a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Data.Monoid - -data Big a = Big [Bool] (Sum Int) String (Endo a) Any - -instance Semigroup (Big a) where - (Big bs sum s en any) <> (Big bs' sum' str en' any') - = Big - (bs <> bs') (sum <> sum') (s <> str) (en <> en') (any <> any') - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs deleted file mode 100644 index 49ea10b8b4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Monoid - -data Big a = Big [Bool] (Sum Int) String (Endo a) Any - -instance Semigroup (Big a) where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs deleted file mode 100644 index 8bef710c69..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -data Semi = Semi [String] Int - -instance Semigroup Int => Semigroup Semi where - (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) (n <> i) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs deleted file mode 100644 index 11e53f4191..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -data Semi = Semi [String] Int - -instance Semigroup Int => Semigroup Semi where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs deleted file mode 100644 index 179937cb6a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - (Test a) <> (Test c) = Test (a <> c) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs deleted file mode 100644 index ed4182c6d9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - Test a <> Test c = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs deleted file mode 100644 index f64222977b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = Monoid mempty _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs deleted file mode 100644 index 7c6bfc5ccd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs deleted file mode 100644 index 3f18919e80..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs deleted file mode 100644 index 1193c14a3b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs deleted file mode 100644 index 627217b285..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -data Foo = Foo - -instance Semigroup Foo where - (<>) _ _ = Foo - - -data Bar = Bar Foo Foo - -instance Semigroup Bar where - (Bar foo foo') <> (Bar foo2 foo3) - = Bar (foo <> foo2) (foo' <> foo3) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs deleted file mode 100644 index 8a03a029af..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Foo = Foo - -instance Semigroup Foo where - (<>) _ _ = Foo - - -data Bar = Bar Foo Foo - -instance Semigroup Bar where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs deleted file mode 100644 index 6ad1e2bf92..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = Monoid mempty - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs deleted file mode 100644 index 0667bee28c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs deleted file mode 100644 index 317f2e770b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid a => Monoid (Mono a) where - mempty = Monoid mempty mempty - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs deleted file mode 100644 index 8ba7bc6d98..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid a => Monoid (Mono a) where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs deleted file mode 100644 index 3711af103a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (Semi a) <> (Semi a') = Semi (a <> a') - diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs deleted file mode 100644 index f5e38276fe..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs deleted file mode 100644 index c65b7d07d0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - case b of - False -> _w0 - True -> _w1 - pure () - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs deleted file mode 100644 index 4598f0eba1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - _ - pure () - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs deleted file mode 100644 index 32e08c94a8..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test b = id $ (case b of - False -> _w0 - True -> _w1) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs deleted file mode 100644 index 83a3e4785b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test b = id $ _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs deleted file mode 100644 index b4d3ee6a0e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ --- keep layout that was written by the user in infix -foo :: Bool -> a -> a -False `foo` a = _w0 -True `foo` a = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs deleted file mode 100644 index 60d198e5da..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs +++ /dev/null @@ -1,4 +0,0 @@ --- keep layout that was written by the user in infix -foo :: Bool -> a -> a -b `foo` a = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs deleted file mode 100644 index d8b34c8939..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test = \b -> case b of - False -> _w0 - True -> _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs deleted file mode 100644 index 3fead2a25d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test = \b -> _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs deleted file mode 100644 index e8bc6ccc87..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -test :: Bool -> Bool -test b = True && (case b of - False -> _w0 - True -> _w1) diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs deleted file mode 100644 index a4c05b7539..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> Bool -test b = True && _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs deleted file mode 100644 index bffe1b6852..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) False a = _w0 -(-/) True a = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs deleted file mode 100644 index bfe7bdafb3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs +++ /dev/null @@ -1,3 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) b a = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs deleted file mode 100644 index ef639a9839..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Pair a b = Pair {pa :: a, pb :: b} - -p :: Pair (a -> a) (a -> b -> c -> b) -p = Pair {pa = _, pb = \ a b c -> _w0} - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs deleted file mode 100644 index 47a9895c2e..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Pair a b = Pair {pa :: a, pb :: b} - -p :: Pair (a -> a) (a -> b -> c -> b) -p = Pair {pa = _, pb = _} - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs deleted file mode 100644 index 9bcb21c9e7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -class Test a where - test :: Bool -> a - test False = _w0 - test True = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs deleted file mode 100644 index c082169c7b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs +++ /dev/null @@ -1,4 +0,0 @@ -class Test a where - test :: Bool -> a - test x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs deleted file mode 100644 index 6b73dfb0ec..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = case b of - False -> _w0 - True -> _w1 diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs deleted file mode 100644 index be2d0d30f5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs deleted file mode 100644 index 8095217673..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in case a of { (n, s) -> _w0 } - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs deleted file mode 100644 index ce6e0341c4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs deleted file mode 100644 index ba63836df3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t False = _w0 - t True = _w1 - in _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs deleted file mode 100644 index 71529d7dd3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t b = _ - in _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs deleted file mode 100644 index 0f7ee4e388..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - - -test :: Maybe [Bool] -> Maybe Bool -test (JustSingleton False) = _w0 -test (JustSingleton True) = _w1 - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs deleted file mode 100644 index 0497bb7244..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - - -test :: Maybe [Bool] -> Maybe Bool -test (JustSingleton a) = _ - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs deleted file mode 100644 index b92544f622..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern Blah :: a -> Maybe a -pattern Blah a = Just a - -test :: Maybe Bool -> a -test (Blah False) = _w0 -test (Blah True) = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs deleted file mode 100644 index 3cabb3c64b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern Blah :: a -> Maybe a -pattern Blah a = Just a - -test :: Maybe Bool -> a -test (Blah a) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs deleted file mode 100644 index d123c652d7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> Nothing) = _w0 -splitLookup (lookup 5 -> (Just s)) = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs deleted file mode 100644 index 6baed55abd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> a) = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs deleted file mode 100644 index 28ad669007..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -data A = A | B | C - -some :: A -> IO () -some a = do - foo - bar a - where - foo = putStrLn "Hi" - - bar :: A -> IO () - bar A = _w0 - bar B = _w1 - bar C = _w2 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs deleted file mode 100644 index 5035df1b0c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs +++ /dev/null @@ -1,12 +0,0 @@ -data A = A | B | C - -some :: A -> IO () -some a = do - foo - bar a - where - foo = putStrLn "Hi" - - bar :: A -> IO () - bar x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs deleted file mode 100644 index 713f686338..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs #-} - -data Z ab where - Z :: (a -> b) -> Z '(a, b) - -test :: Z ab -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs deleted file mode 100644 index 1498dfd8e4..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs deleted file mode 100644 index 9156cc0053..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs +++ /dev/null @@ -1,13 +0,0 @@ -test - :: (a1 -> a2) - -> (a2 -> a3) - -> (a3 -> a4) - -> (a4 -> a5) - -> (a5 -> a6) - -> (a6 -> a7) - -> (a7 -> a8) - -> (a8 -> a9) - -> (a9 -> a10) - -> a1 -> a10 -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs deleted file mode 100644 index 3c56bdbee9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs +++ /dev/null @@ -1 +0,0 @@ -foo = [wingman||] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs deleted file mode 100644 index fdfbd7289d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs +++ /dev/null @@ -1 +0,0 @@ -foo = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs deleted file mode 100644 index c8aa76e837..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = [wingman||] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs deleted file mode 100644 index 2aa2d1caa3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs deleted file mode 100644 index 00421ee479..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs deleted file mode 100644 index d25670bca1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split; assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs deleted file mode 100644 index 05f86c9963..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, _w0) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs deleted file mode 100644 index fe6c118829..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split, assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs deleted file mode 100644 index aac10101ec..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data AST a where - BoolLit :: Bool -> AST Bool - IntLit :: Int -> AST Int - If :: AST Bool -> AST a -> AST a -> AST a - Equal :: AST a -> AST a -> AST Bool - -eval :: AST a -> a -eval (BoolLit b) = b -eval (IntLit n) = n -eval (If ast ast' ast_a) - = let - ast_c = eval ast - ast'_c = eval ast' - ast_a_c = eval ast_a - in _w0 ast_c ast'_c ast_a_c -eval (Equal ast ast') - = let - ast_c = eval ast - ast'_c = eval ast' - in _w1 ast_c ast'_c - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs deleted file mode 100644 index 26e3a03cec..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data AST a where - BoolLit :: Bool -> AST Bool - IntLit :: Int -> AST Int - If :: AST Bool -> AST a -> AST a -> AST a - Equal :: AST a -> AST a -> AST Bool - -eval :: AST a -> a -eval = [wingman| intros x, cata x; collapse |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs deleted file mode 100644 index 58b4fb4ffc..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f, Yo g) => Yo (f :*: g) where - yo (fx :*: gx) - = let - fx_c = yo fx - gx_c = yo gx - in _w0 fx_c gx_c - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs deleted file mode 100644 index 14dc163f4d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f, Yo g) => Yo (f :*: g) where - yo = [wingman| intros x, cata x, collapse |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs deleted file mode 100644 index e9cef291a3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f) => Yo (M1 _1 _2 f) where - yo (M1 fx) = yo fx - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs deleted file mode 100644 index c1abb0acf2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs +++ /dev/null @@ -1,8 +0,0 @@ -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f) => Yo (M1 _1 _2 f) where - yo = [wingman| intros x, cata x, collapse |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs deleted file mode 100644 index c9d2f0cff9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = ((a, b), c) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs deleted file mode 100644 index 97e5b424ba..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = [wingman| split; split | assume c; assume a | assume b |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs deleted file mode 100644 index 90216da0a2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -whats_it_deep_of - :: (a -> a) - -> [(Int, Either Bool (Maybe [a]))] - -> [(Int, Either Bool (Maybe [a]))] --- The assumption here is necessary to tie-break in favor of the longest --- nesting of fmaps. -whats_it_deep_of f = fmap (fmap (fmap (fmap (fmap f)))) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs deleted file mode 100644 index 3afcdcc4e1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs +++ /dev/null @@ -1,8 +0,0 @@ -whats_it_deep_of - :: (a -> a) - -> [(Int, Either Bool (Maybe [a]))] - -> [(Int, Either Bool (Maybe [a]))] --- The assumption here is necessary to tie-break in favor of the longest --- nesting of fmaps. -whats_it_deep_of f = [wingman| nested fmap, assumption |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs deleted file mode 100644 index f589d989f7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -class Blah a b | a -> b, b -> a -instance Blah Int Bool - -foo :: Int -foo = 10 - -bar :: Blah a b => a -> b -bar = undefined - -qux :: Bool -qux = bar foo - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs deleted file mode 100644 index 36d0d4bf73..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -class Blah a b | a -> b, b -> a -instance Blah Int Bool - -foo :: Int -foo = 10 - -bar :: Blah a b => a -> b -bar = undefined - -qux :: Bool -qux = [wingman| use bar, use foo |] - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs deleted file mode 100644 index 21569c7c19..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = (foo <$> _w0) <*> _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs deleted file mode 100644 index f9506cb03b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = [wingman| idiom (use foo) |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs deleted file mode 100644 index e39e9a9fab..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = (Rec <$> _w0) <*> _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs deleted file mode 100644 index 87397da160..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = [wingman| idiom (ctor Rec) |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs deleted file mode 100644 index 54c3678c21..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test - = let - a = _w0 - b = _w1 - c = _w2 - in _w3 diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs deleted file mode 100644 index ae570bae7b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Int -test = [wingman| let a b c |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs deleted file mode 100644 index e0b60b74fa..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b -maybeAp Nothing Nothing = Nothing -maybeAp Nothing (Just _) = Nothing -maybeAp (Just _) Nothing = Nothing -maybeAp (Just fab) (Just a) = Just (fab a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs deleted file mode 100644 index 6159db4ecd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs +++ /dev/null @@ -1,11 +0,0 @@ -maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b -maybeAp = [wingman| - intros, - destruct_all, - obvious, - obvious, - obvious, - ctor Just, - application, - assumption - |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs deleted file mode 100644 index f92e7d40af..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Data.Monoid - -data Foo = Foo (Sum Int) (Sum Int) - -mappend2 :: Foo -> Foo -> Foo -mappend2 (Foo sum sum') (Foo sum2 sum3) - = Foo (mappend sum sum2) (mappend sum' sum3) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs deleted file mode 100644 index 77572569ff..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Monoid - -data Foo = Foo (Sum Int) (Sum Int) - -mappend2 :: Foo -> Foo -> Foo -mappend2 = [wingman| intros f1 f2, destruct_all, ctor Foo; pointwise (use mappend); assumption|] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs deleted file mode 100644 index 0940f9ea21..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = (_w0, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs deleted file mode 100644 index 582189bcbc..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = [wingman| split; try (assumption) |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs deleted file mode 100644 index c72f18589c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = isAlpha - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs deleted file mode 100644 index 87ac26bbcb..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = [wingman| intro c, use isAlpha, assume c |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs deleted file mode 100644 index 1afee3471a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = test - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs deleted file mode 100644 index 0f791818d1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs deleted file mode 100644 index acf46a75a0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = test - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs deleted file mode 100644 index 4723befd10..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs deleted file mode 100644 index 85012d7aaf..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = _w0 <> _w1 diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs deleted file mode 100644 index 4afe5f572d..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = [wingman| use (<>) |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs deleted file mode 100644 index 895e9333c0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = _w0 a diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs deleted file mode 100644 index 75c6ab0445..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = [wingman| with_arg, assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs deleted file mode 100644 index 4bbd4d283a..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah _ = Record - diff --git a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs deleted file mode 100644 index 82b994b936..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs b/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs deleted file mode 100644 index 2da53afbf5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs +++ /dev/null @@ -1,9 +0,0 @@ -foo :: Bool -> () -foo x = - if True - then - case x of - True -> _ - False -> () - else - _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs b/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs deleted file mode 100644 index 6a15b198dd..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs +++ /dev/null @@ -1,2 +0,0 @@ -basilisk :: Monoid Bool => a -basilisk = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs b/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs deleted file mode 100644 index dc096f38f1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} - -data GADT a where - B1 :: GADT Bool - B2 :: GADT Bool - Int :: GADT Int - Var :: GADT a - - -hasHomo :: GADT Bool -> GADT a -hasHomo g = _ - -cantHomo :: GADT a -> GADT Int -cantHomo g = _ - -hasHomoLam :: GADT Bool -> GADT a -hasHomoLam = _ - -cantHomoLam :: GADT a -> GADT Int -cantHomoLam = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs deleted file mode 100644 index 9bdcd61516..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - - -split :: GADT a -> a -split GADT {blah, bar} = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs deleted file mode 100644 index 250479e758..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - - -split :: GADT a -> a -split x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs deleted file mode 100644 index 7b661c2ee5..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Many - = Hello { world :: String } - | Goodbye { a :: Int, b :: Bool, c :: Many } - -test :: Many -> Many -test Hello {world} = _w0 -test Goodbye {a, b, c} = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs b/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs deleted file mode 100644 index 77234a7359..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Many - = Hello { world :: String } - | Goodbye { a :: Int, b :: Bool, c :: Many } - -test :: Many -> Many -test x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs deleted file mode 100644 index 5b3eaf2559..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - Bar :: - { zoo :: Bool - , baxter :: a - , another :: a - } -> GADT Bool - Baz :: GADT Int - - -split :: GADT Bool -> a -split GADT {blah, bar} = _w0 -split Bar {zoo, baxter, another} = _w1 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs deleted file mode 100644 index 70badb7ae2..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - Bar :: - { zoo :: Bool - , baxter :: a - , another :: a - } -> GADT Bool - Baz :: GADT Int - - -split :: GADT Bool -> a -split x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs deleted file mode 100644 index d3cc689a04..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax Bar {ax = n, bax} = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs deleted file mode 100644 index f2cce07cbc..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs deleted file mode 100644 index 65bc2d28d0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar Bar {ax, bax} = _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs deleted file mode 100644 index 6707399c28..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar x = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs deleted file mode 100644 index cfc2235bfb..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -data MyRecord a = Record - { field1 :: a - , field2 :: Int - } - -blah :: (a -> Int) -> a -> MyRecord a -blah f a = Record {field1 = a, field2 = f a} - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs deleted file mode 100644 index 651983e8a3..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs +++ /dev/null @@ -1,9 +0,0 @@ -data MyRecord a = Record - { field1 :: a - , field2 :: Int - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs deleted file mode 100644 index 7110f637da..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = (_w0, _w1, _w2) - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs deleted file mode 100644 index dc611f6e93..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs deleted file mode 100644 index 605f5e0a5c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - One :: (b -> Int) -> GADT Int - Two :: GADT Bool - -test :: z -> GADT Int -test z = One _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs deleted file mode 100644 index 6ac2853173..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - One :: (b -> Int) -> GADT Int - Two :: GADT Bool - -test :: z -> GADT Int -test z = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs deleted file mode 100644 index 5c99dfc3a1..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test a = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs deleted file mode 100644 index afe7524957..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs deleted file mode 100644 index 2d72de4c9b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = \ m_n -> _w0 - where - -- Don't delete me! - blah = undefined - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs deleted file mode 100644 index a9e4ca1db7..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = _ - where - -- Don't delete me! - blah = undefined - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs deleted file mode 100644 index 267e6b8015..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = Reader _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs deleted file mode 100644 index 9e68e115e9..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs deleted file mode 100644 index c76acc0d31..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -data ADT = One | Two Int | Three | Four Bool ADT | Five - -case_split :: ADT -> Int -case_split One = _ -case_split (Two i) = _ -case_split Three = _ -case_split (Four b One) = _w0 -case_split (Four b (Two n)) = _w1 -case_split (Four b Three) = _w2 -case_split (Four b (Four b' adt)) = _w3 -case_split (Four b Five) = _w4 -case_split Five = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs deleted file mode 100644 index ba66257007..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -data ADT = One | Two Int | Three | Four Bool ADT | Five - -case_split :: ADT -> Int -case_split One = _ -case_split (Two i) = _ -case_split Three = _ -case_split (Four b a) = _ -case_split Five = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs deleted file mode 100644 index e638fa311c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f (Dummy n) = n - diff --git a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs deleted file mode 100644 index 7487adf038..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/T1.hs b/plugins/hls-tactics-plugin/new/test/golden/T1.hs deleted file mode 100644 index 7ab382d69f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/T1.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapEither :: (a -> b) -> Either c a -> Either c b -fmapEither = _lalala - diff --git a/plugins/hls-tactics-plugin/new/test/golden/T2.hs b/plugins/hls-tactics-plugin/new/test/golden/T2.hs deleted file mode 100644 index 20b1644a8f..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/T2.hs +++ /dev/null @@ -1,12 +0,0 @@ -eitherFmap :: (a -> b) -> Either e a -> Either e b -eitherFmap fa eab = _ - -global :: Bool -global = True - -foo :: Int -foo = _ - -dontSuggestLambdaCase :: Either a b -> Int -dontSuggestLambdaCase = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/T3.hs b/plugins/hls-tactics-plugin/new/test/golden/T3.hs deleted file mode 100644 index 1bb42a9b02..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/T3.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -suggestHomomorphicLC :: Either a b -> Either a b -suggestHomomorphicLC = _ - -suggestLC :: Either a b -> Int -suggestLC = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs deleted file mode 100644 index 26d6d77b8b..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Left _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs deleted file mode 100644 index 59d03ae7d0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs deleted file mode 100644 index 1a5caad890..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = (_w0, _w1) diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs deleted file mode 100644 index 2d15fe3500..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs deleted file mode 100644 index f36809804c..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Right _w0 - diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs deleted file mode 100644 index 59d03ae7d0..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/plugins/hls-tactics-plugin/new/test/golden/hie.yaml b/plugins/hls-tactics-plugin/new/test/golden/hie.yaml deleted file mode 100644 index 7aa4f9e0ad..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/hie.yaml +++ /dev/null @@ -1 +0,0 @@ -cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/plugins/hls-tactics-plugin/new/test/golden/test.cabal b/plugins/hls-tactics-plugin/new/test/golden/test.cabal deleted file mode 100644 index 845edafa26..0000000000 --- a/plugins/hls-tactics-plugin/new/test/golden/test.cabal +++ /dev/null @@ -1,17 +0,0 @@ -name: test -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Author name here -maintainer: example@example.com -copyright: 2017 Author name here -category: Web -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: T1, T2 - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall -fwarn-unused-imports diff --git a/plugins/hls-tactics-plugin/old/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/old/src/Ide/Plugin/Tactic.hs deleted file mode 100644 index cf326ee653..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Ide/Plugin/Tactic.hs +++ /dev/null @@ -1,5 +0,0 @@ --- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log(..)) where - -import Wingman.Plugin - diff --git a/plugins/hls-tactics-plugin/old/src/Refinery/Future.hs b/plugins/hls-tactics-plugin/old/src/Refinery/Future.hs deleted file mode 100644 index e829672831..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Refinery/Future.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------- --- | Things that belong in the future release of refinery v5. -module Refinery.Future - ( runStreamingTacticT - , hoistListT - , consume - ) where - -import Control.Applicative -import Control.Monad (ap, (>=>)) -import Control.Monad.State.Lazy (runStateT) -import Control.Monad.Trans -import Data.Either (isRight) -import Data.Functor ((<&>)) -import Data.Tuple (swap) -import Refinery.ProofState -import Refinery.Tactic.Internal - - - -hoistElem :: Functor m => (forall x. m x -> n x) -> Elem m a -> Elem n a -hoistElem _ Done = Done -hoistElem f (Next a lt) = Next a $ hoistListT f lt - - -hoistListT :: Functor m => (forall x. m x -> n x) -> ListT m a -> ListT n a -hoistListT f t = ListT $ f $ fmap (hoistElem f) $ unListT t - - -consume :: Monad m => ListT m a -> (a -> m ()) -> m () -consume lt f = unListT lt >>= \case - Done -> pure () - Next a lt' -> f a >> consume lt' f - - -newHole :: MonadExtract meta ext err s m => s -> m (s, (meta, ext)) -newHole = fmap swap . runStateT hole - -runStreamingTacticT :: (MonadExtract meta ext err s m) => TacticT jdg ext err s m () -> jdg -> s -> ListT m (Either err (Proof s meta jdg ext)) -runStreamingTacticT t j s = streamProofs s $ fmap snd $ proofState t j - -data Elem m a - = Done - | Next a (ListT m a) - deriving stock Functor - - -point :: Applicative m => a -> Elem m a -point a = Next a $ ListT $ pure Done - -newtype ListT m a = ListT { unListT :: m (Elem m a) } - -cons :: (Applicative m) => a -> ListT m a -> ListT m a -cons x xs = ListT $ pure $ Next x xs - -instance Functor m => Functor (ListT m) where - fmap f (ListT xs) = ListT $ xs <&> \case - Done -> Done - Next a xs -> Next (f a) (fmap f xs) - -instance (Monad m) => Applicative (ListT m) where - pure = return - (<*>) = ap - -instance (Monad m) => Alternative (ListT m) where - empty = ListT $ pure Done - (ListT xs) <|> (ListT ys) = - ListT $ xs >>= \case - Done -> ys - Next x xs -> pure (Next x (xs <|> ListT ys)) - -instance (Monad m) => Monad (ListT m) where - return a = cons a empty - (ListT xs) >>= k = - ListT $ xs >>= \case - Done -> pure Done - Next x xs -> unListT $ k x <|> (xs >>= k) - - -instance MonadTrans ListT where - lift m = ListT $ fmap (\x -> Next x empty) m - - -interleaveT :: (Monad m) => Elem m a -> Elem m a -> Elem m a -interleaveT xs ys = - case xs of - Done -> ys - Next x xs -> Next x $ ListT $ fmap (interleaveT ys) $ unListT xs - --- ys <&> \case --- Done -> Next x xs --- Next y ys -> Next x (cons y (interleaveT xs ys)) - -force :: (Monad m) => Elem m a -> m [a] -force = \case - Done -> pure [] - Next x xs' -> (x:) <$> (unListT xs' >>= force) - -ofList :: Monad m => [a] -> Elem m a -ofList [] = Done -ofList (x:xs) = Next x $ ListT $ pure $ ofList xs - -streamProofs :: forall ext err s m goal meta. (MonadExtract meta ext err s m) => s -> ProofStateT ext ext err s m goal -> ListT m (Either err (Proof s meta goal ext)) -streamProofs s p = ListT $ go s [] pure p - where - go :: s -> [(meta, goal)] -> (err -> m err) -> ProofStateT ext ext err s m goal -> m (Elem m (Either err (Proof s meta goal ext))) - go s goals _ (Subgoal goal k) = do - (s', (meta, h)) <- newHole s - -- Note [Handler Reset]: - -- We reset the handler stack to avoid the handlers leaking across subgoals. - -- This would happen when we had a handler that wasn't followed by an error call. - -- pair >> goal >>= \g -> (handler_ $ \_ -> traceM $ "Handling " <> show g) <|> failure "Error" - -- We would see the "Handling a" message when solving for b. - go s' (goals ++ [(meta, goal)]) pure $ k h - go s goals handlers (Effect m) = m >>= go s goals handlers - go s goals handlers (Stateful f) = - let (s', p) = f s - in go s' goals handlers p - go s goals handlers (Alt p1 p2) = - unListT $ ListT (go s goals handlers p1) <|> ListT (go s goals handlers p2) - go s goals handlers (Interleave p1 p2) = - interleaveT <$> go s goals handlers p1 <*> go s goals handlers p2 - go s goals handlers (Commit p1 p2) = do - solns <- force =<< go s goals handlers p1 - if any isRight solns then pure $ ofList solns else go s goals handlers p2 - go _ _ _ Empty = pure Done - go _ _ handlers (Failure err _) = do - annErr <- handlers err - pure $ point $ Left annErr - go s goals handlers (Handle p h) = - -- Note [Handler ordering]: - -- If we have multiple handlers in scope, then we want the handlers closer to the error site to - -- run /first/. This allows the handlers up the stack to add their annotations on top of the - -- ones lower down, which is the behavior that we desire. - -- IE: for @handler f >> handler g >> failure err@, @g@ ought to be run before @f@. - go s goals (h >=> handlers) p - go s goals _ (Axiom ext) = pure $ point $ Right (Proof ext s goals) - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs deleted file mode 100644 index 604cbfac3e..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.AbstractLSP (installInteractions) where - -import Control.Monad (void) -import Control.Monad.IO.Class -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Except (ExceptT(ExceptT)) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) -import qualified Data.Aeson as A -import Data.Coerce -import Data.Foldable (traverse_) -import Data.Monoid (Last (..)) -import qualified Data.Text as T -import Data.Traversable (for) -import Data.Tuple.Extra (uncurry3) -import Development.IDE (IdeState) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource)) -import Ide.Plugin.Error -import qualified Ide.Plugin.Config as Plugin -import Ide.Types -import Language.LSP.Server (LspM, sendRequest, getClientCapabilities, getVersionedTextDoc) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) -import Wingman.AbstractLSP.Types -import Wingman.EmptyCase (fromMaybeT) -import Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) -import Wingman.StaticPlugin (enableQuasiQuotes) -import Wingman.Types -import Control.Lens ((^.)) - - ------------------------------------------------------------------------------- --- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are --- self-contained request/response pairs that abstract over the LSP, and --- provide a unified interface for doing interesting things, without needing to --- dive into the underlying API too directly. -installInteractions - :: [Interaction] - -> PluginDescriptor IdeState - -> PluginDescriptor IdeState -installInteractions is desc = - let plId = pluginId desc - in desc - { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is - , pluginHandlers = pluginHandlers desc <> buildHandlers is - } - - ------------------------------------------------------------------------------- --- | Extract 'PluginHandlers' from 'Interaction's. -buildHandlers - :: [Interaction] - -> PluginHandlers IdeState -buildHandlers cs = - flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> - case c_makeCommand c of - SynthesizeCodeAction k -> - mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider @target (c_sort c) k - SynthesizeCodeLens k -> - mkPluginHandler SMethod_TextDocumentCodeLens $ codeLensProvider @target (c_sort c) k - - ------------------------------------------------------------------------------- --- | Extract a 'PluginCommand' from an 'Interaction'. -buildCommand - :: PluginId - -> Interaction - -> PluginCommand IdeState -buildCommand plId (Interaction (c :: Continuation sort target b)) = - PluginCommand - { commandId = toCommandId $ c_sort c - , commandDesc = T.pack "" - , commandFunc = runContinuation plId c - } - - ------------------------------------------------------------------------------- --- | Boilerplate for running a 'Continuation' as part of an LSP command. -runContinuation - :: forall sort a b - . IsTarget a - => PluginId - -> Continuation sort a b - -> CommandFunction IdeState (FileContext, b) -runContinuation plId cont state (fc, b) = ExceptT $ do - fromMaybeT - (Left $ PluginInternalError "TODO(sandy)") $ do - env@LspEnv{..} <- buildEnv state plId fc - nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri - let stale a = runStaleIde "runContinuation" state nfp a - args <- fetchTargetArgs @a env - res <- c_runCommand cont env args fc b - - -- This block returns a maybe error. - fmap (maybe (Right $ InR Null) Left . coerce . foldMap Last) $ - for res $ \case - ErrorMessages errs -> do - traverse_ showUserFacingMessage errs - pure Nothing - RawEdit edits -> do - sendEdits edits - pure Nothing - GraftEdit gr -> do - ccs <- lift getClientCapabilities - TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_verTxtDocId le_fileContext) (unTrack pm) gr of - Left errs -> - pure $ Just $ PluginInternalError (T.pack $ show errs) - Right edits -> do - sendEdits edits - pure Nothing - - ------------------------------------------------------------------------------- --- | Push a 'WorkspaceEdit' to the client. -sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () -sendEdits edits = - void $ lift $ - sendRequest - SMethod_WorkspaceApplyEdit - (ApplyWorkspaceEditParams Nothing edits) - (const $ pure ()) - - ------------------------------------------------------------------------------- --- | Push a 'UserFacingMessage' to the client. -showUserFacingMessage - :: UserFacingMessage - -> MaybeT (LspM Plugin.Config) () -showUserFacingMessage ufm = - void $ lift $ showLspMessage $ mkShowMessageParams ufm - - ------------------------------------------------------------------------------- --- | Build an 'LspEnv', which contains the majority of things we need to know --- in a 'Continuation'. -buildEnv - :: IdeState - -> PluginId - -> FileContext - -> MaybeT (LspM Plugin.Config) LspEnv -buildEnv state plId fc = do - cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId - nfp <- getNfp $ fc_verTxtDocId fc ^. L.uri - dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp - pure $ LspEnv - { le_ideState = state - , le_pluginId = plId - , le_dflags = dflags - , le_config = cfg - , le_fileContext = fc - } - - ------------------------------------------------------------------------------- --- | Lift a 'Continuation' into an LSP CodeAction. -codeActionProvider - :: forall target sort b - . (IsContinuationSort sort, A.ToJSON b, IsTarget target) - => sort - -> ( LspEnv - -> TargetArgs target - -> MaybeT (LspM Plugin.Config) [(Metadata, b)] - ) - -> PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider sort k state plId - (CodeActionParams _ _ docId range _) = do - verTxtDocId <- lift $ getVersionedTextDoc docId - handleMaybeM (PluginInvalidUserState "codeActionProvider") $ runMaybeT $ do - let fc = FileContext - { fc_verTxtDocId = verTxtDocId - , fc_range = Just $ unsafeMkCurrent range - } - env <- buildEnv state plId fc - args <- fetchTargetArgs @target env - actions <- k env args - pure - $ InL - $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions - - ------------------------------------------------------------------------------- --- | Lift a 'Continuation' into an LSP CodeLens. -codeLensProvider - :: forall target sort b - . (IsContinuationSort sort, A.ToJSON b, IsTarget target) - => sort - -> ( LspEnv - -> TargetArgs target - -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] - ) - -> PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLensProvider sort k state plId - (CodeLensParams _ _ docId) = do - verTxtDocId <- lift $ getVersionedTextDoc docId - handleMaybeM (PluginInvalidUserState "codeLensProvider") $ runMaybeT $ do - let fc = FileContext - { fc_verTxtDocId = verTxtDocId - , fc_range = Nothing - } - env <- buildEnv state plId fc - args <- fetchTargetArgs @target env - actions <- k env args - pure - $ InL - $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions - - ------------------------------------------------------------------------------- --- | Build a 'LSP.CodeAction'. -makeCodeAction - :: (A.ToJSON b, IsContinuationSort sort) - => PluginId - -> FileContext - -> sort - -> Metadata - -> b - -> LSP.CodeAction -makeCodeAction plId fc sort (Metadata title kind preferred) b = - let cmd_id = toCommandId sort - cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)] - in LSP.CodeAction - { _title = title - , _kind = Just kind - , _diagnostics = Nothing - , _isPreferred = Just preferred - , _disabled = Nothing - , _edit = Nothing - , _command = Just cmd - , _data_ = Nothing - } - - ------------------------------------------------------------------------------- --- | Build a 'LSP.CodeLens'. -makeCodeLens - :: (A.ToJSON b, IsContinuationSort sort) - => PluginId - -> sort - -> FileContext - -> Range - -> Metadata - -> b - -> LSP.CodeLens -makeCodeLens plId sort fc range (Metadata title _ _) b = - let fc' = fc { fc_range = Just $ unsafeMkCurrent range } - cmd_id = toCommandId sort - cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)] - in LSP.CodeLens - { _range = range - , _command = Just cmd - , _data_ = Nothing - } - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs deleted file mode 100644 index 7c74eac8dc..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.AbstractLSP.TacticActions where - -import Control.Lens ((^.)) -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (mapMaybeT) -import Data.Foldable -import Data.Maybe (listToMaybe) -import Data.Proxy -import Development.IDE hiding (rangeToRealSrcSpan) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Generics.SYB.GHC (mkBindListT, everywhereM') -import qualified Language.LSP.Protocol.Lens as L -import Wingman.AbstractLSP.Types -import Wingman.CaseSplit -import Wingman.GHC (liftMaybe, isHole, pattern AMatch) -import Wingman.Judgements (jNeedsToBindArgs) -import Wingman.LanguageServer (runStaleIde) -import Wingman.LanguageServer.TacticProviders -import Wingman.Machinery (runTactic, scoreSolution) -import Wingman.Range -import Wingman.Types -import Development.IDE.Core.Service (getIdeOptionsIO) -import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting)) - - ------------------------------------------------------------------------------- --- | An 'Interaction' for a 'TacticCommand'. -makeTacticInteraction - :: TacticCommand - -> Interaction -makeTacticInteraction cmd = - Interaction $ Continuation @_ @HoleTarget cmd - (SynthesizeCodeAction $ \env hj -> do - pure $ commandProvider cmd $ - TacticProviderData - { tpd_lspEnv = env - , tpd_jdg = hj_jdg hj - , tpd_hole_sort = hj_hole_sort hj - } - ) - $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do - nfp <- getNfp (fc_verTxtDocId ^. L.uri) - let stale a = runStaleIde "tacticCmd" le_ideState nfp a - - let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range - TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - pm_span <- liftMaybe $ mapAgeFrom pmmap span - IdeOptions{optTesting = IdeTesting isTesting} <- - liftIO $ getIdeOptionsIO (shakeExtras le_ideState) - - let t = commandTactic cmd var_name - timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds - - liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case - Left err -> - pure - $ pure - $ ErrorMessages - $ pure - $ mkUserFacingMessage err - Right rtr -> - case rtr_extract rtr of - L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) -> - pure - $ addTimeoutMessage rtr - $ pure - $ ErrorMessages - $ pure NothingToDo - _ -> do - for_ (rtr_other_solns rtr) $ \soln -> do - traceMX "other solution" $ syn_val soln - traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) [] - traceMX "solution" $ rtr_extract rtr - pure - $ addTimeoutMessage rtr - $ pure - $ GraftEdit - $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr - - -addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult] -addTimeoutMessage rtr = mappend - [ ErrorMessages $ pure TimedOut - | rtr_timed_out rtr - ] - - ------------------------------------------------------------------------------- --- | The number of microseconds in a second -seconds :: Num a => a -seconds = 1e6 - - ------------------------------------------------------------------------------- --- | Transform some tactic errors into a 'UserFacingMessage'. -mkUserFacingMessage :: [TacticError] -> UserFacingMessage -mkUserFacingMessage errs - | elem OutOfGas errs = NotEnoughGas -mkUserFacingMessage [] = NothingToDo -mkUserFacingMessage _ = TacticErrors - - ------------------------------------------------------------------------------- --- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly --- deals with top-level holes, in which we might need to fiddle with the --- 'Match's that bind variables. -graftHole - :: SrcSpan - -> RunTacticResults - -> Graft (Either String) ParsedSource -graftHole span rtr - | _jIsTopHole (rtr_jdg rtr) - = genericGraftWithSmallestM - (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span - $ \dflags matches -> - everywhereM' - $ mkBindListT $ \ix -> - graftDecl dflags span ix $ \name pats -> - splitToDecl - (case not $ jNeedsToBindArgs (rtr_jdg rtr) of - -- If the user has explicitly bound arguments, use the - -- fixity they wrote. - True -> matchContextFixity . m_ctxt . unLoc - =<< listToMaybe matches - -- Otherwise, choose based on the name of the function. - False -> Nothing - ) - (occName name) - $ iterateSplit - $ mkFirstAgda pats - $ unLoc - $ rtr_extract rtr -graftHole span rtr - = graft span - $ rtr_extract rtr - - ------------------------------------------------------------------------------- --- | Keep a fixity if one was present in the 'HsMatchContext'. -matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity -matchContextFixity (FunRhs _ l _) = Just l -matchContextFixity _ = Nothing - - ------------------------------------------------------------------------------- --- | Helper function to route 'mergeFunBindMatches' into the right place in an --- AST --- correctly dealing with inserting into instance declarations. -graftDecl - :: DynFlags - -> SrcSpan - -> Int - -> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs) - -> LMatch GhcPs (LHsExpr GhcPs) - -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)] -graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _)) - | dst `isSubspanOf` src = do - L _ dec <- annotateDecl dflags $ make_decl name pats - case dec of - ValD _ FunBind{ fun_matches = MG { mg_alts = L _ alts@(first_match : _)} - } -> do - -- For whatever reason, ExactPrint annotates newlines to the ends of - -- case matches and type signatures, but only allows us to insert - -- them at the beginning of those things. Thus, we need want to - -- insert a preceding newline (done in 'annotateDecl') on all - -- matches, except for the first one --- since it gets its newline - -- from the line above. - when (ix == 0) $ - setPrecedingLinesT first_match 0 0 - pure alts - _ -> lift $ Left "annotateDecl didn't produce a funbind" -graftDecl _ _ _ _ x = pure $ pure x - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs deleted file mode 100644 index 0b4e4cde11..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.AbstractLSP.Types where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT) -import Control.Lens ((^.)) -import qualified Data.Aeson as A -import Data.Text (Text) -import Development.IDE (IdeState) -import Development.IDE.GHC.ExactPrint (Graft) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (Target) -import GHC.Generics (Generic) -import qualified Ide.Plugin.Config as Plugin -import Ide.Types hiding (Config) -import Language.LSP.Server (LspM) -import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) -import qualified Language.LSP.Protocol.Lens as L -import Wingman.LanguageServer (judgementForHole) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | An 'Interaction' is an existential 'Continuation', which handles both --- sides of the request/response interaction for LSP. -data Interaction where - Interaction - :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b) - => Continuation sort target b - -> Interaction - - ------------------------------------------------------------------------------- --- | Metadata for a command. Used by both code actions and lenses, though for --- lenses, only 'md_title' is currently used. -data Metadata - = Metadata - { md_title :: Text - , md_kind :: CodeActionKind - , md_preferred :: Bool - } - deriving stock (Eq, Show) - - ------------------------------------------------------------------------------- --- | Whether we're defining a CodeAction or CodeLens. -data SynthesizeCommand a b - = SynthesizeCodeAction - ( LspEnv - -> TargetArgs a - -> MaybeT (LspM Plugin.Config) [(Metadata, b)] - ) - | SynthesizeCodeLens - ( LspEnv - -> TargetArgs a - -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] - ) - - ------------------------------------------------------------------------------- --- | Transform a "continuation sort" into a 'CommandId'. -class IsContinuationSort a where - toCommandId :: a -> CommandId - -instance IsContinuationSort CommandId where - toCommandId = id - -instance IsContinuationSort Text where - toCommandId = CommandId - - ------------------------------------------------------------------------------- --- | Ways a 'Continuation' can resolve. -data ContinuationResult - = -- | Produce some error messages. - ErrorMessages [UserFacingMessage] - -- | Produce an explicit 'WorkspaceEdit'. - | RawEdit WorkspaceEdit - -- | Produce a 'Graft', corresponding to a transformation of the current - -- AST. - | GraftEdit (Graft (Either String) ParsedSource) - - ------------------------------------------------------------------------------- --- | A 'Continuation' is a single object corresponding to an action that users --- can take via LSP. It generalizes codeactions and codelenses, allowing for --- a significant amount of code reuse. --- --- Given @Continuation sort target payload@: --- --- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions --- rather than working directly with text. This functionality is driven via --- 'IsContinuationSort'. --- --- the @target@ is used to fetch data from LSP on both sides of the --- request/response barrier. For example, you can use it to resolve what node --- in the AST the incoming range refers to. This functionality is driven via --- 'IsTarget'. --- --- the @payload@ is used for data you'd explicitly like to send from the --- request to the response. It's like @target@, but only gets computed once. --- This is beneficial if you can do it, but requires that your data is --- serializable via JSON. -data Continuation sort target payload = Continuation - { c_sort :: sort - , c_makeCommand :: SynthesizeCommand target payload - , c_runCommand - :: LspEnv - -> TargetArgs target - -> FileContext - -> payload - -> MaybeT (LspM Plugin.Config) [ContinuationResult] - } - - ------------------------------------------------------------------------------- --- | What file are we looking at, and what bit of it? -data FileContext = FileContext - { fc_verTxtDocId :: VersionedTextDocumentIdentifier - , fc_range :: Maybe (Tracked 'Current Range) - -- ^ For code actions, this is 'Just'. For code lenses, you'll get - -- a 'Nothing' in the request, and a 'Just' in the response. - } - deriving stock (Eq, Show, Generic) - deriving anyclass (A.ToJSON, A.FromJSON) - - ------------------------------------------------------------------------------- --- | Everything we need to resolve continuations. -data LspEnv = LspEnv - { le_ideState :: IdeState - , le_pluginId :: PluginId - , le_dflags :: DynFlags - , le_config :: Config - , le_fileContext :: FileContext - } - - ------------------------------------------------------------------------------- --- | Extract some information from LSP, so it can be passed to the requests and --- responses of a 'Continuation'. -class IsTarget t where - type TargetArgs t - fetchTargetArgs - :: LspEnv - -> MaybeT (LspM Plugin.Config) (TargetArgs t) - ------------------------------------------------------------------------------- --- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given --- range is an HsExpr hole. It gives continuations access to the resulting --- tactic judgement. -data HoleTarget = HoleTarget - deriving stock (Eq, Ord, Show, Enum, Bounded) - -getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath -getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri - -instance IsTarget HoleTarget where - type TargetArgs HoleTarget = HoleJudgment - fetchTargetArgs LspEnv{..} = do - let FileContext{..} = le_fileContext - range <- MaybeT $ pure fc_range - nfp <- getNfp (fc_verTxtDocId ^. L.uri) - mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Auto.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Auto.hs deleted file mode 100644 index 3748af1e5b..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Auto.hs +++ /dev/null @@ -1,32 +0,0 @@ - -module Wingman.Auto where - -import Control.Monad.Reader.Class (asks) -import Control.Monad.State (gets) -import qualified Data.Set as S -import Refinery.Tactic -import Wingman.Judgements -import Wingman.KnownStrategies -import Wingman.Machinery (tracing, getCurrentDefinitions) -import Wingman.Tactics -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Automatically solve a goal. -auto :: TacticsM () -auto = do - jdg <- goal - skolems <- gets ts_skolems - gas <- asks $ cfg_auto_gas . ctxConfig - current <- getCurrentDefinitions - traceMX "goal" jdg - traceMX "ctx" current - traceMX "skolems" skolems - commit knownStrategies - . tracing "auto" - . localTactic (auto' gas) - . disallowing RecursiveCall - . S.fromList - $ fmap fst current - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/old/src/Wingman/CaseSplit.hs deleted file mode 100644 index 373fc9b23b..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/CaseSplit.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Wingman.CaseSplit - ( mkFirstAgda - , iterateSplit - , splitToDecl - ) where - -import Data.Bool (bool) -import Data.Data -import Data.Generics -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.GHC.Compat -import GHC.Exts (IsString (fromString)) -import GHC.SourceGen (funBindsWithFixity, match, wildP) -import Wingman.GHC -import Wingman.Types - - - ------------------------------------------------------------------------------- --- | Construct an 'AgdaMatch' from patterns in scope (should be the LHS of the --- match) and a body. -mkFirstAgda :: [Pat GhcPs] -> HsExpr GhcPs -> AgdaMatch -mkFirstAgda pats (Lambda pats' body) = mkFirstAgda (pats <> pats') body -mkFirstAgda pats body = AgdaMatch pats body - - ------------------------------------------------------------------------------- --- | Transform an 'AgdaMatch' whose body is a case over a bound pattern, by --- splitting it into multiple matches: one for each alternative of the case. -agdaSplit :: AgdaMatch -> [AgdaMatch] -agdaSplit (AgdaMatch pats (Case (HsVar _ (L _ var)) matches)) - -- Ensure the thing we're destructing is actually a pattern that's been - -- bound. - | containsVar var pats - = do - (pat, body) <- matches - -- TODO(sandy): use an at pattern if necessary - pure $ AgdaMatch (rewriteVarPat var pat pats) $ unLoc body -agdaSplit x = [x] - - ------------------------------------------------------------------------------- --- | Replace unused bound patterns with wild patterns. -wildify :: AgdaMatch -> AgdaMatch -wildify (AgdaMatch pats body) = - let make_wild = bool id (wildifyT (allOccNames body)) $ not $ containsHole body - in AgdaMatch (make_wild pats) body - - ------------------------------------------------------------------------------- --- | Helper function for 'wildify'. -wildifyT :: Data a => Set OccName -> a -> a -wildifyT (S.map occNameString -> used) = everywhere $ mkT $ \case - VarPat _ (L _ var) | S.notMember (occNameString $ occName var) used -> wildP - (x :: Pat GhcPs) -> x - - ------------------------------------------------------------------------------- --- | Determine whether the given 'RdrName' exists as a 'VarPat' inside of @a@. -containsVar :: Data a => RdrName -> a -> Bool -containsVar name = everything (||) $ - mkQ False (\case - VarPat _ (L _ var) -> eqRdrName name var - (_ :: Pat GhcPs) -> False - ) - `extQ` \case - HsRecField lbl _ True -> eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl - (_ :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> False - - ------------------------------------------------------------------------------- --- | Replace a 'VarPat' with the given @'Pat' GhcPs@. -rewriteVarPat :: Data a => RdrName -> Pat GhcPs -> a -> a -rewriteVarPat name rep = everywhere $ - mkT (\case - VarPat _ (L _ var) | eqRdrName name var -> rep - (x :: Pat GhcPs) -> x - ) - `extT` \case - HsRecField lbl _ True - | eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl - -> HsRecField lbl (toPatCompat rep) False - (x :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> x - - ------------------------------------------------------------------------------- --- | Construct an 'HsDecl' from a set of 'AgdaMatch'es. -splitToDecl - :: Maybe LexicalFixity - -> OccName -- ^ The name of the function - -> [AgdaMatch] - -> LHsDecl GhcPs -splitToDecl fixity name ams = do - traceX "fixity" fixity $ - noLoc $ - funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do - AgdaMatch pats body <- ams - pure $ match pats body - - ------------------------------------------------------------------------------- --- | Sometimes 'agdaSplit' exposes another opportunity to do 'agdaSplit'. This --- function runs it a few times, hoping it will find a fixpoint. -iterateSplit :: AgdaMatch -> [AgdaMatch] -iterateSplit am = - let iterated = iterate (agdaSplit =<<) $ pure am - in fmap wildify . (!! 5) $ iterated - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen.hs deleted file mode 100644 index 322a6f5b8c..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.CodeGen - ( module Wingman.CodeGen - , module Wingman.CodeGen.Utils - ) where - - -import Control.Lens ((%~), (<>~), (&)) -import Control.Monad.Except -import Control.Monad.Reader (ask) -import Control.Monad.State -import Data.Bifunctor (second) -import Data.Bool (bool) -import Data.Functor ((<&>)) -import Data.Generics.Labels () -import Data.List -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat -import GHC.Exts -import GHC.SourceGen (occNameToStr) -import GHC.SourceGen.Binds -import GHC.SourceGen.Expr -import GHC.SourceGen.Overloaded -import GHC.SourceGen.Pat -import Wingman.CodeGen.Utils -import Wingman.GHC -import Wingman.Judgements -import Wingman.Judgements.Theta -import Wingman.Machinery -import Wingman.Naming -import Wingman.Types - - -destructMatches - :: Bool - -> (ConLike -> Judgement -> Rule) - -- ^ How to construct each match - -> Maybe OccName - -- ^ Scrutinee - -> CType - -- ^ Type being destructed - -> Judgement - -> RuleM (Synthesized [RawMatch]) --- TODO(sandy): In an ideal world, this would be the same codepath as --- 'destructionFor'. Make sure to change that if you ever change this. -destructMatches use_field_puns f scrut t jdg = do - let hy = jEntireHypothesis jdg - g = jGoal jdg - case tacticsGetDataCons $ unCType t of - Nothing -> cut -- throwError $ GoalMismatch "destruct" g - Just (dcs, apps) -> - fmap unzipTrace $ for dcs $ \dc -> do - let con = RealDataCon dc - ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps - -- We explicitly do not need to add the method hypothesis to - -- #syn_scoped - method_hy = foldMap evidenceToHypothesis ev - args = conLikeInstOrigArgTys' con apps - ctx <- ask - - let names_in_scope = hyNamesInScope hy - names = mkManyGoodNames (hyNamesInScope hy) args - (names', destructed) = - mkDestructPat (bool Nothing (Just names_in_scope) use_field_puns) con names - - let hy' = patternHypothesis scrut con jdg - $ zip names' - $ coerce args - j = withNewCoercions (evidenceToCoercions ev) - $ introduce ctx hy' - $ introduce ctx method_hy - $ withNewGoal g jdg - ext <- f con j - pure $ ext - & #syn_trace %~ rose ("match " <> show dc <> " {" <> intercalate ", " (fmap show names') <> "}") - . pure - & #syn_scoped <>~ hy' - & #syn_val %~ match [destructed] . unLoc - - ------------------------------------------------------------------------------- --- | Generate just the 'Match'es for a case split on a specific type. -destructionFor :: Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)] --- TODO(sandy): In an ideal world, this would be the same codepath as --- 'destructMatches'. Make sure to change that if you ever change this. -destructionFor hy t = do - case tacticsGetDataCons t of - Nothing -> Nothing - Just ([], _) -> Nothing - Just (dcs, apps) -> do - for dcs $ \dc -> do - let con = RealDataCon dc - args = conLikeInstOrigArgTys' con apps - names = mkManyGoodNames (hyNamesInScope hy) args - pure - . noLoc - . Match - noExtField - CaseAlt - [toPatCompat $ snd $ mkDestructPat Nothing con names] - . GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_") - . noLoc - $ EmptyLocalBinds noExtField - - - ------------------------------------------------------------------------------- --- | Produces a pattern for a data con and the names of its fields. -mkDestructPat :: Maybe (S.Set OccName) -> ConLike -> [OccName] -> ([OccName], Pat GhcPs) -mkDestructPat already_in_scope con names - | RealDataCon dcon <- con - , isTupleDataCon dcon = - (names, tuple pat_args) - | fields@(_:_) <- zip (conLikeFieldLabels con) names - , Just in_scope <- already_in_scope = - let (names', rec_fields) = - unzip $ fields <&> \(label, name) -> do - let label_occ = mkVarOccFS $ flLabel label - case S.member label_occ in_scope of - -- We have a shadow, so use the generated name instead - True -> - (name,) $ noLoc $ - HsRecField - (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ) - (noLoc $ bvar' name) - False - -- No shadow, safe to use a pun - False -> - (label_occ,) $ noLoc $ - HsRecField - (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ) - (noLoc $ bvar' label_occ) - True - - in (names', ) - $ ConPatIn (noLoc $ Unqual $ occName $ conLikeName con) - $ RecCon - $ HsRecFields rec_fields Nothing - | otherwise = - (names, ) $ infixifyPatIfNecessary con $ - conP - (coerceName $ conLikeName con) - pat_args - where - pat_args = fmap bvar' names - - -infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs -infixifyPatIfNecessary dcon x - | conLikeIsInfix dcon = - case x of - ConPatIn op (PrefixCon [lhs, rhs]) -> - ConPatIn op $ InfixCon lhs rhs - y -> y - | otherwise = x - - - -unzipTrace :: [Synthesized a] -> Synthesized [a] -unzipTrace = sequenceA - - --- | Essentially same as 'dataConInstOrigArgTys' in GHC, --- but only accepts universally quantified types as the second arguments --- and automatically introduces existentials. --- --- NOTE: The behaviour depends on GHC's 'dataConInstOrigArgTys'. --- We need some tweaks if the compiler changes the implementation. -conLikeInstOrigArgTys' - :: ConLike - -- ^ 'DataCon'structor - -> [Type] - -- ^ /Universally/ quantified type arguments to a result type. - -- It /MUST NOT/ contain any dictionaries, coercion and existentials. - -- - -- For example, for @MkMyGADT :: b -> MyGADT a c@, we - -- must pass @[a, c]@ as this argument but not @b@, as @b@ is an existential. - -> [Type] - -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument. -conLikeInstOrigArgTys' con uniTys = - let exvars = conLikeExTys con - in fmap scaledThing $ conLikeInstOrigArgTys con $ - uniTys ++ fmap mkTyVarTy exvars - -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys' - -- unifies the second argument with DataCon's universals followed by existentials. - -- If the definition of 'dataConInstOrigArgTys' changes, - -- this place must be changed accordingly. - - -conLikeExTys :: ConLike -> [TyCoVar] -conLikeExTys (RealDataCon d) = dataConExTyCoVars d -conLikeExTys (PatSynCon p) = patSynExTys p - -patSynExTys :: PatSyn -> [TyCoVar] -patSynExTys ps = patSynExTyVars ps - - ------------------------------------------------------------------------------- --- | Combinator for performing case splitting, and running sub-rules on the --- resulting matches. - -destruct' :: Bool -> (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule -destruct' use_field_puns f hi jdg = do - when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic - let term = hi_name hi - ext - <- destructMatches - use_field_puns - f - (Just term) - (hi_type hi) - $ disallowing AlreadyDestructed (S.singleton term) jdg - pure $ ext - & #syn_trace %~ rose ("destruct " <> show term) . pure - & #syn_val %~ noLoc . case' (var' term) - - ------------------------------------------------------------------------------- --- | Combinator for performing case splitting, and running sub-rules on the --- resulting matches. -destructLambdaCase' :: Bool -> (ConLike -> Judgement -> Rule) -> Judgement -> Rule -destructLambdaCase' use_field_puns f jdg = do - when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic - let g = jGoal jdg - case splitFunTy_maybe (unCType g) of -#if __GLASGOW_HASKELL__ >= 900 - Just (_multiplicity, arg, _) | isAlgType arg -> -#else - Just (arg, _) | isAlgType arg -> -#endif - fmap (fmap noLoc lambdaCase) <$> - destructMatches use_field_puns f Nothing (CType arg) jdg - _ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g - - ------------------------------------------------------------------------------- --- | Construct a data con with subgoals for each field. -buildDataCon - :: Bool -- Should we blacklist destruct? - -> Judgement - -> ConLike -- ^ The data con to build - -> [Type] -- ^ Type arguments for the data con - -> RuleM (Synthesized (LHsExpr GhcPs)) -buildDataCon should_blacklist jdg dc tyapps = do - args <- case dc of - RealDataCon dc' -> do - let (skolems', theta, args) = dataConInstSig dc' tyapps - modify $ \ts -> - evidenceToSubst (foldMap mkEvidence theta) ts - & #ts_skolems <>~ S.fromList skolems' - pure args - _ -> - -- If we have a 'PatSyn', we can't continue, since there is no - -- 'dataConInstSig' equivalent for 'PatSyn's. I don't think this is - -- a fundamental problem, but I don't know enough about the GHC internals - -- to implement it myself. - -- - -- Fortunately, this isn't an issue in practice, since 'PatSyn's are - -- never in the hypothesis. - cut -- throwError $ TacticPanic "Can't build Pattern constructors yet" - ext - <- fmap unzipTrace - $ traverse ( \(arg, n) -> - newSubgoal - . filterSameTypeFromOtherPositions dc n - . bool id blacklistingDestruct should_blacklist - . flip withNewGoal jdg - $ CType arg - ) $ zip args [0..] - pure $ ext - & #syn_trace %~ rose (show dc) . pure - & #syn_val %~ mkCon dc tyapps - - ------------------------------------------------------------------------------- --- | Make a function application, correctly handling the infix case. -mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs -mkApply occ (lhs : rhs : more) - | isSymOcc occ - = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more -mkApply occ args = noLoc $ foldl' (@@) (var' occ) args - - ------------------------------------------------------------------------------- --- | Run a tactic over each term in the given 'Hypothesis', binding the results --- of each in a let expression. -letForEach - :: (OccName -> OccName) -- ^ How to name bound variables - -> (HyInfo CType -> TacticsM ()) -- ^ The tactic to run - -> Hypothesis CType -- ^ Terms to generate bindings for - -> Judgement -- ^ The goal of original hole - -> RuleM (Synthesized (LHsExpr GhcPs)) -letForEach rename solve (unHypothesis -> hy) jdg = do - case hy of - [] -> newSubgoal jdg - _ -> do - ctx <- ask - let g = jGoal jdg - terms <- fmap sequenceA $ for hy $ \hi -> do - let name = rename $ hi_name hi - let generalized_let_ty = CType alphaTy - res <- tacticToRule (withNewGoal generalized_let_ty jdg) $ solve hi - pure $ fmap ((name,) . unLoc) res - let hy' = fmap (g <$) $ syn_val terms - matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms - g <- fmap (fmap unLoc) $ newSubgoal $ introduce ctx (userHypothesis hy') jdg - pure $ fmap noLoc $ let' <$> matches <*> g - - ------------------------------------------------------------------------------- --- | Let-bind the given occname judgement pairs. -nonrecLet - :: [(OccName, Judgement)] - -> Judgement - -> RuleM (Synthesized (LHsExpr GhcPs)) -nonrecLet occjdgs jdg = do - occexts <- traverse newSubgoal $ fmap snd occjdgs - ctx <- ask - ext <- newSubgoal - $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs) jdg - pure $ fmap noLoc $ - let' - <$> traverse - (\(occ, ext) -> valBind (occNameToStr occ) <$> fmap unLoc ext) - (zip (fmap fst occjdgs) occexts) - <*> fmap unLoc ext - - ------------------------------------------------------------------------------- --- | Converts a function application into applicative form -idiomize :: LHsExpr GhcPs -> LHsExpr GhcPs -idiomize x = noLoc $ case unLoc x of - HsApp _ (L _ (HsVar _ (L _ x))) gshgp3 -> - op (bvar' $ occName x) "<$>" (unLoc gshgp3) - HsApp _ gsigp gshgp3 -> - op (unLoc $ idiomize gsigp) "<*>" (unLoc gshgp3) - RecordCon _ con flds -> - unLoc $ idiomize $ noLoc $ foldl' (@@) (HsVar noExtField con) $ fmap unLoc flds - y -> y - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen/Utils.hs deleted file mode 100644 index d683db9ffd..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/CodeGen/Utils.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Wingman.CodeGen.Utils where - -import Data.String -import Data.List -import Development.IDE.GHC.Compat -import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string) -import GHC.SourceGen.Overloaded as SourceGen -import Wingman.GHC (getRecordFields) - - ------------------------------------------------------------------------------- --- | Make a data constructor with the given arguments. -mkCon :: ConLike -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs -mkCon con apps (fmap unLoc -> args) - | RealDataCon dcon <- con - , dcon == nilDataCon - , [ty] <- apps - , ty `eqType` charTy = noLoc $ string "" - - | RealDataCon dcon <- con - , isTupleDataCon dcon = - noLoc $ tuple args - - | RealDataCon dcon <- con - , dataConIsInfix dcon - , (lhs : rhs : args') <- args = - noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args' - - | Just fields <- getRecordFields con - , length fields >= 2 = -- record notation is unnatural on single field ctors - noLoc $ recordConE (coerceName con_name) $ do - (arg, (field, _)) <- zip args fields - pure (coerceName field, arg) - - | otherwise = - noLoc $ foldl' (@@) (bvar' $ occName con_name) args - where - con_name = conLikeName con - - -coerceName :: HasOccName a => a -> RdrNameStr -coerceName = UnqualStr . fromString . occNameString . occName - - ------------------------------------------------------------------------------- --- | Like 'var', but works over standard GHC 'OccName's. -var' :: SourceGen.Var a => OccName -> a -var' = var . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Like 'bvar', but works over standard GHC 'OccName's. -bvar' :: BVar a => OccName -> a -bvar' = bvar . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a function name. -mkFunc :: String -> HsExpr GhcPs -mkFunc = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a value name. -mkVal :: String -> HsExpr GhcPs -mkVal = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Like 'op', but easier to call. -infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -infixCall s = flip op (fromString s) - - ------------------------------------------------------------------------------- --- | Like '(@@)', but uses a dollar instead of parentheses. -appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -appDollar = infixCall "$" - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Context.hs deleted file mode 100644 index 3c1b40ba1f..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Context.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.Context where - -import Control.Arrow -import Control.Monad.Reader -import Data.Coerce (coerce) -import Data.Foldable.Extra (allM) -import Data.Maybe (fromMaybe, isJust, mapMaybe) -import qualified Data.Set as S -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import Wingman.GHC (normalizeType) -import Wingman.Judgements.Theta -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - -mkContext - :: Config - -> [(OccName, CType)] - -> TcGblEnv - -> HscEnv - -> ExternalPackageState - -> [Evidence] - -> Context -mkContext cfg locals tcg hscenv eps ev = fix $ \ctx -> - Context - { ctxDefiningFuncs - = fmap (second $ coerce $ normalizeType ctx) locals - , ctxModuleFuncs - = fmap (second (coerce $ normalizeType ctx) . splitId) - . mappend (locallyDefinedMethods tcg) - . (getFunBindId =<<) - . fmap unLoc - . bagToList - $ tcg_binds tcg - , ctxConfig = cfg - , ctxFamInstEnvs = - (eps_fam_inst_env eps, tcg_fam_inst_env tcg) - , ctxInstEnvs = - InstEnvs - (eps_inst_env eps) - (tcg_inst_env tcg) - (tcVisibleOrphanMods tcg) - , ctxTheta = evidenceToThetaType ev - , ctx_hscEnv = hscenv - , ctx_occEnv = tcg_rdr_env tcg - , ctx_module = extractModule tcg - } - - -locallyDefinedMethods :: TcGblEnv -> [Id] -locallyDefinedMethods - = foldMap classMethods - . mapMaybe tyConClass_maybe - . tcg_tcs - - - -splitId :: Id -> (OccName, CType) -splitId = occName &&& CType . idType - - -getFunBindId :: HsBindLR GhcTc GhcTc -> [Id] -getFunBindId (AbsBinds _ _ _ abes _ _ _) - = abes >>= \case - ABE _ poly _ _ _ -> pure poly - _ -> [] -getFunBindId _ = [] - - ------------------------------------------------------------------------------- --- | Determine if there is an instance that exists for the given 'Class' at the --- specified types. Deeply checks contexts to ensure the instance is actually --- real. --- --- If so, this returns a 'PredType' that corresponds to the type of the --- dictionary. -getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType)) -getInstance cls tys = do - env <- asks ctxInstEnvs - let (mres, _, _) = lookupInstEnv False env cls tys - case mres of - ((inst, mapps) : _) -> do - -- Get the instantiated type of the dictionary - let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps - -- pull off its resulting arguments - let (theta, df') = tcSplitPhiTy df - allM hasClassInstance theta >>= \case - True -> pure $ Just (cls, df') - False -> pure Nothing - _ -> pure Nothing - - ------------------------------------------------------------------------------- --- | Like 'getInstance', but only returns whether or not it succeeded. Can fail --- fast, and uses a cached Theta from the context. -hasClassInstance :: MonadReader Context m => PredType -> m Bool -hasClassInstance predty = do - theta <- asks ctxTheta - case S.member (CType predty) theta of - True -> pure True - False -> do - let (con, apps) = tcSplitTyConApp predty - case tyConClass_maybe con of - Nothing -> pure False - Just cls -> fmap isJust $ getInstance cls apps - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Debug.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Debug.hs deleted file mode 100644 index e637779824..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Debug.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -module Wingman.Debug - ( unsafeRender - , unsafeRender' - , traceM - , traceShowId - , trace - , traceX - , traceIdX - , traceMX - , traceFX - ) where - -import Control.DeepSeq -import Control.Exception -import Data.Either (fromRight) -import qualified Data.Text as T -import qualified Debug.Trace -import Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc) -import Development.IDE.GHC.Util (printOutputable) -import System.IO.Unsafe (unsafePerformIO) - ------------------------------------------------------------------------------- --- | Print something -unsafeRender :: Outputable a => a -> String -unsafeRender = unsafeRender' . ppr - - -unsafeRender' :: SDoc -> String -unsafeRender' sdoc = unsafePerformIO $ do - let z = T.unpack $ printOutputable sdoc - -- We might not have unsafeGlobalDynFlags (like during testing), in which - -- case GHC panics. Instead of crashing, let's just fail to print. - !res <- try @PlainGhcException $ evaluate $ deepseq z z - pure $ fromRight "" res -{-# NOINLINE unsafeRender' #-} - -traceMX :: (Monad m, Show a) => String -> a -> m () -traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a - -traceX :: (Show a) => String -> a -> b -> b -traceX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) - -traceIdX :: (Show a) => String -> a -> a -traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a - -traceFX :: String -> (a -> String) -> a -> a -traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a - -traceM :: Applicative f => String -> f () -trace :: String -> a -> a -traceShowId :: Show a => a -> a -#ifdef DEBUG -traceM = Debug.Trace.traceM -trace = Debug.Trace.trace -traceShowId = Debug.Trace.traceShowId -#else -traceM _ = pure () -trace _ = id -traceShowId = id -#endif diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs deleted file mode 100644 index 6c49e8d702..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.EmptyCase where - -import Control.Applicative (empty) -import Control.Lens -import Control.Monad -import Control.Monad.Except (runExcept) -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Data.Generics.Aliases (mkQ, GenericQ) -import Data.Generics.Schemes (everything) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import Data.Traversable -import Development.IDE (hscEnv, realSrcSpanToRange) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty, EmptyCase) -import Development.IDE.GHC.ExactPrint -import Development.IDE.Spans.LocalBindings (getLocalScope) -import Ide.Types -import Language.LSP.Server -import Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Types -import Prelude hiding (span) -import Wingman.AbstractLSP.Types -import Wingman.CodeGen (destructionFor) -import Wingman.GHC -import Wingman.Judgements -import Wingman.LanguageServer -import Wingman.Types - - -data EmptyCaseT = EmptyCaseT - -instance IsContinuationSort EmptyCaseT where - toCommandId _ = CommandId "wingman.emptyCase" - -instance IsTarget EmptyCaseT where - type TargetArgs EmptyCaseT = () - fetchTargetArgs _ = pure () - -emptyCaseInteraction :: Interaction -emptyCaseInteraction = Interaction $ - Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT - (SynthesizeCodeLens $ \LspEnv{..} _ -> do - let FileContext{..} = le_fileContext - nfp <- getNfp (fc_verTxtDocId ^. L.uri) - - let stale a = runStaleIde "codeLensProvider" le_ideState nfp a - - ccs <- lift getClientCapabilities - TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - TrackedStale binds bind_map <- mapMaybeT liftIO $ stale GetBindings - holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState nfp - - for holes $ \(ss, ty) -> do - binds_ss <- liftMaybe $ mapAgeFrom bind_map ss - let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss - range = realSrcSpanToRange $ unTrack ss - matches <- - liftMaybe $ - destructionFor - (foldMap (hySingleton . occName . fst) bindings) - ty - edits <- liftMaybe $ hush $ - mkWorkspaceEdits le_dflags ccs fc_verTxtDocId (unTrack pm) $ - graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ - noLoc matches - pure - ( range - , Metadata - (mkEmptyCaseLensDesc ty) - (CodeActionKind_Custom "refactor.wingman.completeEmptyCase") - False - , edits - ) - ) - (\ _ _ _ we -> pure $ pure $ RawEdit we) - - -scrutinzedType :: EmptyCaseSort Type -> Maybe Type -scrutinzedType (EmptyCase ty) = pure ty -scrutinzedType (EmptyLamCase ty) = - case tacticsSplitFunTy ty of - (_, _, tys, _) -> listToMaybe $ fmap scaledThing tys - - ------------------------------------------------------------------------------- --- | The description for the empty case lens. -mkEmptyCaseLensDesc :: Type -> T.Text -mkEmptyCaseLensDesc ty = - "Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")" - - ------------------------------------------------------------------------------- --- | Silence an error. -hush :: Either e a -> Maybe a -hush (Left _) = Nothing -hush (Right a) = Just a - - ------------------------------------------------------------------------------- --- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly --- deals with top-level holes, in which we might need to fiddle with the --- 'Match's that bind variables. -graftMatchGroup - :: SrcSpan - -> Located [LMatch GhcPs (LHsExpr GhcPs)] - -> Graft (Either String) ParsedSource -graftMatchGroup ss l = - hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case - L span (HsCase ext scrut mg) -> do - pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l } - L span (HsLamCase ext mg) -> do - pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l } - (_ :: LHsExpr GhcPs) -> pure Nothing - - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT - - ------------------------------------------------------------------------------- --- | Find the last typechecked module, and find the most specific span, as well --- as the judgement at the given range. -emptyCaseScrutinees - :: IdeState - -> NormalizedFilePath - -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)] -emptyCaseScrutinees state nfp = do - let stale a = runStaleIde "emptyCaseScrutinees" state nfp a - - TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck - let tcg' = unTrack tcg - hscenv <- stale GhcSessionDeps - - let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg - fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do - ty <- MaybeT - . fmap (scrutinzedType <=< sequence) - . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg') - $ scrutinee - case null $ tacticsGetDataCons ty of - True -> pure empty - False -> - case ss of - RealSrcSpan r _ -> do - rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r - pure $ Just (rss', ty) - UnhelpfulSpan _ -> empty - -data EmptyCaseSort a - = EmptyCase a - | EmptyLamCase a - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - ------------------------------------------------------------------------------- --- | Get the 'SrcSpan' and scrutinee of every empty case. -emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))] -emptyCaseQ = everything (<>) $ mkQ mempty $ \case - L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee) - L new_span expr@(LamCase []) -> pure (new_span, EmptyLamCase expr) - (_ :: LHsExpr GhcTc) -> mempty - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/old/src/Wingman/GHC.hs deleted file mode 100644 index 13562a6ef8..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/GHC.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.GHC where - -import Control.Monad.State -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Data.Bool (bool) -import Data.Coerce (coerce) -import Data.Function (on) -import Data.Functor ((<&>)) -import Data.List (isPrefixOf) -import qualified Data.Map as M -import Data.Maybe (isJust) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import GHC.SourceGen (lambda) -import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) -import Wingman.StaticPlugin (pattern MetaprogramSyntax) -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - -tcTyVar_maybe :: Type -> Maybe Var -tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty' -tcTyVar_maybe (CastTy ty _) = tcTyVar_maybe ty -- look through casts, as - -- this is only used for - -- e.g., FlexibleContexts -tcTyVar_maybe (TyVarTy v) = Just v -tcTyVar_maybe _ = Nothing - - -instantiateType :: Type -> ([TyVar], Type) -instantiateType t = do - let vs = tyCoVarsOfTypeList t - vs' = fmap cloneTyVar vs - subst = foldr (\(v,t) a -> extendTCvSubst a v $ TyVarTy t) emptyTCvSubst - $ zip vs vs' - in (vs', substTy subst t) - - -cloneTyVar :: TyVar -> TyVar -cloneTyVar t = - let uniq = getUnique t - some_magic_char = 'w' -- 'w' for wingman ;D - in setVarUnique t $ newTagUnique uniq some_magic_char - - ------------------------------------------------------------------------------- --- | Is this a function type? -isFunction :: Type -> Bool -isFunction (tacticsSplitFunTy -> (_, _, [], _)) = False -isFunction _ = True - - ------------------------------------------------------------------------------- --- | Split a function, also splitting out its quantified variables and theta --- context. -tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type) -tacticsSplitFunTy t - = let (vars, theta, t') = tcSplitNestedSigmaTys t - (args, res) = tcSplitFunTys t' - in (vars, theta, args, res) - - ------------------------------------------------------------------------------- --- | Rip the theta context out of a regular type. -tacticsThetaTy :: Type -> ThetaType -tacticsThetaTy (tcSplitSigmaTy -> (_, theta, _)) = theta - - ------------------------------------------------------------------------------- --- | Get the data cons of a type, if it has any. -tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type]) -tacticsGetDataCons ty - | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty - = tacticsGetDataCons ty' -tacticsGetDataCons ty - | Just _ <- algebraicTyCon ty - = splitTyConApp_maybe ty <&> \(tc, apps) -> - ( filter (not . dataConCannotMatch apps) $ tyConDataCons tc - , apps - ) -tacticsGetDataCons _ = Nothing - ------------------------------------------------------------------------------- --- | Instantiate all of the quantified type variables in a type with fresh --- skolems. -freshTyvars :: MonadState TacticState m => Type -> m Type -freshTyvars t = do - let (tvs, _, _, _) = tacticsSplitFunTy t - reps <- fmap M.fromList - $ for tvs $ \tv -> do - uniq <- freshUnique - pure (tv, setTyVarUnique tv uniq) - pure $ - everywhere - (mkT $ \tv -> M.findWithDefault tv tv reps - ) $ snd $ tcSplitForAllTyVars t - - ------------------------------------------------------------------------------- --- | Given a datacon, extract its record fields' names and types. Returns --- nothing if the datacon is not a record. -getRecordFields :: ConLike -> Maybe [(OccName, CType)] -getRecordFields dc = - case conLikeFieldLabels dc of - [] -> Nothing - lbls -> for lbls $ \lbl -> do - let ty = conLikeFieldType dc $ flLabel lbl - pure (mkVarOccFS $ flLabel lbl, CType ty) - - ------------------------------------------------------------------------------- --- | Is this an algebraic type? -algebraicTyCon :: Type -> Maybe TyCon -algebraicTyCon ty - | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty - = algebraicTyCon ty' -algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _)) - | tycon == intTyCon = Nothing - | tycon == floatTyCon = Nothing - | tycon == doubleTyCon = Nothing - | tycon == charTyCon = Nothing - | tycon == funTyCon = Nothing - | otherwise = Just tycon -algebraicTyCon _ = Nothing - - ------------------------------------------------------------------------------- --- | We can't compare 'RdrName' for equality directly. Instead, sloppily --- compare them by their 'OccName's. -eqRdrName :: RdrName -> RdrName -> Bool -eqRdrName = (==) `on` occNameString . occName - - ------------------------------------------------------------------------------- --- | Compare two 'OccName's for unqualified equality. -sloppyEqOccName :: OccName -> OccName -> Bool -sloppyEqOccName = (==) `on` occNameString - - ------------------------------------------------------------------------------- --- | Does this thing contain any references to 'HsVar's with the given --- 'RdrName'? -containsHsVar :: Data a => RdrName -> a -> Bool -containsHsVar name x = not $ null $ listify ( - \case - ((HsVar _ (L _ a)) :: HsExpr GhcPs) | eqRdrName a name -> True - _ -> False - ) x - - ------------------------------------------------------------------------------- --- | Does this thing contain any holes? -containsHole :: Data a => a -> Bool -containsHole x = not $ null $ listify ( - \case - ((HsVar _ (L _ name)) :: HsExpr GhcPs) -> isHole $ occName name - MetaprogramSyntax _ -> True - _ -> False - ) x - - ------------------------------------------------------------------------------- --- | Check if an 'OccName' is a hole -isHole :: OccName -> Bool --- TODO(sandy): Make this more robust -isHole = isPrefixOf "_" . occNameString - - ------------------------------------------------------------------------------- --- | Get all of the referenced occnames. -allOccNames :: Data a => a -> Set OccName -allOccNames = everything (<>) $ mkQ mempty $ \case - a -> S.singleton a - - ------------------------------------------------------------------------------- --- | Unpack the relevant parts of a 'Match' -#if __GLASGOW_HASKELL__ >= 900 -pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) -#else -pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) -#endif -pattern AMatch ctx pats body <- - Match { m_ctxt = ctx - , m_pats = fmap fromPatCompat -> pats - , m_grhss = UnguardedRHSs (unLoc -> body) - } - - -pattern SingleLet :: IdP GhcPs -> [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -pattern SingleLet bind pats val expr <- - HsLet _ - (HsValBinds _ - (ValBinds _ (bagToList -> - [L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _)) - (L _ expr) - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -pattern Lambda pats body <- - HsLam _ - MG {mg_alts = L _ [L _ (AMatch _ pats body) ]} - where - -- If there are no patterns to bind, just stick in the body - Lambda [] body = body - Lambda pats body = lambda pats body - - ------------------------------------------------------------------------------- --- | A GRHS that contains no guards. -pattern UnguardedRHSs :: LHsExpr p -> GRHSs p (LHsExpr p) -pattern UnguardedRHSs body <- - GRHSs {grhssGRHSs = [L _ (GRHS _ [] body)]} - - ------------------------------------------------------------------------------- --- | A match with a single pattern. Case matches are always 'SinglePatMatch'es. -pattern SinglePatMatch :: PatCompattable p => Pat p -> LHsExpr p -> Match p (LHsExpr p) -pattern SinglePatMatch pat body <- - Match { m_pats = [fromPatCompat -> pat] - , m_grhss = UnguardedRHSs body - } - - ------------------------------------------------------------------------------- --- | Helper function for defining the 'Case' pattern. -unpackMatches :: PatCompattable p => [Match p (LHsExpr p)] -> Maybe [(Pat p, LHsExpr p)] -unpackMatches [] = Just [] -unpackMatches (SinglePatMatch pat body : matches) = - ((pat, body):) <$> unpackMatches matches -unpackMatches _ = Nothing - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Case :: PatCompattable p => HsExpr p -> [(Pat p, LHsExpr p)] -> HsExpr p -pattern Case scrutinee matches <- - HsCase _ (L _ scrutinee) - MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)} - ------------------------------------------------------------------------------- --- | Like 'Case', but for lambda cases. -pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p -pattern LamCase matches <- - HsLamCase _ - MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)} - - ------------------------------------------------------------------------------- --- | Can ths type be lambda-cased? --- --- Return: 'Nothing' if no --- @Just False@ if it can't be homomorphic --- @Just True@ if it can -lambdaCaseable :: Type -> Maybe Bool -#if __GLASGOW_HASKELL__ >= 900 -lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res)) -#else -lambdaCaseable (splitFunTy_maybe -> Just (arg, res)) -#endif - | isJust (algebraicTyCon arg) - = Just $ isJust $ algebraicTyCon res -lambdaCaseable _ = Nothing - -class PatCompattable p where - fromPatCompat :: PatCompat p -> Pat p - toPatCompat :: Pat p -> PatCompat p - -instance PatCompattable GhcTc where - fromPatCompat = unLoc - toPatCompat = noLoc - -instance PatCompattable GhcPs where - fromPatCompat = unLoc - toPatCompat = noLoc - -type PatCompat pass = LPat pass - ------------------------------------------------------------------------------- --- | Should make sure it's a fun bind -pattern TopLevelRHS - :: OccName - -> [PatCompat GhcTc] - -> LHsExpr GhcTc - -> HsLocalBindsLR GhcTc GhcTc - -> Match GhcTc (LHsExpr GhcTc) -pattern TopLevelRHS name ps body where_binds <- - Match _ - (FunRhs (L _ (occName -> name)) _ _) - ps - (GRHSs _ - [L _ (GRHS _ [] body)] (L _ where_binds)) - -liftMaybe :: Monad m => Maybe a -> MaybeT m a -liftMaybe a = MaybeT $ pure a - - ------------------------------------------------------------------------------- --- | Get the type of an @HsExpr GhcTc@. This is slow and you should prefer to --- not use it, but sometimes it can't be helped. -typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type) -typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr - ------------------------------------------------------------------------------- --- | Expand type and data families -normalizeType :: Context -> Type -> Type -normalizeType ctx ty = - let ty' = expandTyFam ctx ty - in case tcSplitTyConApp_maybe ty' of - Just (tc, tys) -> - -- try to expand any data families - case tcLookupDataFamInst_maybe (ctxFamInstEnvs ctx) tc tys of - Just (dtc, dtys, _) -> mkAppTys (mkTyConTy dtc) dtys - Nothing -> ty' - Nothing -> ty' - ------------------------------------------------------------------------------- --- | Expand type families -expandTyFam :: Context -> Type -> Type -expandTyFam ctx = snd . normaliseType (ctxFamInstEnvs ctx) Nominal - - ------------------------------------------------------------------------------- --- | Like 'tcUnifyTy', but takes a list of skolems to prevent unification of. -tryUnifyUnivarsButNotSkolems :: Set TyVar -> CType -> CType -> Maybe TCvSubst -tryUnifyUnivarsButNotSkolems skolems goal inst = - tryUnifyUnivarsButNotSkolemsMany skolems $ coerce [(goal, inst)] - ------------------------------------------------------------------------------- --- | Like 'tryUnifyUnivarsButNotSkolems', but takes a list --- of pairs of types to unify. -tryUnifyUnivarsButNotSkolemsMany :: Set TyVar -> [(Type, Type)] -> Maybe TCvSubst -tryUnifyUnivarsButNotSkolemsMany skolems (unzip -> (goal, inst)) = - tcUnifyTys - (bool BindMe Skolem . flip S.member skolems) - inst - goal - - -updateSubst :: TCvSubst -> TacticState -> TacticState -updateSubst subst s = s { ts_unifier = unionTCvSubst subst (ts_unifier s) } - - ------------------------------------------------------------------------------- --- | Get the class methods of a 'PredType', correctly dealing with --- instantiation of quantified class types. -methodHypothesis :: PredType -> Maybe [HyInfo CType] -methodHypothesis ty = do - (tc, apps) <- splitTyConApp_maybe ty - cls <- tyConClass_maybe tc - let methods = classMethods cls - tvs = classTyVars cls - subst = zipTvSubst tvs apps - pure $ methods <&> \method -> - let (_, _, ty) = tcSplitSigmaTy $ idType method - in ( HyInfo (occName method) (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty - ) - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Judgements.hs deleted file mode 100644 index 0ff03e60ee..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements.hs +++ /dev/null @@ -1,474 +0,0 @@ -module Wingman.Judgements where - -import Control.Arrow -import Control.Lens hiding (Context) -import Data.Bool -import Data.Char -import Data.Coerce -import Data.Generics.Product (field) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.Core.UseStale (Tracked, unTrack) -import Development.IDE.GHC.Compat hiding (isTopLevel) -import Development.IDE.Spans.LocalBindings -import Wingman.GHC (algebraicTyCon, normalizeType) -import Wingman.Judgements.Theta -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis. -hypothesisFromBindings :: Tracked age RealSrcSpan -> Tracked age Bindings -> Hypothesis CType -hypothesisFromBindings (unTrack -> span) (unTrack -> bs) = buildHypothesis $ getLocalScope bs span - - ------------------------------------------------------------------------------- --- | Convert a @Set Id@ into a hypothesis. -buildHypothesis :: [(Name, Maybe Type)] -> Hypothesis CType -buildHypothesis - = Hypothesis - . mapMaybe go - where - go (occName -> occ, t) - | Just ty <- t - , (h:_) <- occNameString occ - , isAlpha h = Just $ HyInfo occ UserPrv $ CType ty - | otherwise = Nothing - - ------------------------------------------------------------------------------- --- | Build a trivial hypothesis containing only a single name. The corresponding --- HyInfo has no provenance or type. -hySingleton :: OccName -> Hypothesis () -hySingleton n = Hypothesis . pure $ HyInfo n UserPrv () - - -blacklistingDestruct :: Judgement -> Judgement -blacklistingDestruct = - field @"_jBlacklistDestruct" .~ True - - -unwhitelistingSplit :: Judgement -> Judgement -unwhitelistingSplit = - field @"_jWhitelistSplit" .~ False - - -isDestructBlacklisted :: Judgement -> Bool -isDestructBlacklisted = _jBlacklistDestruct - - -isSplitWhitelisted :: Judgement -> Bool -isSplitWhitelisted = _jWhitelistSplit - - -withNewGoal :: a -> Judgement' a -> Judgement' a -withNewGoal t = field @"_jGoal" .~ t - ------------------------------------------------------------------------------- --- | Like 'withNewGoal' but allows you to modify the goal rather than replacing --- it. -withModifiedGoal :: (a -> a) -> Judgement' a -> Judgement' a -withModifiedGoal f = field @"_jGoal" %~ f - - ------------------------------------------------------------------------------- --- | Add some new type equalities to the local judgement. -withNewCoercions :: [(CType, CType)] -> Judgement -> Judgement -withNewCoercions ev j = - let subst = allEvidenceToSubst mempty $ coerce ev - in fmap (CType . substTyAddInScope subst . unCType) j - & field @"j_coercion" %~ unionTCvSubst subst - - -normalizeHypothesis :: Functor f => Context -> f CType -> f CType -normalizeHypothesis = fmap . coerce . normalizeType - -normalizeJudgement :: Functor f => Context -> f CType -> f CType -normalizeJudgement = normalizeHypothesis - - -introduce :: Context -> Hypothesis CType -> Judgement' CType -> Judgement' CType --- NOTE(sandy): It's important that we put the new hypothesis terms first, --- since 'jAcceptableDestructTargets' will never destruct a pattern that occurs --- after a previously-destructed term. -introduce ctx hy = - field @"_jHypothesis" %~ mappend (normalizeHypothesis ctx hy) - - ------------------------------------------------------------------------------- --- | Helper function for implementing functions which introduce new hypotheses. -introduceHypothesis - :: (Int -> Int -> Provenance) - -- ^ A function from the total number of args and position of this arg - -- to its provenance. - -> [(OccName, a)] - -> Hypothesis a -introduceHypothesis f ns = - Hypothesis $ zip [0..] ns <&> \(pos, (name, ty)) -> - HyInfo name (f (length ns) pos) ty - - ------------------------------------------------------------------------------- --- | Introduce bindings in the context of a lambda. -lambdaHypothesis - :: Maybe OccName -- ^ The name of the top level function. For any other - -- function, this should be 'Nothing'. - -> [(OccName, a)] - -> Hypothesis a -lambdaHypothesis func = - introduceHypothesis $ \count pos -> - maybe UserPrv (\x -> TopLevelArgPrv x pos count) func - - ------------------------------------------------------------------------------- --- | Introduce a binding in a recursive context. -recursiveHypothesis :: [(OccName, a)] -> Hypothesis a -recursiveHypothesis = introduceHypothesis $ const $ const RecursivePrv - - ------------------------------------------------------------------------------- --- | Introduce a binding in a recursive context. -userHypothesis :: [(OccName, a)] -> Hypothesis a -userHypothesis = introduceHypothesis $ const $ const UserPrv - - ------------------------------------------------------------------------------- --- | Check whether any of the given occnames are an ancestor of the term. -hasPositionalAncestry - :: Foldable t - => t OccName -- ^ Desired ancestors. - -> Judgement - -> OccName -- ^ Potential child - -> Maybe Bool -- ^ Just True if the result is the oldest positional ancestor - -- just false if it's a descendent - -- otherwise nothing -hasPositionalAncestry ancestors jdg name - | not $ null ancestors - = case name `elem` ancestors of - True -> Just True - False -> - case M.lookup name $ jAncestryMap jdg of - Just ancestry -> - bool Nothing (Just False) $ any (flip S.member ancestry) ancestors - Nothing -> Nothing - | otherwise = Nothing - - ------------------------------------------------------------------------------- --- | Helper function for disallowing hypotheses that have the wrong ancestry. -filterAncestry - :: Foldable t - => t OccName - -> DisallowReason - -> Judgement - -> Judgement -filterAncestry ancestry reason jdg = - disallowing reason (M.keysSet $ M.filterWithKey go $ hyByName $ jHypothesis jdg) jdg - where - go name _ - = isNothing - $ hasPositionalAncestry ancestry jdg name - - ------------------------------------------------------------------------------- --- | @filter defn pos@ removes any hypotheses which are bound in @defn@ to --- a position other than @pos@. Any terms whose ancestry doesn't include @defn@ --- remain. -filterPosition :: OccName -> Int -> Judgement -> Judgement -filterPosition defn pos jdg = - filterAncestry (findPositionVal jdg defn pos) (WrongBranch pos) jdg - - ------------------------------------------------------------------------------- --- | Helper function for determining the ancestry list for 'filterPosition'. -findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName -findPositionVal jdg defn pos = listToMaybe $ do - -- It's important to inspect the entire hypothesis here, as we need to trace - -- ancestry through potentially disallowed terms in the hypothesis. - (name, hi) <- M.toList - $ M.map (overProvenance expandDisallowed) - $ hyByName - $ jEntireHypothesis jdg - case hi_provenance hi of - TopLevelArgPrv defn' pos' _ - | defn == defn' - , pos == pos' -> pure name - PatternMatchPrv pv - | pv_scrutinee pv == Just defn - , pv_position pv == pos -> pure name - _ -> [] - - ------------------------------------------------------------------------------- --- | Helper function for determining the ancestry list for --- 'filterSameTypeFromOtherPositions'. -findDconPositionVals :: Judgement' a -> ConLike -> Int -> [OccName] -findDconPositionVals jdg dcon pos = do - (name, hi) <- M.toList $ hyByName $ jHypothesis jdg - case hi_provenance hi of - PatternMatchPrv pv - | pv_datacon pv == Uniquely dcon - , pv_position pv == pos -> pure name - _ -> [] - - ------------------------------------------------------------------------------- --- | Disallow any hypotheses who have the same type as anything bound by the --- given position for the datacon. Used to ensure recursive functions like --- 'fmap' preserve the relative ordering of their arguments by eliminating any --- other term which might match. -filterSameTypeFromOtherPositions :: ConLike -> Int -> Judgement -> Judgement -filterSameTypeFromOtherPositions dcon pos jdg = - let hy = hyByName - . jHypothesis - $ filterAncestry - (findDconPositionVals jdg dcon pos) - (WrongBranch pos) - jdg - tys = S.fromList $ hi_type <$> M.elems hy - to_remove = - M.filter (flip S.member tys . hi_type) (hyByName $ jHypothesis jdg) - M.\\ hy - in disallowing Shadowed (M.keysSet to_remove) jdg - - ------------------------------------------------------------------------------- --- | Return the ancestry of a 'PatVal', or 'mempty' otherwise. -getAncestry :: Judgement' a -> OccName -> Set OccName -getAncestry jdg name = - maybe mempty pv_ancestry . M.lookup name $ jPatHypothesis jdg - - -jAncestryMap :: Judgement' a -> Map OccName (Set OccName) -jAncestryMap jdg = - M.map pv_ancestry (jPatHypothesis jdg) - - -provAncestryOf :: Provenance -> Set OccName -provAncestryOf (TopLevelArgPrv o _ _) = S.singleton o -provAncestryOf (PatternMatchPrv (PatVal mo so _ _)) = - maybe mempty S.singleton mo <> so -provAncestryOf (ClassMethodPrv _) = mempty -provAncestryOf UserPrv = mempty -provAncestryOf RecursivePrv = mempty -provAncestryOf ImportPrv = mempty -provAncestryOf (DisallowedPrv _ p2) = provAncestryOf p2 - - ------------------------------------------------------------------------------- --- TODO(sandy): THIS THING IS A BIG BIG HACK --- --- Why? 'ctxDefiningFuncs' is _all_ of the functions currently being defined --- (eg, we might be in a where block). The head of this list is not guaranteed --- to be the one we're interested in. -extremelyStupid__definingFunction :: Context -> OccName -extremelyStupid__definingFunction = - fst . head . ctxDefiningFuncs - - -patternHypothesis - :: Maybe OccName - -> ConLike - -> Judgement' a - -> [(OccName, a)] - -> Hypothesis a -patternHypothesis scrutinee dc jdg - = introduceHypothesis $ \_ pos -> - PatternMatchPrv $ - PatVal - scrutinee - (maybe - mempty - (\scrut -> S.singleton scrut <> getAncestry jdg scrut) - scrutinee) - (Uniquely dc) - pos - - ------------------------------------------------------------------------------- --- | Prevent some occnames from being used in the hypothesis. This will hide --- them from 'jHypothesis', but not from 'jEntireHypothesis'. -disallowing :: DisallowReason -> S.Set OccName -> Judgement' a -> Judgement' a -disallowing reason ns = - field @"_jHypothesis" %~ (\z -> Hypothesis . flip fmap (unHypothesis z) $ \hi -> - case S.member (hi_name hi) ns of - True -> overProvenance (DisallowedPrv reason) hi - False -> hi - ) - - ------------------------------------------------------------------------------- --- | The hypothesis, consisting of local terms and the ambient environment --- (imports and class methods.) Hides disallowed values. -jHypothesis :: Judgement' a -> Hypothesis a -jHypothesis - = Hypothesis - . filter (not . isDisallowed . hi_provenance) - . unHypothesis - . jEntireHypothesis - - ------------------------------------------------------------------------------- --- | The whole hypothesis, including things disallowed. -jEntireHypothesis :: Judgement' a -> Hypothesis a -jEntireHypothesis = _jHypothesis - - ------------------------------------------------------------------------------- --- | Just the local hypothesis. -jLocalHypothesis :: Judgement' a -> Hypothesis a -jLocalHypothesis - = Hypothesis - . filter (isLocalHypothesis . hi_provenance) - . unHypothesis - . jHypothesis - - ------------------------------------------------------------------------------- --- | Filter elements from the hypothesis -hyFilter :: (HyInfo a -> Bool) -> Hypothesis a -> Hypothesis a -hyFilter f = Hypothesis . filter f . unHypothesis - - ------------------------------------------------------------------------------- --- | Given a judgment, return the hypotheses that are acceptable to destruct. --- --- We use the ordering of the hypothesis for this purpose. Since new bindings --- are always inserted at the beginning, we can impose a canonical ordering on --- which order to try destructs by what order they are introduced --- stopping --- at the first one we've already destructed. -jAcceptableDestructTargets :: Judgement' CType -> [HyInfo CType] -jAcceptableDestructTargets - = filter (isJust . algebraicTyCon . unCType . hi_type) - . takeWhile (not . isAlreadyDestructed . hi_provenance) - . unHypothesis - . jEntireHypothesis - - ------------------------------------------------------------------------------- --- | If we're in a top hole, the name of the defining function. -isTopHole :: Context -> Judgement' a -> Maybe OccName -isTopHole ctx = - bool Nothing (Just $ extremelyStupid__definingFunction ctx) . _jIsTopHole - - -unsetIsTopHole :: Judgement' a -> Judgement' a -unsetIsTopHole = field @"_jIsTopHole" .~ False - - ------------------------------------------------------------------------------- --- | What names are currently in scope in the hypothesis? -hyNamesInScope :: Hypothesis a -> Set OccName -hyNamesInScope = M.keysSet . hyByName - - ------------------------------------------------------------------------------- --- | Are there any top-level function argument bindings in this judgement? -jHasBoundArgs :: Judgement' a -> Bool -jHasBoundArgs - = any (isTopLevel . hi_provenance) - . unHypothesis - . jLocalHypothesis - - -jNeedsToBindArgs :: Judgement' CType -> Bool -jNeedsToBindArgs = isFunTy . unCType . jGoal - - ------------------------------------------------------------------------------- --- | Fold a hypothesis into a single mapping from name to info. This --- unavoidably will cause duplicate names (things like methods) to shadow one --- another. -hyByName :: Hypothesis a -> Map OccName (HyInfo a) -hyByName - = M.fromList - . fmap (hi_name &&& id) - . unHypothesis - - ------------------------------------------------------------------------------- --- | Only the hypothesis members which are pattern vals -jPatHypothesis :: Judgement' a -> Map OccName PatVal -jPatHypothesis - = M.mapMaybe (getPatVal . hi_provenance) - . hyByName - . jHypothesis - - -getPatVal :: Provenance-> Maybe PatVal -getPatVal prov = - case prov of - PatternMatchPrv pv -> Just pv - _ -> Nothing - - -jGoal :: Judgement' a -> a -jGoal = _jGoal - - -substJdg :: TCvSubst -> Judgement -> Judgement -substJdg subst = fmap $ coerce . substTy subst . coerce - - -mkFirstJudgement - :: Context - -> Hypothesis CType - -> Bool -- ^ are we in the top level rhs hole? - -> Type - -> Judgement' CType -mkFirstJudgement ctx hy top goal = - normalizeJudgement ctx $ - Judgement - { _jHypothesis = hy - , _jBlacklistDestruct = False - , _jWhitelistSplit = True - , _jIsTopHole = top - , _jGoal = CType goal - , j_coercion = emptyTCvSubst - } - - ------------------------------------------------------------------------------- --- | Is this a top level function binding? -isTopLevel :: Provenance -> Bool -isTopLevel TopLevelArgPrv{} = True -isTopLevel _ = False - - ------------------------------------------------------------------------------- --- | Is this a local function argument, pattern match or user val? -isLocalHypothesis :: Provenance -> Bool -isLocalHypothesis UserPrv{} = True -isLocalHypothesis PatternMatchPrv{} = True -isLocalHypothesis TopLevelArgPrv{} = True -isLocalHypothesis _ = False - - ------------------------------------------------------------------------------- --- | Is this a pattern match? -isPatternMatch :: Provenance -> Bool -isPatternMatch PatternMatchPrv{} = True -isPatternMatch _ = False - - ------------------------------------------------------------------------------- --- | Was this term ever disallowed? -isDisallowed :: Provenance -> Bool -isDisallowed DisallowedPrv{} = True -isDisallowed _ = False - ------------------------------------------------------------------------------- --- | Has this term already been disallowed? -isAlreadyDestructed :: Provenance -> Bool -isAlreadyDestructed (DisallowedPrv AlreadyDestructed _) = True -isAlreadyDestructed _ = False - - ------------------------------------------------------------------------------- --- | Eliminates 'DisallowedPrv' provenances. -expandDisallowed :: Provenance -> Provenance -expandDisallowed (DisallowedPrv _ prv) = expandDisallowed prv -expandDisallowed prv = prv diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/SYB.hs deleted file mode 100644 index 8cd6130eb3..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/SYB.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} - --- | Custom SYB traversals -module Wingman.Judgements.SYB where - -import Data.Foldable (foldl') -import Data.Generics hiding (typeRep) -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util (unpackFS) -import GHC.Exts (Any) -import Type.Reflection -import Unsafe.Coerce (unsafeCoerce) -import Wingman.StaticPlugin (pattern WingmanMetaprogram) - - ------------------------------------------------------------------------------- --- | Like 'everything', but only looks inside 'Located' terms that contain the --- given 'SrcSpan'. -everythingContaining - :: forall r - . Monoid r - => SrcSpan - -> GenericQ r - -> GenericQ r -everythingContaining dst f = go - where - go :: GenericQ r - go x = - case genericIsSubspan dst x of - Just False -> mempty - _ -> foldl' (<>) (f x) (gmapQ go x) - - ------------------------------------------------------------------------------- --- | Helper function for implementing 'everythingWithin' --- --- NOTE(sandy): Subtly broken. In an ideal world, this function should return --- @Just False@ for nodes of /any type/ which do not contain the span. But if --- this functionality exists anywhere within the SYB machinery, I have yet to --- find it. -genericIsSubspan - :: SrcSpan - -> GenericQ (Maybe Bool) -genericIsSubspan dst = mkQ1 (L noSrcSpan ()) Nothing $ \case - L span _ -> Just $ dst `isSubspanOf` span - - ------------------------------------------------------------------------------- --- | Like 'mkQ', but allows for polymorphic instantiation of its specific case. --- This instantiation matches whenever the dynamic value has the same --- constructor as the proxy @f ()@ value. -mkQ1 :: forall a r f - . (Data a, Data (f ())) - => f () -- ^ Polymorphic constructor to match on - -> r -- ^ Default value - -> (forall b. f b -> r) -- ^ Polymorphic match - -> a - -> r -mkQ1 proxy r br a = - case l_con == a_con && sameTypeModuloLastApp @a @(f ()) of - -- We have proven that the two values share the same constructor, and - -- that they have the same type if you ignore the final application. - -- Therefore, it is safe to coerce @a@ to @f b@, since @br@ is universal - -- over @b@ and can't inspect it. - True -> br $ unsafeCoerce @_ @(f Any) a - False -> r - where - l_con = toConstr proxy - a_con = toConstr a - - ------------------------------------------------------------------------------- --- | Given @a ~ f1 a1@ and @b ~ f2 b2@, returns true if @f1 ~ f2@. -sameTypeModuloLastApp :: forall a b. (Typeable a, Typeable b) => Bool -sameTypeModuloLastApp = - let tyrep1 = typeRep @a - tyrep2 = typeRep @b - in case (tyrep1 , tyrep2) of - (App a _, App b _) -> - case eqTypeRep a b of - Just HRefl -> True - Nothing -> False - _ -> False - - -metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)] -metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case - L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program) - (_ :: LHsExpr GhcTc) -> mempty - - -metaprogramQ :: GenericQ [(SrcSpan, T.Text)] -metaprogramQ = everything (<>) $ mkQ mempty $ \case - L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program) - (_ :: LHsExpr GhcTc) -> mempty - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/Theta.hs deleted file mode 100644 index 25bf5a3a21..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Judgements/Theta.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -module Wingman.Judgements.Theta - ( Evidence - , getEvidenceAtHole - , mkEvidence - , evidenceToCoercions - , evidenceToSubst - , evidenceToHypothesis - , evidenceToThetaType - , allEvidenceToSubst - ) where - -import Control.Applicative (empty) -import Control.Lens (preview) -import Data.Coerce (coerce) -import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import Data.Generics.Sum (_Ctor) -import Data.Set (Set) -import qualified Data.Set as S -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Generics.SYB hiding (tyConName, empty, Generic) -import GHC.Generics -import Wingman.GHC -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - ------------------------------------------------------------------------------- --- | Something we've learned about the type environment. -data Evidence - -- | The two types are equal, via a @a ~ b@ relationship - = EqualityOfTypes Type Type - -- | We have an instance in scope - | HasInstance PredType - deriving (Show, Generic) - - ------------------------------------------------------------------------------- --- | Given a 'PredType', pull an 'Evidence' out of it. -mkEvidence :: PredType -> [Evidence] -mkEvidence (getEqualityTheta -> Just (a, b)) - = pure $ EqualityOfTypes a b -mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) = do - (_, apps) <- maybeToList $ splitTyConApp_maybe inst - let tvs = classTyVars cls - subst = zipTvSubst tvs apps - sc_ev <- traverse (mkEvidence . substTy subst) $ classSCTheta cls - HasInstance inst : sc_ev -mkEvidence _ = empty - - ------------------------------------------------------------------------------- --- | Build a set of 'PredType's from the evidence. -evidenceToThetaType :: [Evidence] -> Set CType -evidenceToThetaType evs = S.fromList $ do - HasInstance t <- evs - pure $ CType t - - ------------------------------------------------------------------------------- --- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'. -getEvidenceAtHole :: Tracked age SrcSpan -> Tracked age (LHsBinds GhcTc) -> [Evidence] -getEvidenceAtHole (unTrack -> dst) - = concatMap mkEvidence - . (everything (<>) $ - mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst) - . unTrack - - -mkSubst :: Set TyVar -> Type -> Type -> TCvSubst -mkSubst skolems a b = - let tyvars = S.fromList $ mapMaybe getTyVar_maybe [a, b] - -- If we can unify our skolems, at least one is no longer a skolem. - -- Removing them from this set ensures we can get a substitution between - -- the two. But it's okay to leave them in 'ts_skolems' in general, since - -- they won't exist after running this substitution. - skolems' = skolems S.\\ tyvars - in - case tryUnifyUnivarsButNotSkolems skolems' (CType a) (CType b) of - Just subst -> subst - Nothing -> emptyTCvSubst - - -substPair :: TCvSubst -> (Type, Type) -> (Type, Type) -substPair subst (ty, ty') = (substTy subst ty, substTy subst ty') - - ------------------------------------------------------------------------------- --- | Construct a substitution given a list of types that are equal to one --- another. This is more subtle than it seems, since there might be several --- equalities for the same type. We must be careful to push the accumulating --- substitution through each pair of types before adding their equalities. -allEvidenceToSubst :: Set TyVar -> [(Type, Type)] -> TCvSubst -allEvidenceToSubst _ [] = emptyTCvSubst -allEvidenceToSubst skolems ((a, b) : evs) = - let subst = mkSubst skolems a b - in unionTCvSubst subst - $ allEvidenceToSubst skolems - $ fmap (substPair subst) evs - ------------------------------------------------------------------------------- --- | Given some 'Evidence', get a list of which types are now equal. -evidenceToCoercions :: [Evidence] -> [(CType, CType)] -evidenceToCoercions = coerce . mapMaybe (preview $ _Ctor @"EqualityOfTypes") - ------------------------------------------------------------------------------- --- | Update our knowledge of which types are equal. -evidenceToSubst :: [Evidence] -> TacticState -> TacticState -evidenceToSubst evs ts = - updateSubst - (allEvidenceToSubst (ts_skolems ts) . coerce $ evidenceToCoercions evs) - ts - - ------------------------------------------------------------------------------- --- | Get all of the methods that are in scope from this piece of 'Evidence'. -evidenceToHypothesis :: Evidence -> Hypothesis CType -evidenceToHypothesis EqualityOfTypes{} = mempty -evidenceToHypothesis (HasInstance t) = - Hypothesis . excludeForbiddenMethods . fromMaybe [] $ methodHypothesis t - - ------------------------------------------------------------------------------- --- | Given @a ~ b@ or @a ~# b@, returns @Just (a, b)@, otherwise @Nothing@. -getEqualityTheta :: PredType -> Maybe (Type, Type) -getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k, a, b])) -#if __GLASGOW_HASKELL__ > 806 - | tc == eqTyCon -#else - | nameRdrName (tyConName tc) == eqTyCon_RDR -#endif - = Just (a, b) -getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k1, _k2, a, b])) - | tc == eqPrimTyCon = Just (a, b) -getEqualityTheta _ = Nothing - - ------------------------------------------------------------------------------- --- | Many operations are defined in typeclasses for performance reasons, rather --- than being a true part of the class. This function filters out those, in --- order to keep our hypothesis space small. -excludeForbiddenMethods :: [HyInfo a] -> [HyInfo a] -excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name) - where - forbiddenMethods :: Set OccName - forbiddenMethods = S.map mkVarOcc $ S.fromList - [ -- monadfail - "fail" - -- show - , "showsPrec", "showList" - -- functor - , "<$" - -- applicative - , "liftA2", "<*", "*>" - -- monad - , "return", ">>" - -- alternative - , "some", "many" - -- foldable - , "foldr1", "foldl1", "elem", "maximum", "minimum", "sum", "product" - -- traversable - , "sequenceA", "mapM", "sequence" - -- semigroup - , "sconcat", "stimes" - -- monoid - , "mconcat" - ] - - ------------------------------------------------------------------------------- --- | Extract evidence from 'AbsBinds' in scope. -absBinds :: SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -absBinds dst (L src (FunBind w _ _ _)) - | dst `isSubspanOf` src - = wrapper w -absBinds dst (L src (AbsBinds _ _ h _ _ z _)) -#else -absBinds dst (L src (AbsBinds _ _ h _ _ _ _)) -#endif - | dst `isSubspanOf` src - = fmap idType h -#if __GLASGOW_HASKELL__ >= 900 - <> foldMap (absBinds dst) z -#endif -absBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from 'HsWrapper's in scope -wrapperBinds :: SrcSpan -> LHsExpr GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _)))) -#else -wrapperBinds dst (L src (HsWrap _ h _)) -#endif - | dst `isSubspanOf` src - = wrapper h -wrapperBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from the 'ConPatOut's bound in this 'Match'. -matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType] -matchBinds dst (L src (Match _ _ pats _)) - | dst `isSubspanOf` src - = everything (<>) (mkQ mempty patBinds) pats -matchBinds _ _ = [] - - ------------------------------------------------------------------------------- --- | Extract evidence from a 'ConPatOut'. -patBinds :: Pat GhcTc -> [PredType] -#if __GLASGOW_HASKELL__ >= 900 -patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }}) -#else -patBinds (ConPatOut { pat_dicts = dicts }) -#endif - = fmap idType dicts -patBinds _ = [] - - ------------------------------------------------------------------------------- --- | Extract the types of the evidence bindings in scope. -wrapper :: HsWrapper -> [PredType] -wrapper (WpCompose h h2) = wrapper h <> wrapper h2 -wrapper (WpEvLam v) = [idType v] -wrapper _ = [] - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies.hs deleted file mode 100644 index e898358c49..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Wingman.KnownStrategies where - -import Data.Foldable (for_) -import Development.IDE.GHC.Compat.Core -import Refinery.Tactic -import Wingman.Judgements (jGoal) -import Wingman.KnownStrategies.QuickCheck (deriveArbitrary) -import Wingman.Machinery (tracing, getKnownInstance, getCurrentDefinitions) -import Wingman.Tactics -import Wingman.Types - - -knownStrategies :: TacticsM () -knownStrategies = choice - [ known "fmap" deriveFmap - , known "mempty" deriveMempty - , known "arbitrary" deriveArbitrary - , known "<>" deriveMappend - , known "mappend" deriveMappend - ] - - -known :: String -> TacticsM () -> TacticsM () -known name t = do - getCurrentDefinitions >>= \case - [(def, _)] | def == mkVarOcc name -> - tracing ("known " <> name) t - _ -> failure NoApplicableTactic - - -deriveFmap :: TacticsM () -deriveFmap = do - try intros - overAlgebraicTerms homo - choice - [ overFunctions (apply Saturated) >> auto' 2 - , assumption - , recursion - ] - - ------------------------------------------------------------------------------- --- | We derive mappend by binding the arguments, introducing the constructor, --- and then calling mappend recursively. At each recursive call, we filter away --- any binding that isn't in an analogous position. --- --- The recursive call first attempts to use an instance in scope. If that fails, --- it falls back to trying a theta method from the hypothesis with the correct --- name. -deriveMappend :: TacticsM () -deriveMappend = do - try intros - destructAll - split - g <- goal - minst <- getKnownInstance (mkClsOcc "Semigroup") - . pure - . unCType - $ jGoal g - for_ minst $ \(cls, df) -> do - restrictPositionForApplication - (applyMethod cls df $ mkVarOcc "<>") - assumption - try $ - restrictPositionForApplication - (applyByName $ mkVarOcc "<>") - assumption - - ------------------------------------------------------------------------------- --- | We derive mempty by introducing the constructor, and then trying to --- 'mempty' everywhere. This smaller 'mempty' might come from an instance in --- scope, or it might come from the hypothesis theta. -deriveMempty :: TacticsM () -deriveMempty = do - split - g <- goal - minst <- getKnownInstance (mkClsOcc "Monoid") [unCType $ jGoal g] - for_ minst $ \(cls, df) -> do - applyMethod cls df $ mkVarOcc "mempty" - try assumption - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies/QuickCheck.hs deleted file mode 100644 index b14e4b8348..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/KnownStrategies/QuickCheck.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Wingman.KnownStrategies.QuickCheck where - -import Data.Bool (bool) -import Data.Generics (everything, mkQ) -import Data.List (partition) -import Development.IDE.GHC.Compat -import GHC.Exts (IsString (fromString)) -import GHC.List (foldl') -import GHC.SourceGen (int) -import GHC.SourceGen.Binds (match, valBind) -import GHC.SourceGen.Expr (case', lambda, let') -import GHC.SourceGen.Overloaded (App ((@@)), HasList (list)) -import GHC.SourceGen.Pat (conP) -import Refinery.Tactic (goal, rule, failure) -import Wingman.CodeGen -import Wingman.Judgements (jGoal) -import Wingman.Machinery (tracePrim) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Known tactic for deriving @arbitrary :: Gen a@. This tactic splits the --- type's data cons into terminal and inductive cases, and generates code that --- produces a terminal if the QuickCheck size parameter is <=1, or any data con --- otherwise. It correctly scales recursive parameters, ensuring termination. -deriveArbitrary :: TacticsM () -deriveArbitrary = do - ty <- jGoal <$> goal - case splitTyConApp_maybe $ unCType ty of - Just (gen_tc, [splitTyConApp_maybe -> Just (tc, apps)]) - | occNameString (occName $ tyConName gen_tc) == "Gen" -> do - rule $ \_ -> do - let dcs = tyConDataCons tc - (terminal, big) = partition ((== 0) . genRecursiveCount) - $ fmap (mkGenerator tc apps) dcs - terminal_expr = mkVal "terminal" - oneof_expr = mkVal "oneof" - pure - $ Synthesized (tracePrim "deriveArbitrary") - -- TODO(sandy): This thing is not actually empty! We produced - -- a bespoke binding "terminal", and a not-so-bespoke "n". - -- But maybe it's fine for known rules? - mempty - mempty - mempty - $ noLoc $ case terminal of - [onlyCon] -> genExpr onlyCon -- See #1879 - _ -> let' [valBind (fromString "terminal") $ list $ fmap genExpr terminal] $ - appDollar (mkFunc "sized") $ lambda [bvar' (mkVarOcc "n")] $ - case' (infixCall "<=" (mkVal "n") (int 1)) - [ match [conP (fromString "True") []] $ - oneof_expr @@ terminal_expr - , match [conP (fromString "False") []] $ - appDollar oneof_expr $ - infixCall "<>" - (list $ fmap genExpr big) - terminal_expr - ] - _ -> failure $ GoalMismatch "deriveArbitrary" ty - - ------------------------------------------------------------------------------- --- | Helper data type for the generator of a specific data con. -data Generator = Generator - { genRecursiveCount :: Integer - , genExpr :: HsExpr GhcPs - } - - ------------------------------------------------------------------------------- --- | Make a 'Generator' for a given tycon instantiated with the given @[Type]@. -mkGenerator :: TyCon -> [Type] -> DataCon -> Generator -mkGenerator tc apps dc = do - let dc_expr = var' $ occName $ dataConName dc - args = conLikeInstOrigArgTys' (RealDataCon dc) apps - num_recursive_calls = sum $ fmap (bool 0 1 . doesTypeContain tc) args - mkArbitrary = mkArbitraryCall tc num_recursive_calls - Generator num_recursive_calls $ case args of - [] -> mkFunc "pure" @@ dc_expr - (a : as) -> - foldl' - (infixCall "<*>") - (infixCall "<$>" dc_expr $ mkArbitrary a) - (fmap mkArbitrary as) - - ------------------------------------------------------------------------------- --- | Check if the given 'TyCon' exists anywhere in the 'Type'. -doesTypeContain :: TyCon -> Type -> Bool -doesTypeContain recursive_tc = - everything (||) $ mkQ False (== recursive_tc) - - ------------------------------------------------------------------------------- --- | Generate the correct sort of call to @arbitrary@. For recursive calls, we --- need to scale down the size parameter, either by a constant factor of 1 if --- it's the only recursive parameter, or by @`div` n@ where n is the number of --- recursive parameters. For all other types, just call @arbitrary@ directly. -mkArbitraryCall :: TyCon -> Integer -> Type -> HsExpr GhcPs -mkArbitraryCall recursive_tc n ty = - let arbitrary = mkFunc "arbitrary" - in case doesTypeContain recursive_tc ty of - True -> - mkFunc "scale" - @@ bool (mkFunc "flip" @@ mkFunc "div" @@ int n) - (mkFunc "subtract" @@ int 1) - (n == 1) - @@ arbitrary - False -> arbitrary diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs deleted file mode 100644 index fde8705d55..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE NoMonoLocalBinds #-} - -module Wingman.LanguageServer where - -import Control.Arrow ((***)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.RWS -import Control.Monad.State (State, evalState) -import Control.Monad.Trans.Maybe -import Data.Bifunctor (first) -import Data.Coerce -import Data.Functor ((<&>)) -import Data.Functor.Identity (runIdentity) -import qualified Data.HashMap.Strict as Map -import Data.IORef (readIORef) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Traversable -import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction) -import Development.IDE.Core.PositionMapping (idDelta) -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Rules (usePropertyAction) -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule) -import qualified Development.IDE.Core.Shake as IDE -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Development.IDE.GHC.Compat.ExactPrint -import qualified Development.IDE.GHC.Compat.Util as FastString -import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) -import Development.IDE.Graph (Action, RuleResult, Rules, action) -import Development.IDE.Graph.Classes (Hashable, NFData) -import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) -import GHC.Generics (Generic) -import Generics.SYB hiding (Generic) -import Ide.Plugin.Properties -import Ide.Types (PluginId) -import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) -import Language.LSP.Server (MonadLsp, sendNotification) -import Language.LSP.Protocol.Types hiding - (SemanticTokensEdit (_start)) -import Language.LSP.Protocol.Message -import Prelude hiding (span) -import Retrie (transformA) -import Wingman.Context -import Wingman.GHC -import Wingman.Judgements -import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ) -import Wingman.Judgements.Theta -import Wingman.Range -import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) -import Wingman.Types -import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) -import qualified Development.IDE.Core.Shake as Shake - - -newtype Log - = LogShake Shake.Log - deriving Show - -instance Pretty Log where - pretty = \case - LogShake shakeLog -> pretty shakeLog - -tacticDesc :: T.Text -> T.Text -tacticDesc name = "fill the hole using the " <> name <> " tactic" - - ------------------------------------------------------------------------------- --- | The name of the command for the LS. -tcCommandName :: TacticCommand -> T.Text -tcCommandName = T.pack . show - - -runIde :: String -> String -> IdeState -> Action a -> IO a -runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state - -runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a -runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state) - - -runCurrentIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO (Tracked 'Current r) -runCurrentIde herald state nfp a = - MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp - - -runStaleIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO (TrackedStale r) -runStaleIde herald state nfp a = - MaybeT $ runIde herald (show a) state $ useWithStale a nfp - - -unsafeRunStaleIde - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO r -unsafeRunStaleIde herald state nfp a = do - (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp - pure r - -unsafeRunStaleIdeFast - :: forall a r - . ( r ~ RuleResult a - , Eq a , Hashable a , Show a , Typeable a , NFData a - , Show r, Typeable r, NFData r - ) - => String - -> IdeState - -> NormalizedFilePath - -> a - -> MaybeT IO r -unsafeRunStaleIdeFast herald state nfp a = do - (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp - pure r - - ------------------------------------------------------------------------------- - -properties :: Properties - '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity)) - , 'PropertyKey "max_use_ctor_actions" 'TInteger - , 'PropertyKey "timeout_duration" 'TInteger - , 'PropertyKey "auto_gas" 'TInteger - , 'PropertyKey "proofstate_styling" 'TBoolean - ] -properties = emptyProperties - & defineBooleanProperty #proofstate_styling - "Should Wingman emit styling markup when showing metaprogram proof states?" True - & defineIntegerProperty #auto_gas - "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4 - & defineIntegerProperty #timeout_duration - "The timeout for Wingman actions, in seconds" 2 - & defineIntegerProperty #max_use_ctor_actions - "Maximum number of `Use constructor ` code actions that can appear" 5 - & defineEnumProperty #hole_severity - "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities." - [ (Just DiagnosticSeverity_Error, "error") - , (Just DiagnosticSeverity_Warning, "warning") - , (Just DiagnosticSeverity_Information, "info") - , (Just DiagnosticSeverity_Hint, "hint") - , (Nothing, "none") - ] - Nothing - - --- | Get the the plugin config -getTacticConfigAction :: PluginId -> Action Config -getTacticConfigAction pId = - Config - <$> usePropertyAction #max_use_ctor_actions pId properties - <*> usePropertyAction #timeout_duration pId properties - <*> usePropertyAction #auto_gas pId properties - <*> usePropertyAction #proofstate_styling pId properties - - -getIdeDynflags - :: IdeState - -> NormalizedFilePath - -> MaybeT IO DynFlags -getIdeDynflags state nfp = do - -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' - -- which don't change very often. - msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps - pure $ ms_hspp_opts $ msrModSummary msr - -getAllMetaprograms :: Data a => a -> [String] -getAllMetaprograms = everything (<>) $ mkQ mempty $ \case - WingmanMetaprogram fs -> [ FastString.unpackFS fs ] - (_ :: HsExpr GhcTc) -> mempty - - ------------------------------------------------------------------------------- --- | Find the last typechecked module, and find the most specific span, as well --- as the judgement at the given range. -judgementForHole - :: IdeState - -> NormalizedFilePath - -> Tracked 'Current Range - -> Config - -> MaybeT IO HoleJudgment -judgementForHole state nfp range cfg = do - let stale a = runStaleIde "judgementForHole" state nfp a - - TrackedStale asts amapping <- stale GetHieAst - case unTrack asts of - HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" - HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do - range' <- liftMaybe $ mapAgeFrom amapping range - binds <- stale GetBindings - tcg@(TrackedStale tcg_t tcg_map) - <- fmap (fmap tmrTypechecked) - $ stale TypeCheck - - hscenv <- stale GhcSessionDeps - - (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf - - new_rss <- liftMaybe $ mapAgeTo amapping rss - tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss - - -- KnownThings is just the instances in scope. There are no ranges - -- involved, so it's not crucial to track ages. - let henv = untrackedStaleValue hscenv - eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv - - (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps - let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t - - dflags <- getIdeDynflags state nfp - pure $ HoleJudgment - { hj_range = fmap realSrcSpanToRange new_rss - , hj_jdg = jdg - , hj_ctx = ctx - , hj_dflags = dflags - , hj_hole_sort = holeSortFor mp - } - - -holeSortFor :: Maybe T.Text -> HoleSort -holeSortFor = maybe Hole Metaprogram - - -mkJudgementAndContext - :: Config - -> Type - -> TrackedStale Bindings - -> Tracked 'Current RealSrcSpan - -> TrackedStale TcGblEnv - -> HscEnv - -> ExternalPackageState - -> Maybe (Judgement, Context) -mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do - binds_rss <- mapAgeFrom bmap rss - tcg_rss <- mapAgeFrom tcgmap rss - - let tcs = fmap tcg_binds tcg - ctx = mkContext cfg - (mapMaybe (sequenceA . (occName *** coerce)) - $ unTrack - $ getDefiningBindings <$> binds <*> binds_rss) - (unTrack tcg) - hscenv - eps - evidence - top_provs = getRhsPosVals tcg_rss tcs - already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs - local_hy = spliceProvenance top_provs - $ hypothesisFromBindings binds_rss binds - evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs - cls_hy = foldMap evidenceToHypothesis evidence - subst = ts_unifier $ evidenceToSubst evidence defaultTacticState - pure - ( disallowing AlreadyDestructed already_destructed - $ fmap (CType . substTyAddInScope subst . unCType) $ - mkFirstJudgement - ctx - (local_hy <> cls_hy) - (isRhsHoleWithoutWhere tcg_rss tcs) - g - , ctx - ) - - ------------------------------------------------------------------------------- --- | Determine which bindings have already been destructed by the location of --- the hole. -getAlreadyDestructed - :: Tracked age SrcSpan - -> Tracked age (LHsBinds GhcTc) - -> Set OccName -getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = - everythingContaining span - (mkQ mempty $ \case - Case (HsVar _ (L _ (occName -> var))) _ -> - S.singleton var - (_ :: HsExpr GhcTc) -> mempty - ) binds - - -getSpanAndTypeAtHole - :: Tracked age Range - -> Tracked age (HieASTs Type) - -> Maybe (Tracked age RealSrcSpan, Type) -getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do - join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of - Nothing -> Nothing - Just ast' -> do - let info = nodeInfo ast' - ty <- listToMaybe $ nodeType info - guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info - -- Ensure we're actually looking at a hole here - occ <- (either (const Nothing) (Just . occName) =<<) - . listToMaybe - . S.toList - . M.keysSet - $ nodeIdentifiers info - guard $ isHole occ - pure (unsafeCopyAge r $ nodeSpan ast', ty) - - - ------------------------------------------------------------------------------- --- | Combine two (possibly-overlapping) hypotheses; using the provenance from --- the first hypothesis if the bindings overlap. -spliceProvenance - :: Hypothesis a -- ^ Bindings to keep - -> Hypothesis a -- ^ Bindings to keep if they don't overlap with the first set - -> Hypothesis a -spliceProvenance top x = - let bound = S.fromList $ fmap hi_name $ unHypothesis top - in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x - - ------------------------------------------------------------------------------- --- | Compute top-level position vals of a function -getRhsPosVals - :: Tracked age RealSrcSpan - -> Tracked age TypecheckedSource - -> Hypothesis CType -getRhsPosVals (unTrack -> rss) (unTrack -> tcs) - = everything (<>) (mkQ mempty $ \case - TopLevelRHS name ps - (L (RealSrcSpan span _) -- body with no guards and a single defn - (HsVar _ (L _ hole))) - _ - | containsSpan rss span -- which contains our span - , isHole $ occName hole -- and the span is a hole - -> flip evalState 0 $ buildTopLevelHypothesis name ps - _ -> mempty - ) tcs - - ------------------------------------------------------------------------------- --- | Construct a hypothesis given the patterns from the left side of a HsMatch. --- These correspond to things that the user put in scope before running --- tactics. -buildTopLevelHypothesis - :: OccName -- ^ Function name - -> [PatCompat GhcTc] - -> State Int (Hypothesis CType) -buildTopLevelHypothesis name ps = do - fmap mconcat $ - for (zip [0..] ps) $ \(ix, p) -> - buildPatHy (TopLevelArgPrv name ix $ length ps) p - - ------------------------------------------------------------------------------- --- | Construct a hypothesis for a single pattern, including building --- sub-hypotheses for constructor pattern matches. -buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType) -buildPatHy prov (fromPatCompat -> p0) = - case p0 of - VarPat _ x -> pure $ mkIdHypothesis (unLoc x) prov - LazyPat _ p -> buildPatHy prov p - AsPat _ x p -> do - hy' <- buildPatHy prov p - pure $ mkIdHypothesis (unLoc x) prov <> hy' - ParPat _ p -> buildPatHy prov p - BangPat _ p -> buildPatHy prov p - ViewPat _ _ p -> buildPatHy prov p - -- Desugar lists into cons - ListPat _ [] -> pure mempty - ListPat x@(ListPatTc ty _) (p : ps) -> - mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] - [ (0, p) - , (1, toPatCompat $ ListPat x ps) - ] - -- Desugar tuples into an explicit constructor - TuplePat tys pats boxity -> - mkDerivedConHypothesis - prov - (RealDataCon $ tupleDataCon boxity $ length pats) - tys - $ zip [0.. ] pats -#if __GLASGOW_HASKELL__ >= 900 - ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} -> -#else - ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} -> -#endif - case f of - PrefixCon l_pgt -> - mkDerivedConHypothesis prov con args $ zip [0..] l_pgt - InfixCon pgt pgt5 -> - mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] - RecCon r -> - mkDerivedRecordHypothesis prov con args r - SigPat _ p _ -> buildPatHy prov p - _ -> pure mempty - - ------------------------------------------------------------------------------- --- | Like 'mkDerivedConHypothesis', but for record patterns. -mkDerivedRecordHypothesis - :: Provenance - -> ConLike -- ^ Destructing constructor - -> [Type] -- ^ Applied type variables - -> HsRecFields GhcTc (PatCompat GhcTc) - -> State Int (Hypothesis CType) -mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _) - | Just rec_fields <- getRecordFields dc - = do - let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..] - mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) -> - ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ) - , p - ) -mkDerivedRecordHypothesis _ _ _ _ = - error "impossible! using record pattern on something that isn't a record" - - ------------------------------------------------------------------------------- --- | Construct a fake variable name. Used to track the provenance of top-level --- pattern matches which otherwise wouldn't have anything to attach their --- 'TopLevelArgPrv' to. -mkFakeVar :: State Int OccName -mkFakeVar = do - i <- get - put $ i + 1 - pure $ mkVarOcc $ "_" <> show i - - ------------------------------------------------------------------------------- --- | Construct a fake variable to attach the current 'Provenance' to, and then --- build a sub-hypothesis for the pattern match. -mkDerivedConHypothesis - :: Provenance - -> ConLike -- ^ Destructing constructor - -> [Type] -- ^ Applied type variables - -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con - -> State Int (Hypothesis CType) -mkDerivedConHypothesis prov dc args ps = do - var <- mkFakeVar - hy' <- fmap mconcat $ - for ps $ \(ix, p) -> do - let prov' = PatternMatchPrv - $ PatVal (Just var) - (S.singleton var <> provAncestryOf prov) - (Uniquely dc) - ix - buildPatHy prov' p - pure - $ mappend hy' - $ Hypothesis - $ pure - $ HyInfo var (DisallowedPrv AlreadyDestructed prov) - $ CType - -- TODO(sandy): This is the completely wrong type, but we don't have a good - -- way to get the real one. It's probably OK though, since we're generating - -- this term with a disallowed provenance, and it doesn't actually exist - -- anyway. - $ conLikeResTy dc args - - ------------------------------------------------------------------------------- --- | Build a 'Hypothesis' given an 'Id'. -mkIdHypothesis :: Id -> Provenance -> Hypothesis CType -mkIdHypothesis (splitId -> (name, ty)) prov = - Hypothesis $ pure $ HyInfo name prov ty - - ------------------------------------------------------------------------------- --- | Is this hole immediately to the right of an equals sign --- and is there --- no where clause attached to it? --- --- It's important that there is no where clause because otherwise it gets --- clobbered. See #2183 for an example. --- --- This isn't a perfect check, and produces some ugly code. But it's much much --- better than the alternative, which is to destructively modify the user's --- AST. -isRhsHoleWithoutWhere - :: Tracked age RealSrcSpan - -> Tracked age TypecheckedSource - -> Bool -isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = - everything (||) (mkQ False $ \case - TopLevelRHS _ _ - (L (RealSrcSpan span _) _) - (EmptyLocalBinds _) -> containsSpan rss span - _ -> False - ) tcs - - -ufmSeverity :: UserFacingMessage -> MessageType -ufmSeverity NotEnoughGas = MessageType_Info -ufmSeverity TacticErrors = MessageType_Error -ufmSeverity TimedOut = MessageType_Info -ufmSeverity NothingToDo = MessageType_Info -ufmSeverity (InfrastructureError _) = MessageType_Error - - -mkShowMessageParams :: UserFacingMessage -> ShowMessageParams -mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm - - -showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () -showLspMessage = sendNotification SMethod_WindowShowMessage - - --- This rule only exists for generating file diagnostics --- so the RuleResult is empty -data WriteDiagnostics = WriteDiagnostics - deriving (Eq, Show, Typeable, Generic) - -instance Hashable WriteDiagnostics -instance NFData WriteDiagnostics - -type instance RuleResult WriteDiagnostics = () - -data GetMetaprograms = GetMetaprograms - deriving (Eq, Show, Typeable, Generic) - -instance Hashable GetMetaprograms -instance NFData GetMetaprograms - -type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] - -wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -wingmanRules recorder plId = do - define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> - usePropertyAction #hole_severity plId properties >>= \case - Nothing -> pure (mempty, Just ()) - Just severity -> - use GetParsedModule nfp >>= \case - Nothing -> - pure ([], Nothing) - Just pm -> do - let holes :: [Range] - holes = - everything (<>) - (mkQ mempty $ \case - L span (HsVar _ (L _ name)) - | isHole (occName name) -> - maybeToList $ srcSpanToRange span -#if __GLASGOW_HASKELL__ >= 900 - L span (HsUnboundVar _ occ) -#else - L span (HsUnboundVar _ (TrueExprHole occ)) -#endif - | isHole occ -> - maybeToList $ srcSpanToRange span - (_ :: LHsExpr GhcPs) -> mempty - ) $ pm_parsed_source pm - pure - ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes - , Just () - ) - - defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do - TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp - let scrutinees = traverse (metaprogramQ . tcg_binds) tcg - return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do - case ss of - RealSrcSpan r _ -> do - rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r - pure (rss', program) - UnhelpfulSpan _ -> Nothing - - -- This persistent rule helps to avoid blocking HLS hover providers at startup - -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other - -- hover providers from being used to produce a response - addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing) - - action $ do - files <- getFilesOfInterestUntracked - void $ uses WriteDiagnostics $ Map.keys files - - -mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic -mkDiagnostic severity r = - Diagnostic r - (Just severity) - (Just $ InR "hole") - Nothing - (Just "wingman") - "Hole" - (Just [DiagnosticTag_Unnecessary]) - Nothing - Nothing - - ------------------------------------------------------------------------------- --- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. -mkWorkspaceEdits - :: DynFlags - -> ClientCapabilities - -> VersionedTextDocumentIdentifier - -> Annotated ParsedSource - -> Graft (Either String) ParsedSource - -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits dflags ccs verTxtDocId pm g = do - let pm' = runIdentity $ transformA pm annotateMetaprograms - let response = transform dflags ccs verTxtDocId g pm' - in first (InfrastructureError . T.pack) response - - ------------------------------------------------------------------------------- --- | Add ExactPrint annotations to every metaprogram in the source tree. --- Usually the ExactPrint module can do this for us, but we've enabled --- QuasiQuotes, so the round-trip print/parse journey will crash. -annotateMetaprograms :: Data a => a -> Transform a -annotateMetaprograms = everywhereM $ mkM $ \case - L ss (WingmanMetaprogram mp) -> do - let x = L ss $ MetaprogramSyntax mp - let anns = addAnnotationsForPretty [] x mempty - modifyAnnsT $ mappend anns - pure x - (x :: LHsExpr GhcPs) -> pure x - - ------------------------------------------------------------------------------- --- | Find the source of a tactic metaprogram at the given span. -getMetaprogramAtSpan - :: Tracked age SrcSpan - -> Tracked age TcGblEnv - -> Maybe T.Text -getMetaprogramAtSpan (unTrack -> ss) - = fmap snd - . listToMaybe - . metaprogramAtQ ss - . tcg_binds - . unTrack - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs deleted file mode 100644 index 8f55ee2143..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE RankNTypes #-} - -module Wingman.LanguageServer.Metaprogram - ( hoverProvider - ) where - -import Control.Applicative (empty) -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Data.List (find) -import Data.Maybe -import qualified Data.Text as T -import Development.IDE (positionToRealSrcLoc, realSrcSpanToRange) -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) -import Ide.Types -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message -import Prelude hiding (span) -import Wingman.LanguageServer -import Wingman.Metaprogramming.Parser (attempt_it) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Provide the "empty case completion" code lens -hoverProvider :: PluginMethodHandler IdeState Method_TextDocumentHover -hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos - stale = unsafeRunStaleIdeFast "hoverProvider" state nfp - - cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) - liftIO $ fromMaybeT (InR Null) $ do - holes <- stale GetMetaprograms - - case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of - Just (trss, program) -> do - let tr_range = fmap realSrcSpanToRange trss - rsl = realSrcSpanStart $ unTrack trss - HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg - z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program - pure $ InL $ Hover - { _contents = InL - $ MarkupContent MarkupKind_Markdown - $ either T.pack T.pack z - , _range = Just $ unTrack tr_range - } - Nothing -> empty -hoverProvider _ _ _ = pure $ InR Null - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs deleted file mode 100644 index 4d28c92ad8..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Wingman.LanguageServer.TacticProviders - ( commandProvider - , commandTactic - , TacticProviderData (..) - ) where - -import Control.Monad -import Data.Bool (bool) -import Data.Coerce -import Data.Maybe -import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Ide.Types hiding (Config) -import Language.LSP.Protocol.Types -import Prelude hiding (span) -import Wingman.AbstractLSP.Types -import Wingman.Auto -import Wingman.GHC -import Wingman.Judgements -import Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons) -import Wingman.Metaprogramming.Parser (parseMetaprogram) -import Wingman.Tactics -import Wingman.Types - - ------------------------------------------------------------------------------- --- | A mapping from tactic commands to actual tactics for refinery. -commandTactic :: TacticCommand -> T.Text -> TacticsM () -commandTactic Auto = const auto -commandTactic Intros = const intros -commandTactic IntroAndDestruct = const introAndDestruct -commandTactic Destruct = useNameFromHypothesis destruct . mkVarOcc . T.unpack -commandTactic DestructPun = useNameFromHypothesis destructPun . mkVarOcc . T.unpack -commandTactic Homomorphism = useNameFromHypothesis homo . mkVarOcc . T.unpack -commandTactic DestructLambdaCase = const destructLambdaCase -commandTactic HomomorphismLambdaCase = const homoLambdaCase -commandTactic DestructAll = const destructAll -commandTactic UseDataCon = userSplit . mkVarOcc . T.unpack -commandTactic Refine = const refine -commandTactic BeginMetaprogram = const metaprogram -commandTactic RunMetaprogram = parseMetaprogram - - ------------------------------------------------------------------------------- --- | The LSP kind -tacticKind :: TacticCommand -> T.Text -tacticKind Auto = "fillHole" -tacticKind Intros = "introduceLambda" -tacticKind IntroAndDestruct = "introduceAndDestruct" -tacticKind Destruct = "caseSplit" -tacticKind DestructPun = "caseSplitPun" -tacticKind Homomorphism = "homomorphicCaseSplit" -tacticKind DestructLambdaCase = "lambdaCase" -tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase" -tacticKind DestructAll = "splitFuncArgs" -tacticKind UseDataCon = "useConstructor" -tacticKind Refine = "refine" -tacticKind BeginMetaprogram = "beginMetaprogram" -tacticKind RunMetaprogram = "runMetaprogram" - - ------------------------------------------------------------------------------- --- | Whether or not this code action is preferred -- ostensibly refers to --- whether or not we can bind it to a key in vs code? -tacticPreferred :: TacticCommand -> Bool -tacticPreferred Auto = True -tacticPreferred Intros = True -tacticPreferred IntroAndDestruct = True -tacticPreferred Destruct = True -tacticPreferred DestructPun = False -tacticPreferred Homomorphism = True -tacticPreferred DestructLambdaCase = False -tacticPreferred HomomorphismLambdaCase = False -tacticPreferred DestructAll = True -tacticPreferred UseDataCon = True -tacticPreferred Refine = True -tacticPreferred BeginMetaprogram = False -tacticPreferred RunMetaprogram = True - - -mkTacticKind :: TacticCommand -> CodeActionKind -mkTacticKind = - CodeActionKind_Custom . mappend "refactor.wingman." . tacticKind - - ------------------------------------------------------------------------------- --- | Mapping from tactic commands to their contextual providers. See 'provide', --- 'filterGoalType' and 'filterBindingType' for the nitty gritty. -commandProvider :: TacticCommand -> TacticProvider -commandProvider Auto = - requireHoleSort (== Hole) $ - provide Auto "" -commandProvider Intros = - requireHoleSort (== Hole) $ - filterGoalType isFunction $ - provide Intros "" -commandProvider IntroAndDestruct = - requireHoleSort (== Hole) $ - filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $ - provide IntroAndDestruct "" -commandProvider Destruct = - requireHoleSort (== Hole) $ - filterBindingType destructFilter $ \occ _ -> - provide Destruct $ T.pack $ occNameString occ -commandProvider DestructPun = - requireHoleSort (== Hole) $ - filterBindingType destructPunFilter $ \occ _ -> - provide DestructPun $ T.pack $ occNameString occ -commandProvider Homomorphism = - requireHoleSort (== Hole) $ - filterBindingType homoFilter $ \occ _ -> - provide Homomorphism $ T.pack $ occNameString occ -commandProvider DestructLambdaCase = - requireHoleSort (== Hole) $ - requireExtension LambdaCase $ - filterGoalType (isJust . lambdaCaseable) $ - provide DestructLambdaCase "" -commandProvider HomomorphismLambdaCase = - requireHoleSort (== Hole) $ - requireExtension LambdaCase $ - filterGoalType (liftLambdaCase False homoFilter) $ - provide HomomorphismLambdaCase "" -commandProvider DestructAll = - requireHoleSort (== Hole) $ - withJudgement $ \jdg -> - case _jIsTopHole jdg && jHasBoundArgs jdg of - True -> provide DestructAll "" - False -> mempty -commandProvider UseDataCon = - requireHoleSort (== Hole) $ - withConfig $ \cfg -> - filterTypeProjection - ( guardLength (<= cfg_max_use_ctor_actions cfg) - . maybe [] fst - . tacticsGetDataCons - ) $ \dcon -> - provide UseDataCon - . T.pack - . occNameString - . occName - $ dataConName dcon -commandProvider Refine = - requireHoleSort (== Hole) $ - provide Refine "" -commandProvider BeginMetaprogram = - requireHoleSort (== Hole) $ - provide BeginMetaprogram "" -commandProvider RunMetaprogram = - withMetaprogram $ \mp -> - provide RunMetaprogram mp - - ------------------------------------------------------------------------------- --- | Return an empty list if the given predicate doesn't hold over the length -guardLength :: (Int -> Bool) -> [a] -> [a] -guardLength f as = bool [] as $ f $ length as - - ------------------------------------------------------------------------------- --- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS --- UI. -type TacticProvider - = TacticProviderData - -> [(Metadata, T.Text)] - - -data TacticProviderData = TacticProviderData - { tpd_lspEnv :: LspEnv - , tpd_jdg :: Judgement - , tpd_hole_sort :: HoleSort - } - - -requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider -requireHoleSort p tp tpd = - case p $ tpd_hole_sort tpd of - True -> tp tpd - False -> [] - -withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider -withMetaprogram tp tpd = - case tpd_hole_sort tpd of - Metaprogram mp -> tp mp tpd - _ -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -requireExtension :: Extension -> TacticProvider -> TacticProvider -requireExtension ext tp tpd = - case xopt ext $ le_dflags $ tpd_lspEnv tpd of - True -> tp tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider -filterGoalType p tp tpd = - case p $ unCType $ jGoal $ tpd_jdg tpd of - True -> tp tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- predicate holds for the goal. -withJudgement :: (Judgement -> TacticProvider) -> TacticProvider -withJudgement tp tpd = tp (tpd_jdg tpd) tpd - - ------------------------------------------------------------------------------- --- | Multiply a 'TacticProvider' for each binding, making sure it appears only --- when the given predicate holds over the goal and binding types. -filterBindingType - :: (Type -> Type -> Bool) -- ^ Goal and then binding types. - -> (OccName -> Type -> TacticProvider) - -> TacticProvider -filterBindingType p tp tpd = - let jdg = tpd_jdg tpd - hy = jLocalHypothesis jdg - g = jGoal jdg - in unHypothesis hy >>= \hi -> - let ty = unCType $ hi_type hi - in case p (unCType g) ty of - True -> tp (hi_name hi) ty tpd - False -> [] - - ------------------------------------------------------------------------------- --- | Multiply a 'TacticProvider' by some feature projection out of the goal --- type. Used e.g. to crete a code action for every data constructor. -filterTypeProjection - :: (Type -> [a]) -- ^ Features of the goal to look into further - -> (a -> TacticProvider) - -> TacticProvider -filterTypeProjection p tp tpd = - (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a -> - tp a tpd - - ------------------------------------------------------------------------------- --- | Get access to the 'Config' when building a 'TacticProvider'. -withConfig :: (Config -> TacticProvider) -> TacticProvider -withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd - - ------------------------------------------------------------------------------- --- | Terminal constructor for providing context-sensitive tactics. Tactics --- given by 'provide' are always available. -provide :: TacticCommand -> T.Text -> TacticProvider -provide tc name _ = - pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name) - - ------------------------------------------------------------------------------- --- | Construct a 'CommandId' -tcCommandId :: TacticCommand -> CommandId -tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command" - - ------------------------------------------------------------------------------- --- | We should show homos only when the goal type is the same as the binding --- type, and that both are usual algebraic types. -homoFilter :: Type -> Type -> Bool -homoFilter codomain domain = - case uncoveredDataCons domain codomain of - Just s -> S.null s - _ -> False - - ------------------------------------------------------------------------------- --- | Lift a function of (codomain, domain) over a lambda case. -liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r -liftLambdaCase nil f t = - case tacticsSplitFunTy t of - (_, _, arg : _, res) -> f res $ scaledThing arg - _ -> nil - - - ------------------------------------------------------------------------------- --- | We should show destruct for bindings only when those bindings have usual --- algebraic types. -destructFilter :: Type -> Type -> Bool -destructFilter _ (algebraicTyCon -> Just _) = True -destructFilter _ _ = False - - ------------------------------------------------------------------------------- --- | We should show destruct punning for bindings only when those bindings have --- usual algebraic types, and when any of their data constructors are records. -destructPunFilter :: Type -> Type -> Bool -destructPunFilter _ (algebraicTyCon -> Just tc) = - not . all (null . dataConFieldLabels) $ tyConDataCons tc -destructPunFilter _ _ = False - - -instance IsContinuationSort TacticCommand where - toCommandId = tcCommandId - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs deleted file mode 100644 index 278304644e..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.Machinery where - -import Control.Applicative (empty) -import Control.Concurrent.Chan.Unagi.NoBlocking (newChan, writeChan, OutChan, tryRead, tryReadChan) -import Control.Lens ((<>~)) -import Control.Monad.Reader -import Control.Monad.State.Class (gets, modify, MonadState) -import Control.Monad.State.Strict (StateT (..), execStateT) -import Control.Monad.Trans.Maybe -import Data.Coerce -import Data.Foldable -import Data.Functor ((<&>)) -import Data.Generics (everything, gcount, mkQ) -import Data.Generics.Product (field') -import Data.List (sortBy) -import qualified Data.Map as M -import Data.Maybe (mapMaybe, isNothing) -import Data.Monoid (getSum) -import Data.Ord (Down (..), comparing) -import qualified Data.Set as S -import Data.Traversable (for) -import Development.IDE.Core.Compile (lookupName) -import Development.IDE.GHC.Compat hiding (isTopLevel, empty) -import Refinery.Future -import Refinery.ProofState -import Refinery.Tactic -import Refinery.Tactic.Internal -import System.Timeout (timeout) -import Wingman.Context (getInstance) -import Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars, tryUnifyUnivarsButNotSkolemsMany) -import Wingman.Judgements -import Wingman.Simplify (simplify) -import Wingman.Types - -#if __GLASGOW_HASKELL__ < 900 -import FunDeps (fd_eqs, improveFromInstEnv) -import Pair (unPair) -#else -import GHC.Tc.Instance.FunDeps (fd_eqs, improveFromInstEnv) -import GHC.Data.Pair (unPair) -#endif - - -substCTy :: TCvSubst -> CType -> CType -substCTy subst = coerce . substTy subst . coerce - - -getSubstForJudgement - :: MonadState TacticState m - => Judgement - -> m TCvSubst -getSubstForJudgement j = do - -- NOTE(sandy): It's OK to use mempty here, because coercions _can_ give us - -- substitutions for skolems. - let coercions = j_coercion j - unifier <- gets ts_unifier - pure $ unionTCvSubst unifier coercions - ------------------------------------------------------------------------------- --- | Produce a subgoal that must be solved before we can solve the original --- goal. -newSubgoal - :: Judgement - -> Rule -newSubgoal j = do - ctx <- ask - unifier <- getSubstForJudgement j - subgoal - $ normalizeJudgement ctx - $ substJdg unifier - $ unsetIsTopHole - $ normalizeJudgement ctx j - - -tacticToRule :: Judgement -> TacticsM () -> Rule -tacticToRule jdg (TacticT tt) = RuleT $ execStateT tt jdg >>= flip Subgoal Axiom - - -consumeChan :: OutChan (Maybe a) -> IO [a] -consumeChan chan = do - tryReadChan chan >>= tryRead >>= \case - Nothing -> pure [] - Just (Just a) -> (a:) <$> consumeChan chan - Just Nothing -> pure [] - - ------------------------------------------------------------------------------- --- | Attempt to generate a term of the right type using in-scope bindings, and --- a given tactic. -runTactic - :: Int -- ^ Timeout - -> Context - -> Judgement - -> TacticsM () -- ^ Tactic to use - -> IO (Either [TacticError] RunTacticResults) -runTactic duration ctx jdg t = do - let skolems = S.fromList - $ foldMap (tyCoVarsOfTypeWellScoped . unCType) - $ (:) (jGoal jdg) - $ fmap hi_type - $ toList - $ hyByName - $ jHypothesis jdg - tacticState = - defaultTacticState - { ts_skolems = skolems - } - - let stream = hoistListT (flip runReaderT ctx . unExtractM) - $ runStreamingTacticT t jdg tacticState - (in_proofs, out_proofs) <- newChan - (in_errs, out_errs) <- newChan - timed_out <- - fmap isNothing $ timeout duration $ consume stream $ \case - Left err -> writeChan in_errs $ Just err - Right proof -> writeChan in_proofs $ Just proof - writeChan in_proofs Nothing - - solns <- consumeChan out_proofs - let sorted = - flip sortBy solns $ comparing $ \(Proof ext _ holes) -> - Down $ scoreSolution ext jdg $ fmap snd holes - case sorted of - ((Proof syn _ subgoals) : _) -> - pure $ Right $ - RunTacticResults - { rtr_trace = syn_trace syn - , rtr_extract = simplify $ syn_val syn - , rtr_subgoals = fmap snd subgoals - , rtr_other_solns = reverse . fmap pf_extract $ sorted - , rtr_jdg = jdg - , rtr_ctx = ctx - , rtr_timed_out = timed_out - } - _ -> fmap Left $ consumeChan out_errs - - -tracePrim :: String -> Trace -tracePrim = flip rose [] - - ------------------------------------------------------------------------------- --- | Mark that a tactic used the given string in its extract derivation. Mainly --- used for debugging the search when things go terribly wrong. -tracing - :: Functor m - => String - -> TacticT jdg (Synthesized ext) err s m a - -> TacticT jdg (Synthesized ext) err s m a -tracing s = mappingExtract (mapTrace $ rose s . pure) - - ------------------------------------------------------------------------------- --- | Mark that a tactic performed recursion. Doing so incurs a small penalty in --- the score. -markRecursion - :: Functor m - => TacticT jdg (Synthesized ext) err s m a - -> TacticT jdg (Synthesized ext) err s m a -markRecursion = mappingExtract (field' @"syn_recursion_count" <>~ 1) - - ------------------------------------------------------------------------------- --- | Map a function over the extract created by a tactic. -mappingExtract - :: Functor m - => (ext -> ext) - -> TacticT jdg ext err s m a - -> TacticT jdg ext err s m a -mappingExtract f (TacticT m) - = TacticT $ StateT $ \jdg -> - mapExtract id f $ runStateT m jdg - - ------------------------------------------------------------------------------- --- | Given the results of running a tactic, score the solutions by --- desirability. --- --- NOTE: This function is completely unprincipled and was just hacked together --- to produce the right test results. -scoreSolution - :: Synthesized (LHsExpr GhcPs) - -> Judgement - -> [Judgement] - -> ( Penalize Int -- number of holes - , Reward Bool -- all bindings used - , Penalize Int -- unused top-level bindings - , Penalize Int -- number of introduced bindings - , Reward Int -- number used bindings - , Penalize Int -- number of recursive calls - , Penalize Int -- size of extract - ) -scoreSolution ext goal holes - = ( Penalize $ length holes - , Reward $ S.null $ intro_vals S.\\ used_vals - , Penalize $ S.size unused_top_vals - , Penalize $ S.size intro_vals - , Reward $ S.size used_vals + length used_user_vals - , Penalize $ getSum $ syn_recursion_count ext - , Penalize $ solutionSize $ syn_val ext - ) - where - initial_scope = hyByName $ jEntireHypothesis goal - intro_vals = M.keysSet $ hyByName $ syn_scoped ext - used_vals = S.intersection intro_vals $ syn_used_vals ext - used_user_vals = filter (isLocalHypothesis . hi_provenance) - $ mapMaybe (flip M.lookup initial_scope) - $ S.toList - $ syn_used_vals ext - top_vals = S.fromList - . fmap hi_name - . filter (isTopLevel . hi_provenance) - . unHypothesis - $ syn_scoped ext - unused_top_vals = top_vals S.\\ used_vals - - ------------------------------------------------------------------------------- --- | Compute the number of 'LHsExpr' nodes; used as a rough metric for code --- size. -solutionSize :: LHsExpr GhcPs -> Int -solutionSize = everything (+) $ gcount $ mkQ False $ \case - (_ :: LHsExpr GhcPs) -> True - - -newtype Penalize a = Penalize a - deriving (Eq, Ord, Show) via (Down a) - -newtype Reward a = Reward a - deriving (Eq, Ord, Show) via a - - ------------------------------------------------------------------------------- --- | Generate a unique unification variable. -newUnivar :: MonadState TacticState m => m Type -newUnivar = do - freshTyvars $ - mkInfForAllTys [alphaTyVar] alphaTy - - ------------------------------------------------------------------------------- --- | Attempt to unify two types. -unify :: CType -- ^ The goal type - -> CType -- ^ The type we are trying unify the goal type with - -> RuleM () -unify goal inst = do - skolems <- gets ts_skolems - case tryUnifyUnivarsButNotSkolems skolems goal inst of - Just subst -> - modify $ updateSubst subst - Nothing -> cut - ------------------------------------------------------------------------------- --- | Get a substitution out of a theta's fundeps -learnFromFundeps - :: ThetaType - -> RuleM () -learnFromFundeps theta = do - inst_envs <- asks ctxInstEnvs - skolems <- gets ts_skolems - subst <- gets ts_unifier - let theta' = substTheta subst theta - fundeps = foldMap (foldMap fd_eqs . improveFromInstEnv inst_envs (\_ _ -> ())) theta' - case tryUnifyUnivarsButNotSkolemsMany skolems $ fmap unPair fundeps of - Just subst -> - modify $ updateSubst subst - Nothing -> cut - - -cut :: RuleT jdg ext err s m a -cut = RuleT Empty - - ------------------------------------------------------------------------------- --- | Attempt to unify two types. -canUnify - :: MonadState TacticState m - => CType -- ^ The goal type - -> CType -- ^ The type we are trying unify the goal type with - -> m Bool -canUnify goal inst = do - skolems <- gets ts_skolems - case tryUnifyUnivarsButNotSkolems skolems goal inst of - Just _ -> pure True - Nothing -> pure False - - ------------------------------------------------------------------------------- --- | Prefer the first tactic to the second, if the bool is true. Otherwise, just run the second tactic. --- --- This is useful when you have a clever pruning solution that isn't always --- applicable. -attemptWhen :: TacticsM a -> TacticsM a -> Bool -> TacticsM a -attemptWhen _ t2 False = t2 -attemptWhen t1 t2 True = commit t1 t2 - - ------------------------------------------------------------------------------- --- | Run the given tactic iff the current hole contains no univars. Skolems and --- already decided univars are OK though. -requireConcreteHole :: TacticsM a -> TacticsM a -requireConcreteHole m = do - jdg <- goal - skolems <- gets ts_skolems - let vars = S.fromList $ tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg - case S.size $ vars S.\\ skolems of - 0 -> m - _ -> failure TooPolymorphic - - ------------------------------------------------------------------------------- --- | The 'try' that comes in refinery 0.3 causes unnecessary backtracking and --- balloons the search space. This thing just tries it, but doesn't backtrack --- if it fails. --- --- NOTE(sandy): But there's a bug! Or at least, something not understood here. --- Using this everywhere breaks te tests, and neither I nor TOTBWF are sure --- why. Prefer 'try' if you can, and only try this as a last resort. --- --- TODO(sandy): Remove this when we upgrade to 0.4 -try' - :: Functor m - => TacticT jdg ext err s m () - -> TacticT jdg ext err s m () -try' t = commit t $ pure () - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -exact :: HsExpr GhcPs -> TacticsM () -exact = rule . const . pure . pure . noLoc - ------------------------------------------------------------------------------- --- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to --- look it up in the hypothesis. -useNameFromHypothesis :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a -useNameFromHypothesis f name = do - hy <- jHypothesis <$> goal - case M.lookup name $ hyByName hy of - Just hi -> f hi - Nothing -> failure $ NotInScope name - ------------------------------------------------------------------------------- --- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to --- look it up in the hypothesis. -useNameFromContext :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a -useNameFromContext f name = do - lookupNameInContext name >>= \case - Just ty -> f $ createImportedHyInfo name ty - Nothing -> failure $ NotInScope name - - ------------------------------------------------------------------------------- --- | Find the type of an 'OccName' that is defined in the current module. -lookupNameInContext :: MonadReader Context m => OccName -> m (Maybe CType) -lookupNameInContext name = do - ctx <- asks ctxModuleFuncs - pure $ case find ((== name) . fst) ctx of - Just (_, ty) -> pure ty - Nothing -> empty - - -getDefiningType - :: TacticsM CType -getDefiningType = do - calling_fun_name <- asks (fst . head . ctxDefiningFuncs) - maybe - (failure $ NotInScope calling_fun_name) - pure - =<< lookupNameInContext calling_fun_name - - ------------------------------------------------------------------------------- --- | Build a 'HyInfo' for an imported term. -createImportedHyInfo :: OccName -> CType -> HyInfo CType -createImportedHyInfo on ty = HyInfo - { hi_name = on - , hi_provenance = ImportPrv - , hi_type = ty - } - - -getTyThing - :: OccName - -> TacticsM (Maybe TyThing) -getTyThing occ = do - ctx <- ask - case lookupOccEnv (ctx_occEnv ctx) occ of - Just (elt : _) -> do - mvar <- lift - $ ExtractM - $ lift - $ lookupName (ctx_hscEnv ctx) - $ gre_name elt - pure mvar - _ -> pure Nothing - - ------------------------------------------------------------------------------- --- | Like 'getTyThing' but specialized to classes. -knownClass :: OccName -> TacticsM (Maybe Class) -knownClass occ = - getTyThing occ <&> \case - Just (ATyCon tc) -> tyConClass_maybe tc - _ -> Nothing - - ------------------------------------------------------------------------------- --- | Like 'getInstance', but uses a class that it just looked up. -getKnownInstance :: OccName -> [Type] -> TacticsM (Maybe (Class, PredType)) -getKnownInstance f tys = runMaybeT $ do - cls <- MaybeT $ knownClass f - MaybeT $ getInstance cls tys - - ------------------------------------------------------------------------------- --- | Lookup the type of any 'OccName' that was imported. Necessarily done in --- IO, so we only expose this functionality to the parser. Internal Haskell --- code that wants to lookup terms should do it via 'KnownThings'. -getOccNameType - :: OccName - -> TacticsM Type -getOccNameType occ = do - getTyThing occ >>= \case - Just (AnId v) -> pure $ varType v - _ -> failure $ NotInScope occ - - -getCurrentDefinitions :: TacticsM [(OccName, CType)] -getCurrentDefinitions = do - ctx_funcs <- asks ctxDefiningFuncs - for ctx_funcs $ \res@(occ, _) -> - pure . maybe res (occ,) =<< lookupNameInContext occ - - ------------------------------------------------------------------------------- --- | Given two types, see if we can construct a homomorphism by mapping every --- data constructor in the domain to the same in the codomain. This function --- returns 'Just' when all the lookups succeeded, and a non-empty value if the --- homomorphism *is not* possible. -uncoveredDataCons :: Type -> Type -> Maybe (S.Set (Uniquely DataCon)) -uncoveredDataCons domain codomain = do - (g_dcs, _) <- tacticsGetDataCons codomain - (hi_dcs, _) <- tacticsGetDataCons domain - pure $ S.fromList (coerce hi_dcs) S.\\ S.fromList (coerce g_dcs) - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Lexer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Lexer.hs deleted file mode 100644 index fed7e91bbd..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Lexer.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.Metaprogramming.Lexer where - -import Control.Applicative -import Control.Monad -import Data.Foldable (asum) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import Development.IDE.GHC.Compat.Core (OccName, mkVarOcc) -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as L - -type Parser = P.Parsec Void Text - - - -lineComment :: Parser () -lineComment = L.skipLineComment "--" - -blockComment :: Parser () -blockComment = L.skipBlockComment "{-" "-}" - -sc :: Parser () -sc = L.space P.space1 lineComment blockComment - -ichar :: Parser Char -ichar = P.alphaNumChar <|> P.char '_' <|> P.char '\'' - -symchar :: Parser Char -symchar = asum - [ P.symbolChar - , P.char '!' - , P.char '#' - , P.char '$' - , P.char '%' - , P.char '^' - , P.char '&' - , P.char '*' - , P.char '-' - , P.char '=' - , P.char '+' - , P.char ':' - , P.char '<' - , P.char '>' - , P.char ',' - , P.char '.' - , P.char '/' - , P.char '?' - , P.char '~' - , P.char '|' - , P.char '\\' - ] - -lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc - -symbol :: Text -> Parser Text -symbol = L.symbol sc - -symbol_ :: Text -> Parser () -symbol_ = void . symbol - -brackets :: Parser a -> Parser a -brackets = P.between (symbol "[") (symbol "]") - -braces :: Parser a -> Parser a -braces = P.between (symbol "{") (symbol "}") - -parens :: Parser a -> Parser a -parens = P.between (symbol "(") (symbol ")") - -identifier :: Text -> Parser () -identifier i = lexeme (P.string i *> P.notFollowedBy ichar) - -variable :: Parser OccName -variable = lexeme $ do - c <- P.alphaNumChar <|> P.char '(' - fmap mkVarOcc $ case c of - '(' -> do - cs <- P.many symchar - void $ P.char ')' - pure cs - _ -> do - cs <- P.many ichar - pure $ c : cs - -name :: Parser Text -name = lexeme $ do - c <- P.alphaNumChar - cs <- P.many (ichar <|> P.char '-') - pure $ T.pack (c:cs) - -keyword :: Text -> Parser () -keyword = identifier - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs deleted file mode 100644 index a1d4eca4d4..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs +++ /dev/null @@ -1,501 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Wingman.Metaprogramming.Parser where - -import qualified Control.Monad.Combinators.Expr as P -import Data.Either (fromRight) -import Data.Functor -import Data.Maybe (listToMaybe) -import qualified Data.Text as T -import Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile) -import Development.IDE.GHC.Compat.Util (unpackFS) -import Refinery.Tactic (failure) -import qualified Refinery.Tactic as R -import qualified Text.Megaparsec as P -import Wingman.Auto -import Wingman.Machinery (useNameFromHypothesis, useNameFromContext, getCurrentDefinitions) -import Wingman.Metaprogramming.Lexer -import Wingman.Metaprogramming.Parser.Documentation -import Wingman.Metaprogramming.ProofState (proofState, layout) -import Wingman.Tactics -import Wingman.Types - - -nullary :: T.Text -> TacticsM () -> Parser (TacticsM ()) -nullary name tac = identifier name $> tac - - -unary_occ :: T.Text -> (OccName -> TacticsM ()) -> Parser (TacticsM ()) -unary_occ name tac = tac <$> (identifier name *> variable) - - ------------------------------------------------------------------------------- --- | Like 'unary_occ', but runs directly in the 'Parser' monad. -unary_occM :: T.Text -> (OccName -> Parser (TacticsM ())) -> Parser (TacticsM ()) -unary_occM name tac = tac =<< (identifier name *> variable) - - -variadic_occ :: T.Text -> ([OccName] -> TacticsM ()) -> Parser (TacticsM ()) -variadic_occ name tac = tac <$> (identifier name *> P.many variable) - - -commands :: [SomeMetaprogramCommand] -commands = - [ command "assumption" Nondeterministic Nullary - "Use any term in the hypothesis that can unify with the current goal." - (pure assumption) - [ Example - Nothing - [] - [EHI "some_a_val" "a"] - (Just "a") - "some_a_val" - ] - - , command "assume" Deterministic (Ref One) - "Use the given term from the hypothesis, unifying it with the current goal" - (pure . assume) - [ Example - Nothing - ["some_a_val"] - [EHI "some_a_val" "a"] - (Just "a") - "some_a_val" - ] - - , command "intros" Deterministic (Bind Many) - ( mconcat - [ "Construct a lambda expression, using the specific names if given, " - , "generating unique names otherwise. When no arguments are given, " - , "all of the function arguments will be bound; otherwise, this " - , "tactic will bind only enough to saturate the given names. Extra " - , "names are ignored." - ]) - (pure . \case - [] -> intros - names -> intros' $ IntroduceOnlyNamed names - ) - [ Example - Nothing - [] - [] - (Just "a -> b -> c -> d") - "\\a b c -> (_ :: d)" - , Example - Nothing - ["aye"] - [] - (Just "a -> b -> c -> d") - "\\aye -> (_ :: b -> c -> d)" - , Example - Nothing - ["x", "y", "z", "w"] - [] - (Just "a -> b -> c -> d") - "\\x y z -> (_ :: d)" - ] - - , command "idiom" Deterministic Tactic - "Lift a tactic into idiom brackets." - (pure . idiom) - [ Example - Nothing - ["(apply f)"] - [EHI "f" "a -> b -> Int"] - (Just "Maybe Int") - "f <$> (_ :: Maybe a) <*> (_ :: Maybe b)" - ] - - , command "intro" Deterministic (Bind One) - "Construct a lambda expression, binding an argument with the given name." - (pure . intros' . IntroduceOnlyNamed . pure) - [ Example - Nothing - ["aye"] - [] - (Just "a -> b -> c -> d") - "\\aye -> (_ :: b -> c -> d)" - ] - - , command "destruct_all" Deterministic Nullary - "Pattern match on every function paramater, in original binding order." - (pure destructAll) - [ Example - (Just "Assume `a` and `b` were bound via `f a b = _`.") - [] - [EHI "a" "Bool", EHI "b" "Maybe Int"] - Nothing $ - T.pack $ init $ unlines - [ "case a of" - , " False -> case b of" - , " Nothing -> _" - , " Just i -> _" - , " True -> case b of" - , " Nothing -> _" - , " Just i -> _" - ] - ] - - , command "destruct" Deterministic (Ref One) - "Pattern match on the argument." - (pure . useNameFromHypothesis destruct) - [ Example - Nothing - ["a"] - [EHI "a" "Bool"] - Nothing $ - T.pack $ init $ unlines - [ "case a of" - , " False -> _" - , " True -> _" - ] - ] - - , command "homo" Deterministic (Ref One) - ( mconcat - [ "Pattern match on the argument, and fill the resulting hole in with " - , "the same data constructor." - ]) - (pure . useNameFromHypothesis homo) - [ Example - (Just $ mconcat - [ "Only applicable when the type constructor of the argument is " - , "the same as that of the hole." - ]) - ["e"] - [EHI "e" "Either a b"] - (Just "Either x y") $ - T.pack $ init $ unlines - [ "case e of" - , " Left a -> Left (_ :: x)" - , " Right b -> Right (_ :: y)" - ] - ] - - , command "application" Nondeterministic Nullary - "Apply any function in the hypothesis that returns the correct type." - (pure application) - [ Example - Nothing - [] - [EHI "f" "a -> b"] - (Just "b") - "f (_ :: a)" - ] - - , command "pointwise" Deterministic Tactic - "Restrict the hypothesis in the holes of the given tactic to align up with the top-level bindings. This will ensure, eg, that the first hole can see only terms that came from the first position in any terms destructed from the top-level bindings." - (pure . flip restrictPositionForApplication (pure ())) - [ Example - (Just "In the context of `f (a1, b1) (a2, b2) = _`. The resulting first hole can see only 'a1' and 'a2', and the second, only 'b1' and 'b2'.") - ["(use mappend)"] - [] - Nothing - "mappend _ _" - ] - - , command "apply" Deterministic (Ref One) - "Apply the given function from *local* scope." - (pure . useNameFromHypothesis (apply Saturated)) - [ Example - Nothing - ["f"] - [EHI "f" "a -> b"] - (Just "b") - "f (_ :: a)" - ] - - , command "split" Nondeterministic Nullary - "Produce a data constructor for the current goal." - (pure split) - [ Example - Nothing - [] - [] - (Just "Either a b") - "Right (_ :: b)" - ] - - , command "ctor" Deterministic (Ref One) - "Use the given data cosntructor." - (pure . userSplit) - [ Example - Nothing - ["Just"] - [] - (Just "Maybe a") - "Just (_ :: a)" - ] - - , command "obvious" Nondeterministic Nullary - "Produce a nullary data constructor for the current goal." - (pure obvious) - [ Example - Nothing - [] - [] - (Just "[a]") - "[]" - ] - - , command "auto" Nondeterministic Nullary - ( mconcat - [ "Repeatedly attempt to split, destruct, apply functions, and " - , "recurse in an attempt to fill the hole." - ]) - (pure auto) - [ Example - Nothing - [] - [EHI "f" "a -> b", EHI "g" "b -> c"] - (Just "a -> c") - "g . f" - ] - - , command "sorry" Deterministic Nullary - "\"Solve\" the goal by leaving a hole." - (pure sorry) - [ Example - Nothing - [] - [] - (Just "b") - "_ :: b" - ] - - , command "unary" Deterministic Nullary - ( mconcat - [ "Produce a hole for a single-parameter function, as well as a hole for " - , "its argument. The argument holes are completely unconstrained, and " - , "will be solved before the function." - ]) - (pure $ nary 1) - [ Example - (Just $ mconcat - [ "In the example below, the variable `a` is free, and will unify " - , "to the resulting extract from any subsequent tactic." - ]) - [] - [] - (Just "Int") - "(_2 :: a -> Int) (_1 :: a)" - ] - - , command "binary" Deterministic Nullary - ( mconcat - [ "Produce a hole for a two-parameter function, as well as holes for " - , "its arguments. The argument holes have the same type but are " - , "otherwise unconstrained, and will be solved before the function." - ]) - (pure $ nary 2) - [ Example - (Just $ mconcat - [ "In the example below, the variable `a` is free, and will unify " - , "to the resulting extract from any subsequent tactic." - ]) - [] - [] - (Just "Int") - "(_3 :: a -> a -> Int) (_1 :: a) (_2 :: a)" - ] - - , command "recursion" Deterministic Nullary - "Fill the current hole with a call to the defining function." - ( pure $ - fmap listToMaybe getCurrentDefinitions >>= \case - Just (self, _) -> useNameFromContext (apply Saturated) self - Nothing -> failure $ TacticPanic "no defining function" - ) - [ Example - (Just "In the context of `foo (a :: Int) (b :: b) = _`:") - [] - [] - Nothing - "foo (_ :: Int) (_ :: b)" - ] - - , command "use" Deterministic (Ref One) - "Apply the given function from *module* scope." - (pure . use Saturated) - [ Example - (Just "`import Data.Char (isSpace)`") - ["isSpace"] - [] - (Just "Bool") - "isSpace (_ :: Char)" - ] - - , command "cata" Deterministic (Ref One) - "Destruct the given term, recursing on every resulting binding." - (pure . useNameFromHypothesis cata) - [ Example - (Just "Assume we're called in the context of a function `f.`") - ["x"] - [EHI "x" "(a, a)"] - Nothing $ - T.pack $ init $ unlines - [ "case x of" - , " (a1, a2) ->" - , " let a1_c = f a1" - , " a2_c = f a2" - , " in _" - ] - ] - - , command "collapse" Deterministic Nullary - "Collapse every term in scope with the same type as the goal." - (pure collapse) - [ Example - Nothing - [] - [ EHI "a1" "a" - , EHI "a2" "a" - , EHI "a3" "a" - ] - (Just "a") - "(_ :: a -> a -> a -> a) a1 a2 a3" - ] - - , command "let" Deterministic (Bind Many) - "Create let-bindings for each binder given to this tactic." - (pure . letBind) - [ Example - Nothing - ["a", "b", "c"] - [ ] - (Just "x") - $ T.pack $ unlines - [ "let a = _1 :: a" - , " b = _2 :: b" - , " c = _3 :: c" - , " in (_4 :: x)" - ] - ] - - , command "try" Nondeterministic Tactic - "Simultaneously run and do not run a tactic. Subsequent tactics will bind on both states." - (pure . R.try) - [ Example - Nothing - ["(apply f)"] - [ EHI "f" "a -> b" - ] - (Just "b") - $ T.pack $ unlines - [ "-- BOTH of:\n" - , "f (_ :: a)" - , "\n-- and\n" - , "_ :: b" - ] - ] - - , command "nested" Nondeterministic (Ref One) - "Nest the given function (in module scope) with itself arbitrarily many times. NOTE: The resulting function is necessarily unsaturated, so you will likely need `with_arg` to use this tactic in a saturated context." - (pure . nested) - [ Example - Nothing - ["fmap"] - [] - (Just "[(Int, Either Bool a)] -> [(Int, Either Bool b)]") - "fmap (fmap (fmap _))" - ] - - , command "with_arg" Deterministic Nullary - "Fill the current goal with a function application. This can be useful when you'd like to fill in the argument before the function, or when you'd like to use a non-saturated function in a saturated context." - (pure with_arg) - [ Example - (Just "Where `a` is a new unifiable type variable.") - [] - [] - (Just "r") - "(_2 :: a -> r) (_1 :: a)" - ] - ] - - - -oneTactic :: Parser (TacticsM ()) -oneTactic = - P.choice - [ parens tactic - , makeParser commands - ] - - -tactic :: Parser (TacticsM ()) -tactic = P.makeExprParser oneTactic operators - -operators :: [[P.Operator Parser (TacticsM ())]] -operators = - [ [ P.InfixR (symbol "|" $> (R.<%>) )] - , [ P.InfixL (symbol ";" $> (>>)) - , P.InfixL (symbol "," $> bindOne) - ] - ] - - -tacticProgram :: Parser (TacticsM ()) -tacticProgram = do - sc - r <- tactic P.<|> pure (pure ()) - P.eof - pure r - - -wrapError :: String -> String -wrapError err = "```\n" <> err <> "\n```\n" - - -fixErrorOffset :: RealSrcLoc -> P.ParseErrorBundle a b -> P.ParseErrorBundle a b -fixErrorOffset rsl (P.ParseErrorBundle ne (P.PosState a n (P.SourcePos _ line col) pos s)) - = P.ParseErrorBundle ne - $ P.PosState a n - (P.SourcePos - (unpackFS $ srcLocFile rsl) - ((<>) line $ P.mkPos $ srcLocLine rsl - 1) - ((<>) col $ P.mkPos $ srcLocCol rsl - 1 + length @[] "[wingman|") - ) - pos - s - ------------------------------------------------------------------------------- --- | Attempt to run a metaprogram tactic, returning the proof state, or the --- errors. -attempt_it - :: RealSrcLoc - -> Context - -> Judgement - -> String - -> IO (Either String String) -attempt_it rsl ctx jdg program = - case P.runParser tacticProgram "" (T.pack program) of - Left peb -> pure $ Left $ wrapError $ P.errorBundlePretty $ fixErrorOffset rsl peb - Right tt -> do - res <- runTactic 2e6 ctx jdg tt - pure $ case res of - Left tes -> Left $ wrapError $ show tes - Right rtr -> Right - $ layout (cfg_proofstate_styling $ ctxConfig ctx) - $ proofState rtr - - -parseMetaprogram :: T.Text -> TacticsM () -parseMetaprogram - = fromRight (pure ()) - . P.runParser tacticProgram "" - - ------------------------------------------------------------------------------- --- | Automatically generate the metaprogram command reference. -writeDocumentation :: IO () -writeDocumentation = - writeFile "COMMANDS.md" $ - unlines - [ "# Wingman Metaprogram Command Reference" - , "" - , prettyReadme commands - ] - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs-boot b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs-boot deleted file mode 100644 index 607db0e6f3..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Wingman.Metaprogramming.Parser where - -import Wingman.Metaprogramming.Lexer -import Wingman.Types - -tactic :: Parser (TacticsM ()) - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser/Documentation.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser/Documentation.hs deleted file mode 100644 index 0c37d6365a..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/Parser/Documentation.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Wingman.Metaprogramming.Parser.Documentation where - -import Data.Functor ((<&>)) -import Data.List (sortOn) -import Data.String (IsString) -import Data.Text (Text) -import Prettyprinter hiding (parens) -import Prettyprinter.Render.String (renderString) -import Development.IDE.GHC.Compat (OccName) -import qualified Text.Megaparsec as P -import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens) -import Wingman.Types (TacticsM) - -import {-# SOURCE #-} Wingman.Metaprogramming.Parser (tactic) - - ------------------------------------------------------------------------------- --- | Is a tactic deterministic or not? -data Determinism - = Deterministic - | Nondeterministic - -prettyDeterminism :: Determinism -> Doc b -prettyDeterminism Deterministic = "deterministic" -prettyDeterminism Nondeterministic = "non-deterministic" - - ------------------------------------------------------------------------------- --- | How many arguments does the tactic take? -data Count a where - One :: Count OccName - Many :: Count [OccName] - -prettyCount :: Count a -> Doc b -prettyCount One = "single" -prettyCount Many = "variadic" - - ------------------------------------------------------------------------------- --- | What sorts of arguments does the tactic take? Currently there is no --- distinction between 'Ref' and 'Bind', other than documentation. --- --- The type index here is used for the shape of the function the parser should --- take. -data Syntax a where - Nullary :: Syntax (Parser (TacticsM ())) - Ref :: Count a -> Syntax (a -> Parser (TacticsM ())) - Bind :: Count a -> Syntax (a -> Parser (TacticsM ())) - Tactic :: Syntax (TacticsM () -> Parser (TacticsM ())) - -prettySyntax :: Syntax a -> Doc b -prettySyntax Nullary = "none" -prettySyntax (Ref co) = prettyCount co <+> "reference" -prettySyntax (Bind co) = prettyCount co <+> "binding" -prettySyntax Tactic = "tactic" - - ------------------------------------------------------------------------------- --- | An example for the documentation. -data Example = Example - { ex_ctx :: Maybe Text -- ^ Specific context information about when the tactic is applicable - , ex_args :: [Var] -- ^ Arguments the tactic was called with - , ex_hyp :: [ExampleHyInfo] -- ^ The hypothesis - , ex_goal :: Maybe ExampleType -- ^ Current goal. Nothing indicates it's uninteresting. - , ex_result :: Text -- ^ Resulting extract. - } - - ------------------------------------------------------------------------------- --- | An example 'HyInfo'. -data ExampleHyInfo = EHI - { ehi_name :: Var -- ^ Name of the variable - , ehi_type :: ExampleType -- ^ Type of the variable - } - - ------------------------------------------------------------------------------- --- | A variable -newtype Var = Var - { getVar :: Text - } - deriving newtype (IsString, Pretty) - - ------------------------------------------------------------------------------- --- | A type -newtype ExampleType = ExampleType - { getExampleType :: Text - } - deriving newtype (IsString, Pretty) - - ------------------------------------------------------------------------------- --- | A command to expose to the parser -data MetaprogramCommand a = MC - { mpc_name :: Text -- ^ Name of the command. This is the token necessary to run the command. - , mpc_syntax :: Syntax a -- ^ The command's arguments - , mpc_det :: Determinism -- ^ Determinism of the command - , mpc_description :: Text -- ^ User-facing description - , mpc_tactic :: a -- ^ Tactic to run - , mpc_examples :: [Example] -- ^ Collection of documentation examples - } - ------------------------------------------------------------------------------- --- | Existentialize the pain away -data SomeMetaprogramCommand where - SMC :: MetaprogramCommand a -> SomeMetaprogramCommand - - ------------------------------------------------------------------------------- --- | Run the 'Parser' of a 'MetaprogramCommand' -makeMPParser :: MetaprogramCommand a -> Parser (TacticsM ()) -makeMPParser (MC name Nullary _ _ t _) = do - identifier name - t -makeMPParser (MC name (Ref One) _ _ t _) = do - identifier name - variable >>= t -makeMPParser (MC name (Ref Many) _ _ t _) = do - identifier name - P.many variable >>= t -makeMPParser (MC name (Bind One) _ _ t _) = do - identifier name - variable >>= t -makeMPParser (MC name (Bind Many) _ _ t _) = do - identifier name - P.many variable >>= t -makeMPParser (MC name Tactic _ _ t _) = do - identifier name - parens tactic >>= t - - ------------------------------------------------------------------------------- --- | Compile a collection of metaprogram commands into a parser. -makeParser :: [SomeMetaprogramCommand] -> Parser (TacticsM ()) -makeParser ps = P.choice $ ps <&> \(SMC mp) -> makeMPParser mp - - ------------------------------------------------------------------------------- --- | Pretty print a command. -prettyCommand :: MetaprogramCommand a -> Doc b -prettyCommand (MC name syn det desc _ exs) = vsep - [ "##" <+> pretty name - , mempty - , "arguments:" <+> prettySyntax syn <> ". " - , prettyDeterminism det <> "." - , mempty - , ">" <+> align (pretty desc) - , mempty - , vsep $ fmap (prettyExample name) exs - , mempty - ] - - ------------------------------------------------------------------------------- --- | Pretty print a hypothesis. -prettyHyInfo :: ExampleHyInfo -> Doc a -prettyHyInfo hi = pretty (ehi_name hi) <+> "::" <+> pretty (ehi_type hi) - - ------------------------------------------------------------------------------- --- | Append the given term only if the first argument has elements. -mappendIfNotNull :: [a] -> a -> [a] -mappendIfNotNull [] _ = [] -mappendIfNotNull as a = as <> [a] - - ------------------------------------------------------------------------------- --- | Pretty print an example. -prettyExample :: Text -> Example -> Doc a -prettyExample name (Example m_txt args hys goal res) = - align $ vsep - [ mempty - , "### Example" - , maybe mempty ((line <>) . (<> line) . (">" <+>) . align . pretty) m_txt - , "Given:" - , mempty - , codeFence $ vsep - $ mappendIfNotNull (fmap prettyHyInfo hys) mempty - <> [ "_" <+> maybe mempty (("::" <+>). pretty) goal - ] - , mempty - , hsep - [ "running " - , enclose "`" "`" $ pretty name <> hsep (mempty : fmap pretty args) - , "will produce:" - ] - , mempty - , codeFence $ align $ pretty res - ] - - ------------------------------------------------------------------------------- --- | Make a haskell code fence. -codeFence :: Doc a -> Doc a -codeFence d = align $ vsep - [ "```haskell" - , d - , "```" - ] - - ------------------------------------------------------------------------------- --- | Render all of the commands. -prettyReadme :: [SomeMetaprogramCommand] -> String -prettyReadme - = renderString - . layoutPretty defaultLayoutOptions - . vsep - . fmap (\case SMC c -> prettyCommand c) - . sortOn (\case SMC c -> mpc_name c) - - - ------------------------------------------------------------------------------- --- | Helper function to build a 'SomeMetaprogramCommand'. -command - :: Text - -> Determinism - -> Syntax a - -> Text - -> a - -> [Example] - -> SomeMetaprogramCommand -command txt det syn txt' a exs = SMC $ - MC - { mpc_name = txt - , mpc_det = det - , mpc_syntax = syn - , mpc_description = txt' - , mpc_tactic = a - , mpc_examples = exs - } - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs deleted file mode 100644 index 529c5c29cd..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Wingman.Metaprogramming.ProofState where - -import Data.Bool (bool) -import Data.Functor ((<&>)) -import qualified Data.Text as T -import Prettyprinter -import Prettyprinter.Render.Util.Panic -import Language.LSP.Protocol.Types (sectionSeparator) -import Wingman.Judgements (jHypothesis) -import Wingman.Types - -renderSimplyDecorated - :: Monoid out - => (T.Text -> out) -- ^ Render plain 'Text' - -> (ann -> out) -- ^ How to render an annotation - -> (ann -> out) -- ^ How to render the removed annotation - -> SimpleDocStream ann - -> out -renderSimplyDecorated text push pop = go [] - where - go _ SFail = panicUncaughtFail - go [] SEmpty = mempty - go (_:_) SEmpty = panicInputNotFullyConsumed - go st (SChar c rest) = text (T.singleton c) <> go st rest - go st (SText _l t rest) = text t <> go st rest - go st (SLine i rest) = - text (T.singleton '\n') <> text (textSpaces i) <> go st rest - go st (SAnnPush ann rest) = push ann <> go (ann : st) rest - go (ann:st) (SAnnPop rest) = pop ann <> go st rest - go [] SAnnPop{} = panicUnpairedPop -{-# INLINE renderSimplyDecorated #-} - - -data Ann - = Goal - | Hypoth - | Status - deriving (Eq, Ord, Show, Enum, Bounded) - -forceMarkdownNewlines :: String -> String -forceMarkdownNewlines = unlines . fmap (<> " ") . lines - -layout :: Bool -> Doc Ann -> String -layout use_styling - = forceMarkdownNewlines - . T.unpack - . renderSimplyDecorated id - (renderAnn use_styling) - (renderUnann use_styling) - . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.6) - -renderAnn :: Bool -> Ann -> T.Text -renderAnn False _ = "" -renderAnn _ Goal = "" -renderAnn _ Hypoth = "```haskell\n" -renderAnn _ Status = "" - -renderUnann :: Bool -> Ann -> T.Text -renderUnann False _ = "" -renderUnann _ Goal = "" -renderUnann _ Hypoth = "\n```\n" -renderUnann _ Status = "" - -proofState :: RunTacticResults -> Doc Ann -proofState RunTacticResults{rtr_subgoals} = - vsep - $ ( annotate Status - . countFinished "goals accomplished 🎉" "goal" - $ length rtr_subgoals - ) - : pretty sectionSeparator - : fmap prettySubgoal rtr_subgoals - - -prettySubgoal :: Judgement -> Doc Ann -prettySubgoal jdg = - vsep $ - [ mempty | has_hy] <> - [ annotate Hypoth $ prettyHypothesis hy | has_hy] <> - [ "⊢" <+> annotate Goal (prettyType (_jGoal jdg)) - , pretty sectionSeparator - ] - where - hy = jHypothesis jdg - has_hy = not $ null $ unHypothesis hy - - -prettyHypothesis :: Hypothesis CType -> Doc Ann -prettyHypothesis hy = - vsep $ unHypothesis hy <&> \hi -> - prettyHyInfo hi - -prettyHyInfo :: HyInfo CType -> Doc Ann -prettyHyInfo hi = viaShow (hi_name hi) <+> "::" <+> prettyType (hi_type hi) - - -prettyType :: CType -> Doc Ann -prettyType (CType ty) = viaShow ty - - -countFinished :: Doc Ann -> Doc Ann -> Int -> Doc Ann -countFinished finished _ 0 = finished -countFinished _ thing n = count thing n - -count :: Doc Ann -> Int -> Doc Ann -count thing n = - pretty n <+> thing <> bool "" "s" (n /= 1) - -textSpaces :: Int -> T.Text -textSpaces n = T.replicate n $ T.singleton ' ' - - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Naming.hs deleted file mode 100644 index 832fa117e1..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Naming.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.Naming where - -import Control.Arrow -import Control.Monad.State.Strict -import Data.Aeson (camelTo2) -import Data.Bool (bool) -import Data.Char -import Data.List (isPrefixOf) -import Data.List.Extra (split) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable -import Development.IDE.GHC.Compat.Core hiding (IsFunction) -import Text.Hyphenation (hyphenate, english_US) -import Wingman.GHC (tcTyVar_maybe) - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType -#endif - - ------------------------------------------------------------------------------- --- | A classification of a variable, for which we have specific naming rules. --- A variable can have multiple purposes simultaneously. -data Purpose - = Function [Type] Type - | Predicate - | Continuation - | Integral - | Number - | String - | List Type - | Maybe Type - | TyConned TyCon [Type] - -- ^ Something of the form @TC a b c@ - | TyVarred TyVar [Type] - -- ^ Something of the form @m a b c@ - -pattern IsPredicate :: Type -pattern IsPredicate <- - (tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True)) - -pattern IsFunction :: [Type] -> Type -> Type -pattern IsFunction args res <- - (first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res)) - -pattern IsString :: Type -pattern IsString <- - (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True])) - -pattern IsMaybe :: Type -> Type -pattern IsMaybe a <- - (splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a])) - -pattern IsList :: Type -> Type -pattern IsList a <- - (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a])) - -pattern IsTyConned :: TyCon -> [Type] -> Type -pattern IsTyConned tc args <- - (splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args)) - -pattern IsTyVarred :: TyVar -> [Type] -> Type -pattern IsTyVarred v args <- - (tcSplitAppTys -> (tcTyVar_maybe -> Just v, args)) - - ------------------------------------------------------------------------------- --- | Get the 'Purpose's of a type. A type can have multiple purposes --- simultaneously, so the order of purposes in this function corresponds to the --- precedence of that naming rule. Which means, eg, that if a type is both --- a 'Predicate' and a 'Function', we should prefer to use the predicate naming --- rules, since they come first. -getPurposes :: Type -> [Purpose] -getPurposes ty = mconcat - [ [ Predicate | IsPredicate <- [ty] ] - , [ Function args res | IsFunction args res <- [ty] ] - , with (isIntegerTy ty) [ Integral, Number ] - , with (isIntTy ty) [ Integral, Number ] - , [ Number | isFloatingTy ty ] - , [ String | isStringTy ty ] - , [ Maybe a | IsMaybe a <- [ty] ] - , [ List a | IsList a <- [ty] ] - , [ TyVarred v args | IsTyVarred v args <- [ty] ] - , [ TyConned tc args | IsTyConned tc args <- [ty] - , not (isTupleTyCon tc) - , tc /= listTyCon ] - ] - - ------------------------------------------------------------------------------- --- | Return 'mempty' if the give bool is false. -with :: Monoid a => Bool -> a -> a -with False _ = mempty -with True a = a - - ------------------------------------------------------------------------------- --- | Names we can give functions -functionNames :: [String] -functionNames = ["f", "g", "h"] - - ------------------------------------------------------------------------------- --- | Get a ranked ordering of names for a given purpose. -purposeToName :: Purpose -> [String] -purposeToName (Function args res) - | Just tv_args <- traverse tcTyVar_maybe $ args <> pure res - = fmap (<> foldMap (occNameString . occName) tv_args) functionNames -purposeToName (Function _ _) = functionNames -purposeToName Predicate = pure "p" -purposeToName Continuation = pure "k" -purposeToName Integral = ["n", "i", "j"] -purposeToName Number = ["x", "y", "z", "w"] -purposeToName String = ["s", "str"] -purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t -purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t -purposeToName (TyVarred tv args) - | Just tv_args <- traverse tcTyVar_maybe args - = pure $ foldMap (occNameString . occName) $ tv : tv_args -purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv -purposeToName (TyConned tc args@(_:_)) - | Just tv_args <- traverse tcTyVar_maybe args - = [ mkTyConName tc - -- We insert primes to everything later, but it gets the lowest - -- precedence. Here we'd like to prefer it over the more specific type - -- name. - , mkTyConName tc <> "'" - , mconcat - [ mkTyConName tc - , bool mempty "_" $ length (mkTyConName tc) > 1 - , foldMap (occNameString . occName) tv_args - ] - ] -purposeToName (TyConned tc _) - = pure - $ mkTyConName tc - - -mkTyName :: Type -> [String] -mkTyName = purposeToName <=< getPurposes - - ------------------------------------------------------------------------------- --- | Get a good name for a type constructor. -mkTyConName :: TyCon -> String -mkTyConName tc - | tc == unitTyCon = "u" - | isSymOcc occ - = take 1 - . fmap toLower - . filterReplace isSymbol 's' - . filterReplace isPunctuation 'p' - $ name - | camels@(_:_:_) <- camelTerms name - = foldMap (fmap toLower . take 1) camels - | otherwise - = getStem - $ fmap toLower name - where - occ = getOccName tc - name = occNameString occ - - ------------------------------------------------------------------------------- --- | Split a string into its camel case components. -camelTerms :: String -> [String] -camelTerms = split (== '@') . camelTo2 '@' - - ------------------------------------------------------------------------------- --- | A stem of a string is either a special-case shortened form, or a shortened --- first syllable. If the string is one syllable, we take the full word if it's --- short, or just the first two characters if it's long. Otherwise, just take --- the first syllable. --- --- NOTE: There's no rhyme or reason here, I just experimented until I got --- results that were reasonably consistent with the names I would give things. -getStem :: String -> String -getStem str = - let s = stem str - in case (s == str, length str) of - (False, _) -> s - (True, (<= 3) -> True) -> str - _ -> take 2 str - ------------------------------------------------------------------------------- --- | Get a special-case stem, or, failing that, give back the first syllable. -stem :: String -> String -stem "char" = "c" -stem "function" = "func" -stem "bool" = "b" -stem "either" = "e" -stem "text" = "txt" -stem s = join $ take 1 $ hyphenate english_US s - - ------------------------------------------------------------------------------- --- | Maybe replace an element in the list if the predicate matches -filterReplace :: (a -> Bool) -> a -> [a] -> [a] -filterReplace f r = fmap (\a -> bool a r $ f a) - - ------------------------------------------------------------------------------- --- | Produce a unique, good name for a type. -mkGoodName - :: Set OccName -- ^ Bindings in scope; used to ensure we don't shadow anything - -> Type -- ^ The type to produce a name for - -> OccName -mkGoodName in_scope (mkTyName -> tn) - = mkVarOcc - . fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn) - . getFirst - . foldMap (\n -> bool (pure n) mempty $ check n) - $ tn <> fmap (<> "'") tn - where - check n = S.member (mkVarOcc n) $ illegalNames <> in_scope - - -illegalNames :: Set OccName -illegalNames = S.fromList $ fmap mkVarOcc - [ "case" - , "of" - , "class" - , "data" - , "do" - , "type" - , "if" - , "then" - , "else" - , "let" - , "in" - , "mdo" - , "newtype" - , "proc" - , "rec" - , "where" - ] - - - ------------------------------------------------------------------------------- --- | Given a desired name, compute a new name for it based on how many names in --- scope conflict with it. Eg, if we want to name something @x@, but already --- have @x@, @x'@ and @x2@ in scope, we will give back @x3@. -mkNumericSuffix :: Set OccName -> String -> String -mkNumericSuffix s nm = - mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s - - ------------------------------------------------------------------------------- --- | Like 'mkGoodName' but creates several apart names. -mkManyGoodNames - :: (Traversable t) - => Set OccName - -> t Type - -> t OccName -mkManyGoodNames in_scope args = - flip evalState in_scope $ for args $ \at -> do - in_scope <- get - let n = mkGoodName in_scope at - modify $ S.insert n - pure n - - ------------------------------------------------------------------------------- --- | Which names are in scope? -getInScope :: Map OccName a -> [OccName] -getInScope = M.keys - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs deleted file mode 100644 index c8e6c2ae4f..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | A plugin that uses tactics to synthesize code -module Wingman.Plugin where - -import Control.Monad -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Plugin.CodeAction -import qualified Development.IDE.GHC.ExactPrint as E -import Ide.Types -import Language.LSP.Protocol.Message -import Prelude hiding (span) -import Wingman.AbstractLSP -import Wingman.AbstractLSP.TacticActions (makeTacticInteraction) -import Wingman.EmptyCase -import Wingman.LanguageServer hiding (Log) -import qualified Wingman.LanguageServer as WingmanLanguageServer -import Wingman.LanguageServer.Metaprogram (hoverProvider) -import Wingman.StaticPlugin -import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) - -data Log - = LogWingmanLanguageServer WingmanLanguageServer.Log - | LogExactPrint E.Log - deriving Show - -instance Pretty Log where - pretty = \case - LogWingmanLanguageServer log -> pretty log - LogExactPrint exactPrintLog -> pretty exactPrintLog - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId - = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder) - $ installInteractions - ( emptyCaseInteraction - : fmap makeTacticInteraction [minBound .. maxBound] - ) - $ (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hoverProvider - , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId - , pluginConfigDescriptor = - defaultConfigDescriptor - { configCustomConfig = mkCustomConfig properties - } - , pluginModifyDynflags = staticPlugin - } - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Range.hs deleted file mode 100644 index ec61efc27f..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Range.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Wingman.Range where - -import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan) -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Util as FS - - - ------------------------------------------------------------------------------- --- | Convert a DAML compiler Range to a GHC SrcSpan --- TODO(sandy): this doesn't belong here -rangeToSrcSpan :: String -> Range -> SrcSpan -rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing - - -rangeToRealSrcSpan :: String -> Range -> RealSrcSpan -rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) = - mkRealSrcSpan - (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ startLn + 1) (fromIntegral $ startCh + 1)) - (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ endLn + 1) (fromIntegral $ endCh + 1)) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Simplify.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Simplify.hs deleted file mode 100644 index 10eaae97c7..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Simplify.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.Simplify - ( simplify - ) where - -import Data.Generics (GenericT, everywhere, mkT) -import Data.List.Extra (unsnoc) -import Data.Monoid (Endo (..)) -import Development.IDE.GHC.Compat -import GHC.SourceGen (var) -import GHC.SourceGen.Expr (lambda) -import Wingman.CodeGen.Utils -import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet) - - ------------------------------------------------------------------------------- --- | A pattern over the otherwise (extremely) messy AST for lambdas. -pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -pattern Lambda pats body <- - HsLam _ - MG {mg_alts = L _ [L _ - Match { m_pats = fmap fromPatCompat -> pats - , m_grhss = GRHSs {grhssGRHSs = [L _ ( - GRHS _ [] (L _ body))]} - }] - } - where - -- If there are no patterns to bind, just stick in the body - Lambda [] body = body - Lambda pats body = lambda pats body - - - ------------------------------------------------------------------------------- --- | Simplify an expression. -simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify - = (!!3) -- Do three passes; this should be good enough for the limited - -- amount of gas we give to auto - . iterate (everywhere $ foldEndo - [ simplifyEtaReduce - , simplifyRemoveParens - , simplifyCompose - , simplifySingleLet - ]) - - ------------------------------------------------------------------------------- --- | Like 'foldMap' but for endomorphisms. -foldEndo :: Foldable t => t (a -> a) -> a -> a -foldEndo = appEndo . foldMap Endo - - ------------------------------------------------------------------------------- --- | Perform an eta reduction. For example, transforms @\x -> (f g) x@ into --- @f g@. -simplifyEtaReduce :: GenericT -simplifyEtaReduce = mkT $ \case - Lambda - [VarPat _ (L _ pat)] - (HsVar _ (L _ a)) | pat == a -> - var "id" - Lambda - (unsnoc -> Just (pats, VarPat _ (L _ pat))) - (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) - | pat == a - -- We can only perform this simplification if @pat@ is otherwise unused. - , not (containsHsVar pat f) -> - Lambda pats f - x -> x - ------------------------------------------------------------------------------- --- | Eliminates the unnecessary binding in @let a = b in a@ -simplifySingleLet :: GenericT -simplifySingleLet = mkT $ \case - SingleLet bind [] val (HsVar _ (L _ a)) | a == bind -> val - x -> x - - ------------------------------------------------------------------------------- --- | Perform an eta-reducing function composition. For example, transforms --- @\x -> f (g (h x))@ into @f . g . h@. -simplifyCompose :: GenericT -simplifyCompose = mkT $ \case - Lambda - (unsnoc -> Just (pats, VarPat _ (L _ pat))) - (unroll -> (fs@(_:_), HsVar _ (L _ a))) - | pat == a - -- We can only perform this simplification if @pat@ is otherwise unused. - , not (containsHsVar pat fs) -> - Lambda pats (foldr1 (infixCall ".") fs) - x -> x - - ------------------------------------------------------------------------------- --- | Removes unnecessary parentheses on any token that doesn't need them. -simplifyRemoveParens :: GenericT -simplifyRemoveParens = mkT $ \case - HsPar _ (L _ x) | isAtomicHsExpr x -> x - (x :: HsExpr GhcPs) -> x - - ------------------------------------------------------------------------------- --- | Unrolls a right-associative function application of the form --- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@. -unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs) -unroll (HsPar _ (L _ x)) = unroll x -unroll (HsApp _ (L _ f) (L _ a)) = - let (fs, r) = unroll a - in (f : fs, r) -unroll x = ([], x) - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/old/src/Wingman/StaticPlugin.hs deleted file mode 100644 index 42065aa289..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/StaticPlugin.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wingman.StaticPlugin - ( staticPlugin - , metaprogramHoleName - , enableQuasiQuotes - , pattern WingmanMetaprogram - , pattern MetaprogramSyntax - ) where - -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util - -import Ide.Types - -import Data.Data -import Generics.SYB -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Driver.Plugins (purePlugin) -#else -import Plugins (purePlugin) -#endif - -staticPlugin :: DynFlagsModifications -staticPlugin = mempty - { dynFlagsModifyGlobal = - \df -> allowEmptyCaseButWithWarning - $ flip gopt_unset Opt_SortBySubsumHoleFits - $ flip gopt_unset Opt_ShowValidHoleFits - $ df - { refLevelHoleFits = Just 0 - , maxRefHoleFits = Just 0 - , maxValidHoleFits = Just 0 - , staticPlugins = staticPlugins df <> [metaprogrammingPlugin] - } - , dynFlagsModifyParser = enableQuasiQuotes - } - - -pattern MetaprogramSourceText :: SourceText -pattern MetaprogramSourceText = SourceText "wingman-meta-program" - - -pattern WingmanMetaprogram :: FastString -> HsExpr p -pattern WingmanMetaprogram mp <- -#if __GLASGOW_HASKELL__ >= 900 - HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)) - (L _ ( HsVar _ _)) -#else - HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp) - (L _ ( HsVar _ _)) -#endif - - -enableQuasiQuotes :: DynFlags -> DynFlags -enableQuasiQuotes = flip xopt_set QuasiQuotes - - --- | Wingman wants to support destructing of empty cases, but these are a parse --- error by default. So we want to enable 'EmptyCase', but then that leads to --- silent errors without 'Opt_WarnIncompletePatterns'. -allowEmptyCaseButWithWarning :: DynFlags -> DynFlags -allowEmptyCaseButWithWarning = - flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns - - -metaprogrammingPlugin :: StaticPlugin -metaprogrammingPlugin = - StaticPlugin $ PluginWithArgs pluginDefinition [] - where - pluginDefinition = defaultPlugin - { parsedResultAction = worker - , pluginRecompile = purePlugin - } - worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule - worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm } - -mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs -mkMetaprogram ss mp = -#if __GLASGOW_HASKELL__ >= 900 - HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)) -#else - HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp) -#endif - $ L ss - $ HsVar noExtField - $ L ss - $ mkRdrUnqual metaprogramHoleName - -addMetaprogrammingSyntax :: Data a => a -> a -addMetaprogrammingSyntax = - everywhere $ mkT $ \case - L ss (MetaprogramSyntax mp) -> - L ss $ mkMetaprogram ss mp - (x :: LHsExpr GhcPs) -> x - -metaprogramHoleName :: OccName -metaprogramHoleName = mkVarOcc "_$metaprogram" - -pattern MetaprogramSyntax :: FastString -> HsExpr GhcPs -pattern MetaprogramSyntax mp <- - HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp) - where - MetaprogramSyntax mp = - HsSpliceE noExtField $ - HsQuasiQuote - noExtField - (mkRdrUnqual $ mkVarOcc "splice") - (mkRdrUnqual $ mkVarOcc "wingman") - noSrcSpan - mp diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Tactics.hs deleted file mode 100644 index 10d87722cd..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Tactics.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Wingman.Tactics - ( module Wingman.Tactics - , runTactic - ) where - -import Control.Applicative (Alternative(empty), (<|>)) -import Control.Lens ((&), (%~), (<>~)) -import Control.Monad (filterM, unless) -import Control.Monad (when) -import Control.Monad.Extra (anyM) -import Control.Monad.Reader.Class (MonadReader (ask)) -import Control.Monad.State.Strict (StateT(..), runStateT, execStateT) -import Data.Bool (bool) -import Data.Foldable -import Data.Functor ((<&>)) -import Data.Generics.Labels () -import Data.List -import Data.List.Extra (dropEnd, takeEnd) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Traversable (for) -import Development.IDE.GHC.Compat hiding (empty) -import GHC.Exts -import GHC.SourceGen ((@@)) -import GHC.SourceGen.Expr -import Refinery.Tactic -import Refinery.Tactic.Internal -import Wingman.CodeGen -import Wingman.GHC -import Wingman.Judgements -import Wingman.Machinery -import Wingman.Naming -import Wingman.StaticPlugin (pattern MetaprogramSyntax) -import Wingman.Types - - ------------------------------------------------------------------------------- --- | Use something in the hypothesis to fill the hole. -assumption :: TacticsM () -assumption = attemptOn (S.toList . allNames) assume - - ------------------------------------------------------------------------------- --- | Use something named in the hypothesis to fill the hole. -assume :: OccName -> TacticsM () -assume name = rule $ \jdg -> do - case M.lookup name $ hyByName $ jHypothesis jdg of - Just (hi_type -> ty) -> do - unify ty $ jGoal jdg - pure $ - -- This slightly terrible construct is producing a mostly-empty - -- 'Synthesized'; but there is no monoid instance to do something more - -- reasonable for a default value. - (pure (noLoc $ var' name)) - { syn_trace = tracePrim $ "assume " <> occNameString name - , syn_used_vals = S.singleton name <> getAncestry jdg name - } - Nothing -> cut - - ------------------------------------------------------------------------------- --- | Like 'apply', but uses an 'OccName' available in the context --- or the module -use :: Saturation -> OccName -> TacticsM () -use sat occ = do - ctx <- ask - ty <- case lookupNameInContext occ ctx of - Just ty -> pure ty - Nothing -> CType <$> getOccNameType occ - apply sat $ createImportedHyInfo occ ty - - -recursion :: TacticsM () --- TODO(sandy): This tactic doesn't fire for the @AutoThetaFix@ golden test, --- presumably due to running afoul of 'requireConcreteHole'. Look into this! -recursion = requireConcreteHole $ tracing "recursion" $ do - defs <- getCurrentDefinitions - attemptOn (const defs) $ \(name, ty) -> markRecursion $ do - jdg <- goal - -- Peek allows us to look at the extract produced by this block. - peek - ( do - let hy' = recursiveHypothesis defs - ctx <- ask - localTactic (apply Saturated $ HyInfo name RecursivePrv ty) (introduce ctx hy') - <@> fmap (localTactic assumption . filterPosition name) [0..] - ) $ \ext -> do - let pat_vals = jPatHypothesis jdg - -- Make sure that the recursive call contains at least one already-bound - -- pattern value. This ensures it is structurally smaller, and thus - -- suggests termination. - case any (flip M.member pat_vals) $ syn_used_vals ext of - True -> Nothing - False -> Just UnhelpfulRecursion - - -restrictPositionForApplication :: TacticsM () -> TacticsM () -> TacticsM () -restrictPositionForApplication f app = do - -- NOTE(sandy): Safe use of head; context is guaranteed to have a defining - -- binding - name <- head . fmap fst <$> getCurrentDefinitions - f <@> - fmap - (localTactic app . filterPosition name) [0..] - - ------------------------------------------------------------------------------- --- | Introduce a lambda binding every variable. -intros :: TacticsM () -intros = intros' IntroduceAllUnnamed - - -data IntroParams - = IntroduceAllUnnamed - | IntroduceOnlyNamed [OccName] - | IntroduceOnlyUnnamed Int - deriving stock (Eq, Ord, Show) - - ------------------------------------------------------------------------------- --- | Introduce a lambda binding every variable. -intros' - :: IntroParams - -> TacticsM () -intros' params = rule $ \jdg -> do - let g = jGoal jdg - case tacticsSplitFunTy $ unCType g of - (_, _, [], _) -> cut -- failure $ GoalMismatch "intros" g - (_, _, scaledArgs, res) -> do - let args = fmap scaledThing scaledArgs - ctx <- ask - let gen_names = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) args - occs = case params of - IntroduceAllUnnamed -> gen_names - IntroduceOnlyNamed names -> names - IntroduceOnlyUnnamed n -> take n gen_names - num_occs = length occs - top_hole = isTopHole ctx jdg - bindings = zip occs $ coerce args - bound_occs = fmap fst bindings - hy' = lambdaHypothesis top_hole bindings - jdg' = introduce ctx hy' - $ withNewGoal (CType $ mkVisFunTys (drop num_occs scaledArgs) res) jdg - ext <- newSubgoal jdg' - pure $ - ext - & #syn_trace %~ rose ("intros {" <> intercalate ", " (fmap show bound_occs) <> "}") - . pure - & #syn_scoped <>~ hy' - & #syn_val %~ noLoc . lambda (fmap bvar' bound_occs) . unLoc - - ------------------------------------------------------------------------------- --- | Introduce a single lambda argument, and immediately destruct it. -introAndDestruct :: TacticsM () -introAndDestruct = do - hy <- fmap unHypothesis $ hyDiff $ intros' $ IntroduceOnlyUnnamed 1 - -- This case should never happen, but I'm validating instead of parsing. - -- Adding a log to be reminded if the invariant ever goes false. - -- - -- But note that this isn't a game-ending bug. In the worst case, we'll - -- accidentally bind too many variables, and incorrectly unify between them. - -- Which means some GADT cases that should be eliminated won't be --- not the - -- end of the world. - unless (length hy == 1) $ - traceMX "BUG: Introduced too many variables for introAndDestruct! Please report me if you see this! " hy - - for_ hy destruct - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. -destructAuto :: HyInfo CType -> TacticsM () -destructAuto hi = requireConcreteHole $ tracing "destruct(auto)" $ do - jdg <- goal - let subtactic = destructOrHomoAuto hi - case isPatternMatch $ hi_provenance hi of - True -> - pruning subtactic $ \jdgs -> - let getHyTypes = S.fromList . fmap hi_type . unHypothesis . jHypothesis - new_hy = foldMap getHyTypes jdgs - old_hy = getHyTypes jdg - in case S.null $ new_hy S.\\ old_hy of - True -> Just $ UnhelpfulDestruct $ hi_name hi - False -> Nothing - False -> subtactic - - ------------------------------------------------------------------------------- --- | When running auto, in order to prune the auto search tree, we try --- a homomorphic destruct whenever possible. If that produces any results, we --- can probably just prune the other side. -destructOrHomoAuto :: HyInfo CType -> TacticsM () -destructOrHomoAuto hi = tracing "destructOrHomoAuto" $ do - jdg <- goal - let g = unCType $ jGoal jdg - ty = unCType $ hi_type hi - - attemptWhen - (rule $ destruct' False (\dc jdg -> - buildDataCon False jdg dc $ snd $ splitAppTys g) hi) - (rule $ destruct' False (const newSubgoal) hi) - $ case (splitTyConApp_maybe g, splitTyConApp_maybe ty) of - (Just (gtc, _), Just (tytc, _)) -> gtc == tytc - _ -> False - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. -destruct :: HyInfo CType -> TacticsM () -destruct hi = requireConcreteHole $ tracing "destruct(user)" $ - rule $ destruct' False (const newSubgoal) hi - - ------------------------------------------------------------------------------- --- | Case split, and leave holes in the matches. Performs record punning. -destructPun :: HyInfo CType -> TacticsM () -destructPun hi = requireConcreteHole $ tracing "destructPun(user)" $ - rule $ destruct' True (const newSubgoal) hi - - ------------------------------------------------------------------------------- --- | Case split, using the same data constructor in the matches. -homo :: HyInfo CType -> TacticsM () -homo hi = requireConcreteHole . tracing "homo" $ do - jdg <- goal - let g = jGoal jdg - - -- Ensure that every data constructor in the domain type is covered in the - -- codomain; otherwise 'homo' will produce an ill-typed program. - case uncoveredDataCons (coerce $ hi_type hi) (coerce g) of - Just uncovered_dcs -> - unless (S.null uncovered_dcs) $ - failure $ TacticPanic "Can't cover every datacon in domain" - _ -> failure $ TacticPanic "Unable to fetch datacons" - - rule - $ destruct' - False - (\dc jdg -> buildDataCon False jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg) - hi - - ------------------------------------------------------------------------------- --- | LambdaCase split, and leave holes in the matches. -destructLambdaCase :: TacticsM () -destructLambdaCase = - tracing "destructLambdaCase" $ rule $ destructLambdaCase' False (const newSubgoal) - - ------------------------------------------------------------------------------- --- | LambdaCase split, using the same data constructor in the matches. -homoLambdaCase :: TacticsM () -homoLambdaCase = - tracing "homoLambdaCase" $ - rule $ destructLambdaCase' False $ \dc jdg -> - buildDataCon False jdg dc - . snd - . splitAppTys - . unCType - $ jGoal jdg - - -newtype Saturation = Unsaturated Int - deriving (Eq, Ord, Show) - -pattern Saturated :: Saturation -pattern Saturated = Unsaturated 0 - - -apply :: Saturation -> HyInfo CType -> TacticsM () -apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do - jdg <- goal - let g = jGoal jdg - ty = unCType $ hi_type hi - func = hi_name hi - ty' <- freshTyvars ty - let (_, theta, all_args, ret) = tacticsSplitFunTy ty' - saturated_args = dropEnd n all_args - unsaturated_args = takeEnd n all_args - rule $ \jdg -> do - unify g (CType $ mkVisFunTys unsaturated_args ret) - learnFromFundeps theta - ext - <- fmap unzipTrace - $ traverse ( newSubgoal - . blacklistingDestruct - . flip withNewGoal jdg - . CType - . scaledThing - ) saturated_args - pure $ - ext - & #syn_used_vals %~ (\x -> S.insert func x <> getAncestry jdg func) - & #syn_val %~ mkApply func . fmap unLoc - -application :: TacticsM () -application = overFunctions $ apply Saturated - - ------------------------------------------------------------------------------- --- | Choose between each of the goal's data constructors. -split :: TacticsM () -split = tracing "split(user)" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Nothing -> failure $ GoalMismatch "split" g - Just (dcs, _) -> choice $ fmap splitDataCon dcs - - ------------------------------------------------------------------------------- --- | Choose between each of the goal's data constructors. Different than --- 'split' because it won't split a data con if it doesn't result in any new --- goals. -splitAuto :: TacticsM () -splitAuto = requireConcreteHole $ tracing "split(auto)" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Nothing -> failure $ GoalMismatch "split" g - Just (dcs, _) -> do - case isSplitWhitelisted jdg of - True -> choice $ fmap splitDataCon dcs - False -> do - choice $ flip fmap dcs $ \dc -> requireNewHoles $ - splitDataCon dc - - ------------------------------------------------------------------------------- --- | Like 'split', but only works if there is a single matching data --- constructor for the goal. -splitSingle :: TacticsM () -splitSingle = tracing "splitSingle" $ do - jdg <- goal - let g = jGoal jdg - case tacticsGetDataCons $ unCType g of - Just ([dc], _) -> do - splitDataCon dc - _ -> failure $ GoalMismatch "splitSingle" g - ------------------------------------------------------------------------------- --- | Like 'split', but prunes any data constructors which have holes. -obvious :: TacticsM () -obvious = tracing "obvious" $ do - pruning split $ bool (Just NoProgress) Nothing . null - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -sorry :: TacticsM () -sorry = exact $ var' $ mkVarOcc "_" - - ------------------------------------------------------------------------------- --- | Sorry leaves a hole in its extract -metaprogram :: TacticsM () -metaprogram = exact $ MetaprogramSyntax "" - - ------------------------------------------------------------------------------- --- | Allow the given tactic to proceed if and only if it introduces holes that --- have a different goal than current goal. -requireNewHoles :: TacticsM () -> TacticsM () -requireNewHoles m = do - jdg <- goal - pruning m $ \jdgs -> - case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of - True -> Nothing - False -> Just NoProgress - - ------------------------------------------------------------------------------- --- | Attempt to instantiate the given ConLike to solve the goal. --- --- INVARIANT: Assumes the given ConLike is appropriate to construct the type --- with. -splitConLike :: ConLike -> TacticsM () -splitConLike dc = - requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do - let g = jGoal jdg - case splitTyConApp_maybe $ unCType g of - Just (_, apps) -> do - buildDataCon True (unwhitelistingSplit jdg) dc apps - Nothing -> cut -- failure $ GoalMismatch "splitDataCon" g - ------------------------------------------------------------------------------- --- | Attempt to instantiate the given data constructor to solve the goal. --- --- INVARIANT: Assumes the given datacon is appropriate to construct the type --- with. -splitDataCon :: DataCon -> TacticsM () -splitDataCon = splitConLike . RealDataCon - - ------------------------------------------------------------------------------- --- | Perform a case split on each top-level argument. Used to implement the --- "Destruct all function arguments" action. -destructAll :: TacticsM () -destructAll = do - jdg <- goal - let args = fmap fst - $ sortOn snd - $ mapMaybe (\(hi, prov) -> - case prov of - TopLevelArgPrv _ idx _ -> pure (hi, idx) - _ -> Nothing - ) - $ fmap (\hi -> (hi, hi_provenance hi)) - $ filter (isAlgType . unCType . hi_type) - $ unHypothesis - $ jHypothesis jdg - for_ args $ \arg -> do - subst <- getSubstForJudgement =<< goal - destruct $ fmap (coerce substTy subst) arg - --------------------------------------------------------------------------------- --- | User-facing tactic to implement "Use constructor " -userSplit :: OccName -> TacticsM () -userSplit occ = do - jdg <- goal - let g = jGoal jdg - -- TODO(sandy): It's smelly that we need to find the datacon to generate the - -- code action, send it as a string, and then look it up again. Can we push - -- this over LSP somehow instead? - case splitTyConApp_maybe $ unCType g of - Just (tc, _) -> do - case find (sloppyEqOccName occ . occName . dataConName) - $ tyConDataCons tc of - Just dc -> splitDataCon dc - Nothing -> failure $ NotInScope occ - Nothing -> failure $ NotInScope occ - - ------------------------------------------------------------------------------- --- | @matching f@ takes a function from a judgement to a @Tactic@, and --- then applies the resulting @Tactic@. -matching :: (Judgement -> TacticsM ()) -> TacticsM () -matching f = TacticT $ StateT $ \s -> runStateT (unTacticT $ f s) s - - -attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM () -attemptOn getNames tac = matching (choice . fmap tac . getNames) - - -localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a -localTactic t f = do - TacticT $ StateT $ \jdg -> - runStateT (unTacticT t) $ f jdg - - -refine :: TacticsM () -refine = intros <%> splitSingle - - -auto' :: Int -> TacticsM () -auto' 0 = failure OutOfGas -auto' n = do - let loop = auto' (n - 1) - try intros - assumption <|> - choice - [ overFunctions $ \fname -> do - requireConcreteHole $ apply Saturated fname - loop - , overAlgebraicTerms $ \aname -> do - destructAuto aname - loop - , splitAuto >> loop - , recursion - ] - -overFunctions :: (HyInfo CType -> TacticsM ()) -> TacticsM () -overFunctions = - attemptOn $ filter (isFunction . unCType . hi_type) - . unHypothesis - . jHypothesis - -overAlgebraicTerms :: (HyInfo CType -> TacticsM ()) -> TacticsM () -overAlgebraicTerms = - attemptOn jAcceptableDestructTargets - - -allNames :: Judgement -> Set OccName -allNames = hyNamesInScope . jHypothesis - - -applyMethod :: Class -> PredType -> OccName -> TacticsM () -applyMethod cls df method_name = do - case find ((== method_name) . occName) $ classMethods cls of - Just method -> do - let (_, apps) = splitAppTys df - let ty = piResultTys (idType method) apps - apply Saturated $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty - Nothing -> failure $ NotInScope method_name - - -applyByName :: OccName -> TacticsM () -applyByName name = do - g <- goal - choice $ unHypothesis (jHypothesis g) <&> \hi -> - case hi_name hi == name of - True -> apply Saturated hi - False -> empty - - ------------------------------------------------------------------------------- --- | Make a function application where the function being applied itself is --- a hole. -applyByType :: Type -> TacticsM () -applyByType ty = tracing ("applyByType " <> show ty) $ do - jdg <- goal - let g = jGoal jdg - ty' <- freshTyvars ty - let (_, _, args, ret) = tacticsSplitFunTy ty' - rule $ \jdg -> do - unify g (CType ret) - ext - <- fmap unzipTrace - $ traverse ( newSubgoal - . blacklistingDestruct - . flip withNewGoal jdg - . CType - . scaledThing - ) args - app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg - pure $ - fmap noLoc $ - foldl' (@@) - <$> fmap unLoc app - <*> fmap (fmap unLoc) ext - - ------------------------------------------------------------------------------- --- | Make an n-ary function call of the form --- @(_ :: forall a b. a -> a -> b) _ _@. -nary :: Int -> TacticsM () -nary n = do - a <- newUnivar - b <- newUnivar - applyByType $ mkVisFunTys (replicate n $ unrestricted a) b - - -self :: TacticsM () -self = - fmap listToMaybe getCurrentDefinitions >>= \case - Just (self, _) -> useNameFromContext (apply Saturated) self - Nothing -> failure $ TacticPanic "no defining function" - - ------------------------------------------------------------------------------- --- | Perform a catamorphism when destructing the given 'HyInfo'. This will --- result in let binding, making values that call the defining function on each --- destructed value. -cata :: HyInfo CType -> TacticsM () -cata hi = do - (_, _, calling_args, _) - <- tacticsSplitFunTy . unCType <$> getDefiningType - freshened_args <- traverse (freshTyvars . scaledThing) calling_args - diff <- hyDiff $ destruct hi - - -- For for every destructed term, check to see if it can unify with any of - -- the arguments to the calling function. If it doesn't, we don't try to - -- perform a cata on it. - unifiable_diff <- flip filterM (unHypothesis diff) $ \hi -> - flip anyM freshened_args $ \ty -> - canUnify (hi_type hi) $ CType ty - - rule $ - letForEach - (mkVarOcc . flip mappend "_c" . occNameString) - (\hi -> self >> commit (assume $ hi_name hi) assumption) - $ Hypothesis unifiable_diff - - -letBind :: [OccName] -> TacticsM () -letBind occs = do - jdg <- goal - occ_tys <- for occs - $ \occ - -> fmap (occ, ) - $ fmap (<$ jdg) - $ fmap CType newUnivar - rule $ nonrecLet occ_tys - - ------------------------------------------------------------------------------- --- | Deeply nest an unsaturated function onto itself -nested :: OccName -> TacticsM () -nested = deepening . use (Unsaturated 1) - - ------------------------------------------------------------------------------- --- | Repeatedly bind a tactic on its first hole -deep :: Int -> TacticsM () -> TacticsM () -deep 0 _ = pure () -deep n t = foldr1 bindOne $ replicate n t - - ------------------------------------------------------------------------------- --- | Try 'deep' for arbitrary depths. -deepening :: TacticsM () -> TacticsM () -deepening t = - asum $ fmap (flip deep t) [0 .. 100] - - -bindOne :: TacticsM a -> TacticsM a -> TacticsM a -bindOne t t1 = t <@> [t1] - - -collapse :: TacticsM () -collapse = do - g <- goal - let terms = unHypothesis $ hyFilter ((jGoal g ==) . hi_type) $ jLocalHypothesis g - case terms of - [hi] -> assume $ hi_name hi - _ -> nary (length terms) <@> fmap (assume . hi_name) terms - - -with_arg :: TacticsM () -with_arg = rule $ \jdg -> do - let g = jGoal jdg - fresh_ty <- newUnivar - a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg - f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [unrestricted fresh_ty] g) jdg - pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a - - ------------------------------------------------------------------------------- --- | Determine the difference in hypothesis due to running a tactic. Also, it --- runs the tactic. -hyDiff :: TacticsM () -> TacticsM (Hypothesis CType) -hyDiff m = do - g <- unHypothesis . jEntireHypothesis <$> goal - let g_len = length g - m - g' <- unHypothesis . jEntireHypothesis <$> goal - pure $ Hypothesis $ take (length g' - g_len) g' - - ------------------------------------------------------------------------------- --- | Attempt to run the given tactic in "idiom bracket" mode. For example, if --- the current goal is --- --- (_ :: [r]) --- --- then @idiom apply@ will remove the applicative context, resulting in a hole: --- --- (_ :: r) --- --- and then use @apply@ to solve it. Let's say this results in: --- --- (f (_ :: a) (_ :: b)) --- --- Finally, @idiom@ lifts this back into the original applicative: --- --- (f <$> (_ :: [a]) <*> (_ :: [b])) --- --- Idiom will fail fast if the current goal doesn't have an applicative --- instance. -idiom :: TacticsM () -> TacticsM () -idiom m = do - jdg <- goal - let hole = unCType $ jGoal jdg - when (isFunction hole) $ - failure $ GoalMismatch "idiom" $ jGoal jdg - case splitAppTy_maybe hole of - Just (applic, ty) -> do - minst <- getKnownInstance (mkClsOcc "Applicative") - . pure - $ applic - case minst of - Nothing -> failure $ GoalMismatch "idiom" $ CType applic - Just (_, _) -> do - rule $ \jdg -> do - expr <- subgoalWith (withNewGoal (CType ty) jdg) m - case unLoc $ syn_val expr of - HsApp{} -> pure $ fmap idiomize expr - RecordCon{} -> pure $ fmap idiomize expr - _ -> unsolvable $ GoalMismatch "idiom" $ jGoal jdg - rule $ newSubgoal . withModifiedGoal (CType . mkAppTy applic . unCType) - Nothing -> - failure $ GoalMismatch "idiom" $ jGoal jdg - -subgoalWith :: Judgement -> TacticsM () -> RuleM (Synthesized (LHsExpr GhcPs)) -subgoalWith jdg t = RuleT $ flip execStateT jdg $ unTacticT t - diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Types.hs deleted file mode 100644 index 621cc9752e..0000000000 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Types.hs +++ /dev/null @@ -1,562 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Wingman.Types - ( module Wingman.Types - , module Wingman.Debug - , OccName - , Name - , Type - , TyVar - , Span - ) where - -import Control.Lens hiding (Context) -import Control.Monad.Reader -import Control.Monad.State -import qualified Control.Monad.State.Strict as Strict -import Data.Coerce -import Data.Function -import Data.Generics (mkM, everywhereM, Data, Typeable) -import Data.Generics.Labels () -import Data.Generics.Product (field) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tree -import Development.IDE (Range) -import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (Node) -import qualified Development.IDE.GHC.Compat.Util as Util -import Development.IDE.GHC.Orphans () -import GHC.Exts (fromString) -import GHC.Generics -import GHC.SourceGen (var) -import Refinery.ProofState -import Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT)) -import System.IO.Unsafe (unsafePerformIO) -import Wingman.Debug -import Data.IORef - - ------------------------------------------------------------------------------- --- | The list of tactics exposed to the outside world. These are attached to --- actual tactics via 'commandTactic' and are contextually provided to the --- editor via 'commandProvider'. -data TacticCommand - = Auto - | Intros - | IntroAndDestruct - | Destruct - | DestructPun - | Homomorphism - | DestructLambdaCase - | HomomorphismLambdaCase - | DestructAll - | UseDataCon - | Refine - | BeginMetaprogram - | RunMetaprogram - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Generate a title for the command. -tacticTitle :: TacticCommand -> T.Text -> T.Text -tacticTitle = (mappend "Wingman: " .) . go - where - go Auto _ = "Attempt to fill hole" - go Intros _ = "Introduce lambda" - go IntroAndDestruct _ = "Introduce and destruct term" - go Destruct var = "Case split on " <> var - go DestructPun var = "Split on " <> var <> " with NamedFieldPuns" - go Homomorphism var = "Homomorphic case split on " <> var - go DestructLambdaCase _ = "Lambda case split" - go HomomorphismLambdaCase _ = "Homomorphic lambda case split" - go DestructAll _ = "Split all function arguments" - go UseDataCon dcon = "Use constructor " <> dcon - go Refine _ = "Refine hole" - go BeginMetaprogram _ = "Use custom tactic block" - go RunMetaprogram _ = "Run custom tactic" - - ------------------------------------------------------------------------------- --- | Plugin configuration for tactics -data Config = Config - { cfg_max_use_ctor_actions :: Int - , cfg_timeout_seconds :: Int - , cfg_auto_gas :: Int - , cfg_proofstate_styling :: Bool - } - deriving (Eq, Ord, Show) - -emptyConfig :: Config -emptyConfig = Config - { cfg_max_use_ctor_actions = 5 - , cfg_timeout_seconds = 2 - , cfg_auto_gas = 4 - , cfg_proofstate_styling = True - } - ------------------------------------------------------------------------------- --- | A wrapper around 'Type' which supports equality and ordering. -newtype CType = CType { unCType :: Type } - deriving stock (Data, Typeable) - -instance Eq CType where - (==) = eqType `on` unCType - -instance Ord CType where - compare = nonDetCmpType `on` unCType - -instance Show CType where - show = unsafeRender . unCType - -instance Show Name where - show = unsafeRender - -instance Show Type where - show = unsafeRender - -instance Show Var where - show = unsafeRender - -instance Show TCvSubst where - show = unsafeRender - -instance Show DataCon where - show = unsafeRender - -instance Show Class where - show = unsafeRender - -instance Show (HsExpr GhcPs) where - show = unsafeRender - -instance Show (HsExpr GhcTc) where - show = unsafeRender - -instance Show (HsDecl GhcPs) where - show = unsafeRender - -instance Show (Pat GhcPs) where - show = unsafeRender - -instance Show (LHsSigType GhcPs) where - show = unsafeRender - -instance Show TyCon where - show = unsafeRender - -instance Show ConLike where - show = unsafeRender - -instance Show LexicalFixity where - show = unsafeRender - - ------------------------------------------------------------------------------- --- | The state that should be shared between subgoals. Extracts move towards --- the root, judgments move towards the leaves, and the state moves *sideways*. -data TacticState = TacticState - { ts_skolems :: !(Set TyVar) - -- ^ The known skolems. - , ts_unifier :: !TCvSubst - , ts_unique_gen :: !UniqSupply - } deriving stock (Show, Generic) - -instance Show UniqSupply where - show _ = "" - - ------------------------------------------------------------------------------- --- | A 'UniqSupply' to use in 'defaultTacticState' -unsafeDefaultUniqueSupply :: UniqSupply -unsafeDefaultUniqueSupply = - unsafePerformIO $ mkSplitUniqSupply 'w' -{-# NOINLINE unsafeDefaultUniqueSupply #-} - - -defaultTacticState :: TacticState -defaultTacticState = - TacticState - { ts_skolems = mempty - , ts_unifier = emptyTCvSubst - , ts_unique_gen = unsafeDefaultUniqueSupply - } - - ------------------------------------------------------------------------------- --- | Generate a new 'Unique' -freshUnique :: MonadState TacticState m => m Util.Unique -freshUnique = do - (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen - modify' $! field @"ts_unique_gen" .~ supply - pure uniq - - ------------------------------------------------------------------------------- --- | Describes where hypotheses came from. Used extensively to prune stupid --- solutions from the search space. -data Provenance - = -- | An argument given to the topmost function that contains the current - -- hole. Recursive calls are restricted to values whose provenance lines up - -- with the same argument. - TopLevelArgPrv - OccName -- ^ Binding function - Int -- ^ Argument Position - Int -- ^ of how many arguments total? - -- | A binding created in a pattern match. - | PatternMatchPrv PatVal - -- | A class method from the given context. - | ClassMethodPrv - (Uniquely Class) -- ^ Class - -- | A binding explicitly written by the user. - | UserPrv - -- | A binding explicitly imported by the user. - | ImportPrv - -- | The recursive hypothesis. Present only in the context of the recursion - -- tactic. - | RecursivePrv - -- | A hypothesis which has been disallowed for some reason. It's important - -- to keep these in the hypothesis set, rather than filtering it, in order - -- to continue tracking downstream provenance. - | DisallowedPrv DisallowReason Provenance - deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Why was a hypothesis disallowed? -data DisallowReason - = WrongBranch Int - | Shadowed - | RecursiveCall - | AlreadyDestructed - deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Provenance of a pattern value. -data PatVal = PatVal - { pv_scrutinee :: Maybe OccName - -- ^ Original scrutinee which created this PatVal. Nothing, for lambda - -- case. - , pv_ancestry :: Set OccName - -- ^ The set of values which had to be destructed to discover this term. - -- Always contains the scrutinee. - , pv_datacon :: Uniquely ConLike - -- ^ The datacon which introduced this term. - , pv_position :: Int - -- ^ The position of this binding in the datacon's arguments. - } deriving stock (Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | A wrapper which uses a 'Uniquable' constraint for providing 'Eq' and 'Ord' --- instances. -newtype Uniquely a = Uniquely { getViaUnique :: a } - deriving Show via a - deriving stock (Data, Typeable) - -instance Util.Uniquable a => Eq (Uniquely a) where - (==) = (==) `on` Util.getUnique . getViaUnique - -instance Util.Uniquable a => Ord (Uniquely a) where - compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique - - --- NOTE(sandy): The usage of list here is mostly for convenience, but if it's --- ever changed, make sure to correspondingly update --- 'jAcceptableDestructTargets' so that it correctly identifies newly --- introduced terms. -newtype Hypothesis a = Hypothesis - { unHypothesis :: [HyInfo a] - } - deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable) - deriving newtype (Semigroup, Monoid) - - ------------------------------------------------------------------------------- --- | The provenance and type of a hypothesis term. -data HyInfo a = HyInfo - { hi_name :: OccName - , hi_provenance :: Provenance - , hi_type :: a - } - deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable) - - ------------------------------------------------------------------------------- --- | Map a function over the provenance. -overProvenance :: (Provenance -> Provenance) -> HyInfo a -> HyInfo a -overProvenance f (HyInfo name prv ty) = HyInfo name (f prv) ty - - ------------------------------------------------------------------------------- --- | The current bindings and goal for a hole to be filled by refinery. -data Judgement' a = Judgement - { _jHypothesis :: !(Hypothesis a) - , _jBlacklistDestruct :: !Bool - , _jWhitelistSplit :: !Bool - , _jIsTopHole :: !Bool - , _jGoal :: !a - , j_coercion :: TCvSubst - } - deriving stock (Generic, Functor, Show) - -type Judgement = Judgement' CType - - -newtype ExtractM a = ExtractM { unExtractM :: ReaderT Context IO a } - deriving newtype (Functor, Applicative, Monad, MonadReader Context) - ------------------------------------------------------------------------------- --- | Used to ensure hole names are unique across invocations of runTactic -globalHoleRef :: IORef Int -globalHoleRef = unsafePerformIO $ newIORef 10 -{-# NOINLINE globalHoleRef #-} - -instance MonadExtract Int (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM where - hole = do - u <- lift $ ExtractM $ lift $ - readIORef globalHoleRef <* modifyIORef' globalHoleRef (+ 1) - pure - ( u - , pure . noLoc $ var $ fromString $ occNameString $ occName $ mkMetaHoleName u - ) - - unsolvableHole _ = hole - - -instance MonadReader r m => MonadReader r (TacticT jdg ext err s m) where - ask = TacticT $ lift $ Effect $ asks pure - local f (TacticT m) = TacticT $ Strict.StateT $ \jdg -> - Effect $ local f $ pure $ Strict.runStateT m jdg - -instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where - ask = RuleT $ Effect $ asks Axiom - local f (RuleT m) = RuleT $ Effect $ local f $ pure m - -mkMetaHoleName :: Int -> RdrName -mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u) - -instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where - -- TODO(sandy): This join is to combine the synthesizeds - substMeta u val a = join $ a <&> - everywhereM (mkM $ \case - (L _ (HsVar _ (L _ name))) - | name == mkMetaHoleName u -> val - (t :: LHsExpr GhcPs) -> pure t) - - ------------------------------------------------------------------------------- --- | Reasons a tactic might fail. -data TacticError - = OutOfGas - | GoalMismatch String CType - | NoProgress - | NoApplicableTactic - | UnhelpfulRecursion - | UnhelpfulDestruct OccName - | TooPolymorphic - | NotInScope OccName - | TacticPanic String - deriving (Eq) - -instance Show TacticError where - show OutOfGas = "Auto ran out of gas" - show (GoalMismatch tac (CType typ)) = - mconcat - [ "The tactic " - , tac - , " doesn't apply to goal type " - , unsafeRender typ - ] - show NoProgress = - "Unable to make progress" - show NoApplicableTactic = - "No tactic could be applied" - show UnhelpfulRecursion = - "Recursion wasn't productive" - show (UnhelpfulDestruct n) = - "Destructing patval " <> show n <> " leads to no new types" - show TooPolymorphic = - "The tactic isn't applicable because the goal is too polymorphic" - show (NotInScope name) = - "Tried to do something with the out of scope name " <> show name - show (TacticPanic err) = - "Tactic panic: " <> err - - ------------------------------------------------------------------------------- -type TacticsM = TacticT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM -type RuleM = RuleT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM -type Rule = RuleM (Synthesized (LHsExpr GhcPs)) - -type Trace = Rose String - ------------------------------------------------------------------------------- --- | The extract for refinery. Represents a "synthesized attribute" in the --- context of attribute grammars. In essence, 'Synthesized' describes --- information we'd like to pass from leaves of the tactics search upwards. --- This includes the actual AST we've generated (in 'syn_val'). -data Synthesized a = Synthesized - { syn_trace :: Trace - -- ^ A tree describing which tactics were used produce the 'syn_val'. - -- Mainly for debugging when you get the wrong answer, to see the other - -- things it tried. - , syn_scoped :: Hypothesis CType - -- ^ All of the bindings created to produce the 'syn_val'. - , syn_used_vals :: Set OccName - -- ^ The values used when synthesizing the 'syn_val'. - , syn_recursion_count :: Sum Int - -- ^ The number of recursive calls - , syn_val :: a - } - deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) - -instance Monad Synthesized where - return = pure - Synthesized tr1 sc1 uv1 rc1 a >>= f = - case f a of - Synthesized tr2 sc2 uv2 rc2 b -> - Synthesized - { syn_trace = tr1 <> tr2 - , syn_scoped = sc1 <> sc2 - , syn_used_vals = uv1 <> uv2 - , syn_recursion_count = rc1 <> rc2 - , syn_val = b - } - -mapTrace :: (Trace -> Trace) -> Synthesized a -> Synthesized a -mapTrace f (Synthesized tr sc uv rc a) = Synthesized (f tr) sc uv rc a - - ------------------------------------------------------------------------------- --- | This might not be lawful, due to the semigroup on 'Trace' maybe not being --- lawful. But that's only for debug output, so it's not anything I'm concerned --- about. -instance Applicative Synthesized where - pure = Synthesized mempty mempty mempty mempty - Synthesized tr1 sc1 uv1 rc1 f <*> Synthesized tr2 sc2 uv2 rc2 a = - Synthesized (tr1 <> tr2) (sc1 <> sc2) (uv1 <> uv2) (rc1 <> rc2) $ f a - - ------------------------------------------------------------------------------- --- | The Reader context of tactics and rules -data Context = Context - { ctxDefiningFuncs :: [(OccName, CType)] - -- ^ The functions currently being defined - , ctxModuleFuncs :: [(OccName, CType)] - -- ^ Everything defined in the current module - , ctxConfig :: Config - , ctxInstEnvs :: InstEnvs - , ctxFamInstEnvs :: FamInstEnvs - , ctxTheta :: Set CType - , ctx_hscEnv :: HscEnv - , ctx_occEnv :: OccEnv [GlobalRdrElt] - , ctx_module :: Module - } - -instance Show Context where - show Context{..} = mconcat - [ "Context " - , showsPrec 10 ctxDefiningFuncs "" - , showsPrec 10 ctxModuleFuncs "" - , showsPrec 10 ctxConfig "" - , showsPrec 10 ctxTheta "" - ] - - ------------------------------------------------------------------------------- --- | An empty context -emptyContext :: Context -emptyContext - = Context - { ctxDefiningFuncs = mempty - , ctxModuleFuncs = mempty - , ctxConfig = emptyConfig - , ctxFamInstEnvs = mempty - , ctxInstEnvs = InstEnvs mempty mempty mempty - , ctxTheta = mempty - , ctx_hscEnv = error "empty hsc env from emptyContext" - , ctx_occEnv = emptyOccEnv - , ctx_module = error "empty module from emptyContext" - } - - -newtype Rose a = Rose (Tree a) - deriving stock (Eq, Functor, Generic, Data, Typeable) - -instance Show (Rose String) where - show = unlines . dropEveryOther . lines . drawTree . coerce - -dropEveryOther :: [a] -> [a] -dropEveryOther [] = [] -dropEveryOther [a] = [a] -dropEveryOther (a : _ : as) = a : dropEveryOther as - ------------------------------------------------------------------------------- --- | This might not be lawful! I didn't check, and it feels sketchy. -instance (Eq a, Monoid a) => Semigroup (Rose a) where - Rose (Node a as) <> Rose (Node b bs) = Rose $ Node (a <> b) (as <> bs) - sconcat (a :| as) = rose mempty $ a : as - -instance (Eq a, Monoid a) => Monoid (Rose a) where - mempty = Rose $ Node mempty mempty - -rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a -rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs -rose a rs = Rose $ Node a $ coerce rs - - ------------------------------------------------------------------------------- --- | The results of 'Wingman.Machinery.runTactic' -data RunTacticResults = RunTacticResults - { rtr_trace :: Trace - , rtr_extract :: LHsExpr GhcPs - , rtr_subgoals :: [Judgement] - , rtr_other_solns :: [Synthesized (LHsExpr GhcPs)] - , rtr_jdg :: Judgement - , rtr_ctx :: Context - , rtr_timed_out :: Bool - } deriving Show - - -data AgdaMatch = AgdaMatch - { amPats :: [Pat GhcPs] - , amBody :: HsExpr GhcPs - } - deriving (Show) - - -data UserFacingMessage - = NotEnoughGas - | TacticErrors - | TimedOut - | NothingToDo - | InfrastructureError Text - deriving Eq - -instance Show UserFacingMessage where - show NotEnoughGas = "Wingman ran out of gas when trying to find a solution. \nTry increasing the `auto_gas` setting." - show TacticErrors = "Wingman couldn't find a solution" - show TimedOut = "Wingman timed out while finding a solution. \nYou might get a better result if you increase the timeout duration." - show NothingToDo = "Nothing to do" - show (InfrastructureError t) = "Internal error: " <> T.unpack t - - -data HoleSort = Hole | Metaprogram T.Text - deriving (Eq, Ord, Show) - -data HoleJudgment = HoleJudgment - { hj_range :: Tracked 'Current Range - , hj_jdg :: Judgement - , hj_ctx :: Context - , hj_dflags :: DynFlags - , hj_hole_sort :: HoleSort - } - diff --git a/plugins/hls-tactics-plugin/old/test/AutoTupleSpec.hs b/plugins/hls-tactics-plugin/old/test/AutoTupleSpec.hs deleted file mode 100644 index 11ba11e2ae..0000000000 --- a/plugins/hls-tactics-plugin/old/test/AutoTupleSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE NumDecimals #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module AutoTupleSpec where - -import Control.Monad (replicateM) -import Control.Monad.State (evalState) -import Data.Either (isRight) -import Development.IDE.GHC.Compat.Core ( mkVarOcc, mkBoxedTupleTy ) -import System.IO.Unsafe -import Test.Hspec -import Test.QuickCheck -import Wingman.Judgements (mkFirstJudgement) -import Wingman.Machinery -import Wingman.Tactics (auto') -import Wingman.Types - - -spec :: Spec -spec = describe "auto for tuple" $ do - it "should always be able to discover an auto solution" $ do - property $ do - -- Pick some number of variables - n <- choose (1, 7) - let vars = flip evalState defaultTacticState - $ replicateM n newUnivar - -- Pick a random ordering - in_vars <- shuffle vars - -- Randomly associate them into tuple types - in_type <- mkBoxedTupleTy - . fmap mkBoxedTupleTy - <$> randomGroups in_vars - out_type <- mkBoxedTupleTy - . fmap mkBoxedTupleTy - <$> randomGroups vars - pure $ - -- We should always be able to find a solution - unsafePerformIO - (runTactic - 2e6 - emptyContext - (mkFirstJudgement - emptyContext - (Hypothesis $ pure $ HyInfo (mkVarOcc "x") UserPrv $ CType in_type) - True - out_type) - (auto' $ n * 2)) `shouldSatisfy` isRight - - -randomGroups :: [a] -> Gen [[a]] -randomGroups [] = pure [] -randomGroups as = do - n <- choose (1, length as) - (:) <$> pure (take n as) - <*> randomGroups (drop n as) - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/AutoSpec.hs deleted file mode 100644 index 4075183ee6..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/AutoSpec.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.AutoSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let autoTest = goldenTest Auto "" - autoTestNoWhitespace = goldenTestNoWhitespace Auto "" - - describe "golden" $ do - autoTest 11 8 "AutoSplitGADT" - autoTest 2 11 "GoldenEitherAuto" - autoTest 4 12 "GoldenJoinCont" - autoTest 3 11 "GoldenIdentityFunctor" - autoTest 7 11 "GoldenIdTypeFam" - autoTest 2 15 "GoldenEitherHomomorphic" - autoTest 2 8 "GoldenNote" - autoTest 2 12 "GoldenPureList" - autoTest 2 12 "GoldenListFmap" - autoTest 2 13 "GoldenFromMaybe" - autoTest 2 10 "GoldenFoldr" - autoTest 2 8 "GoldenSwap" - autoTest 4 11 "GoldenFmapTree" - autoTest 7 13 "GoldenGADTAuto" - autoTest 2 12 "GoldenSwapMany" - autoTest 4 12 "GoldenBigTuple" - autoTest 2 10 "GoldenShow" - autoTest 2 15 "GoldenShowCompose" - autoTest 2 8 "GoldenShowMapChar" - autoTest 7 8 "GoldenSuperclass" - autoTest 2 12 "GoldenSafeHead" - autoTest 2 12 "FmapBoth" - autoTest 7 8 "RecordCon" - autoTest 6 8 "NewtypeRecord" - autoTest 2 14 "FmapJoin" - autoTest 2 9 "Fgmap" - autoTest 4 19 "FmapJoinInLet" - autoTest 9 12 "AutoEndo" - autoTest 2 16 "AutoEmptyString" - autoTest 7 35 "AutoPatSynUse" - autoTest 2 28 "AutoZip" - autoTest 2 17 "AutoInfixApply" - autoTest 2 19 "AutoInfixApplyMany" - autoTest 2 25 "AutoInfixInfix" - autoTest 19 12 "AutoTypeLevel" - autoTest 11 9 "AutoForallClassMethod" - autoTest 2 8 "AutoUnusedPatternMatch" - - failing "flaky in CI" $ - autoTest 2 11 "GoldenApplicativeThen" - - failing "not enough auto gas" $ - autoTest 5 18 "GoldenFish" - - describe "theta" $ do - autoTest 12 10 "AutoThetaFix" - autoTest 7 27 "AutoThetaRankN" - autoTest 6 10 "AutoThetaGADT" - autoTest 6 8 "AutoThetaGADTDestruct" - autoTest 4 8 "AutoThetaEqCtx" - autoTest 6 10 "AutoThetaEqGADT" - autoTest 6 8 "AutoThetaEqGADTDestruct" - autoTest 6 10 "AutoThetaRefl" - autoTest 6 8 "AutoThetaReflDestruct" - autoTest 19 30 "AutoThetaMultipleUnification" - autoTest 16 9 "AutoThetaSplitUnification" - - describe "known" $ do - autoTest 25 13 "GoldenArbitrary" - autoTest 6 13 "GoldenArbitrarySingleConstructor" - autoTestNoWhitespace - 6 10 "KnownBigSemigroup" - autoTest 4 10 "KnownThetaSemigroup" - autoTest 6 10 "KnownCounterfactualSemigroup" - autoTest 10 10 "KnownModuleInstanceSemigroup" - autoTest 4 22 "KnownDestructedSemigroup" - autoTest 4 10 "KnownMissingSemigroup" - autoTest 7 12 "KnownMonoid" - autoTest 7 12 "KnownPolyMonoid" - autoTest 7 12 "KnownMissingMonoid" - - - describe "messages" $ do - mkShowMessageTest Auto "" 2 8 "MessageForallA" TacticErrors - mkShowMessageTest Auto "" 7 8 "MessageCantUnify" TacticErrors - mkShowMessageTest Auto "" 12 8 "MessageNotEnoughGas" NotEnoughGas - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/DestructAllSpec.hs deleted file mode 100644 index 488fb3ebad..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructAllSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructAllSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructAllTest = goldenTest DestructAll "" - describe "provider" $ do - mkTest - "Requires args on lhs of =" - "DestructAllProvider" 3 21 - [ (not, DestructAll, "") - ] - mkTest - "Can't be a non-top-hole" - "DestructAllProvider" 8 19 - [ (not, DestructAll, "") - , (id, Destruct, "a") - , (id, Destruct, "b") - ] - mkTest - "Provides a destruct all otherwise" - "DestructAllProvider" 12 22 - [ (id, DestructAll, "") - ] - - describe "golden" $ do - destructAllTest 2 11 "DestructAllAnd" - destructAllTest 4 23 "DestructAllMany" - destructAllTest 2 18 "DestructAllNonVarTopMatch" - destructAllTest 2 18 "DestructAllFunc" - destructAllTest 19 18 "DestructAllGADTEvidence" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructPunSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/DestructPunSpec.hs deleted file mode 100644 index 7d17aa1d2c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructPunSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructPunSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructTest = goldenTest DestructPun - - describe "golden" $ do - destructTest "x" 4 9 "PunSimple" - destructTest "x" 6 10 "PunMany" - destructTest "x" 11 11 "PunGADT" - destructTest "x" 17 11 "PunManyGADT" - destructTest "x" 4 12 "PunShadowing" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/DestructSpec.hs deleted file mode 100644 index 2251abfeb2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/DestructSpec.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.DestructSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let destructTest = goldenTest Destruct - - describe "golden" $ do - destructTest "gadt" 7 17 "GoldenGADTDestruct" - destructTest "gadt" 8 17 "GoldenGADTDestructCoercion" - destructTest "a" 7 25 "SplitPattern" - destructTest "a" 6 18 "DestructPun" - destructTest "fp" 31 14 "DestructCthulhu" - destructTest "b" 7 10 "DestructTyFam" - destructTest "b" 7 10 "DestructDataFam" - destructTest "b" 17 10 "DestructTyToDataFam" - destructTest "t" 6 10 "DestructInt" - - describe "layout" $ do - destructTest "b" 4 3 "LayoutBind" - destructTest "b" 2 15 "LayoutDollarApp" - destructTest "b" 2 18 "LayoutOpApp" - destructTest "b" 2 14 "LayoutLam" - destructTest "x" 11 15 "LayoutSplitWhere" - destructTest "x" 3 12 "LayoutSplitClass" - destructTest "b" 3 9 "LayoutSplitGuard" - destructTest "b" 4 13 "LayoutSplitLet" - destructTest "a" 4 7 "LayoutSplitIn" - destructTest "a" 4 31 "LayoutSplitViewPat" - destructTest "a" 7 17 "LayoutSplitPattern" - destructTest "a" 8 26 "LayoutSplitPatSyn" - - describe "providers" $ do - mkTest - "Produces destruct and homomorphism code actions" - "T2" 2 21 - [ (id, Destruct, "eab") - , (id, Homomorphism, "eab") - , (not, DestructPun, "eab") - ] - - mkTest - "Won't suggest homomorphism on the wrong type" - "T2" 8 8 - [ (not, Homomorphism, "global") - ] - - mkTest - "Produces (homomorphic) lambdacase code actions" - "T3" 4 24 - [ (id, HomomorphismLambdaCase, "") - , (id, DestructLambdaCase, "") - ] - - mkTest - "Produces lambdacase code actions" - "T3" 7 13 - [ (id, DestructLambdaCase, "") - ] - - mkTest - "Doesn't suggest lambdacase without -XLambdaCase" - "T2" 11 25 - [ (not, DestructLambdaCase, "") - ] - - mkTest - "Doesn't suggest destruct if already destructed" - "ProvideAlreadyDestructed" 6 18 - [ (not, Destruct, "x") - ] - - mkTest - "...but does suggest destruct if destructed in a different branch" - "ProvideAlreadyDestructed" 9 7 - [ (id, Destruct, "x") - ] - - mkTest - "Doesn't suggest destruct on class methods" - "ProvideLocalHyOnly" 2 12 - [ (not, Destruct, "mempty") - ] - - mkTest - "Suggests homomorphism if the domain is bigger than the codomain" - "ProviderHomomorphism" 12 13 - [ (id, Homomorphism, "g") - ] - - mkTest - "Doesn't suggest homomorphism if the domain is smaller than the codomain" - "ProviderHomomorphism" 15 14 - [ (not, Homomorphism, "g") - , (id, Destruct, "g") - ] - - mkTest - "Suggests lambda homomorphism if the domain is bigger than the codomain" - "ProviderHomomorphism" 18 14 - [ (id, HomomorphismLambdaCase, "") - ] - - mkTest - "Doesn't suggest lambda homomorphism if the domain is smaller than the codomain" - "ProviderHomomorphism" 21 15 - [ (not, HomomorphismLambdaCase, "") - , (id, DestructLambdaCase, "") - ] - - -- test layouts that maintain user-written fixities - destructTest "b" 3 13 "LayoutInfixKeep" - destructTest "b" 2 12 "LayoutPrefixKeep" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/IntroDestructSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/IntroDestructSpec.hs deleted file mode 100644 index 5c3b809c1d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/IntroDestructSpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.IntroDestructSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let test l c = goldenTest IntroAndDestruct "" l c - . mappend "IntroDestruct" - - describe "golden" $ do - test 4 5 "One" - test 2 5 "Many" - test 4 11 "LetBinding" - - describe "provider" $ do - mkTest - "Can intro and destruct an algebraic ty" - "IntroDestructProvider" 2 12 - [ (id, IntroAndDestruct, "") - ] - mkTest - "Won't intro and destruct a non-algebraic ty" - "IntroDestructProvider" 5 12 - [ (not, IntroAndDestruct, "") - ] - mkTest - "Can't intro, so no option" - "IntroDestructProvider" 8 17 - [ (not, IntroAndDestruct, "") - ] - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/IntrosSpec.hs deleted file mode 100644 index da2aaaa273..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/IntrosSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.IntrosSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let introsTest = goldenTest Intros "" - - describe "golden" $ do - introsTest 2 8 "GoldenIntros" - - describe "layout" $ do - introsTest 4 24 "LayoutRec" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/RefineSpec.hs deleted file mode 100644 index 205054c652..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/RefineSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.RefineSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let refineTest = goldenTest Refine "" - - describe "golden" $ do - refineTest 2 8 "RefineIntro" - refineTest 2 8 "RefineCon" - refineTest 4 10 "RefineReader" - refineTest 8 10 "RefineGADT" - refineTest 2 8 "RefineIntroWhere" - - describe "messages" $ do - mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/RunMetaprogramSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/RunMetaprogramSpec.hs deleted file mode 100644 index e366c34efe..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/RunMetaprogramSpec.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.RunMetaprogramSpec where - -import Utils -import Test.Hspec -import Wingman.Types - - -spec :: Spec -spec = do - let metaTest l c f = - goldenTest RunMetaprogram "" l c f - - describe "beginMetaprogram" $ do - goldenTest BeginMetaprogram "" 1 7 "MetaBegin" - goldenTest BeginMetaprogram "" 1 9 "MetaBeginNoWildify" - - describe "golden" $ do - metaTest 6 11 "MetaMaybeAp" - metaTest 2 32 "MetaBindOne" - metaTest 2 32 "MetaBindAll" - metaTest 2 13 "MetaTry" - metaTest 2 74 "MetaChoice" - metaTest 5 40 "MetaUseImport" - metaTest 6 31 "MetaUseLocal" - metaTest 11 11 "MetaUseMethod" - metaTest 9 38 "MetaCataCollapse" - metaTest 7 16 "MetaCataCollapseUnary" - metaTest 10 32 "MetaCataAST" - metaTest 6 46 "MetaPointwise" - metaTest 4 28 "MetaUseSymbol" - metaTest 7 53 "MetaDeepOf" - metaTest 2 34 "MetaWithArg" - metaTest 2 18 "MetaLetSimple" - metaTest 5 9 "MetaIdiom" - metaTest 7 9 "MetaIdiomRecord" - - metaTest 14 10 "MetaFundeps" - - metaTest 2 12 "IntrosTooMany" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeAction/UseDataConSpec.hs deleted file mode 100644 index 94a1d17550..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeAction/UseDataConSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeAction.UseDataConSpec where - -import qualified Data.Text as T -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let useTest = goldenTest UseDataCon - - describe "provider" $ do - mkTest - "Suggests all data cons for Either" - "ConProviders" 5 6 - [ (id, UseDataCon, "Left") - , (id, UseDataCon, "Right") - , (not, UseDataCon, ":") - , (not, UseDataCon, "[]") - , (not, UseDataCon, "C1") - ] - mkTest - "Suggests no data cons for big types" - "ConProviders" 11 17 $ do - c <- [1 :: Int .. 10] - pure $ (not, UseDataCon, T.pack $ show c) - mkTest - "Suggests only matching data cons for GADT" - "ConProviders" 20 12 - [ (id, UseDataCon, "IntGADT") - , (id, UseDataCon, "VarGADT") - , (not, UseDataCon, "BoolGADT") - ] - - describe "golden" $ do - useTest "(,)" 2 8 "UseConPair" - useTest "Left" 2 8 "UseConLeft" - useTest "Right" 2 8 "UseConRight" - diff --git a/plugins/hls-tactics-plugin/old/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/old/test/CodeLens/EmptyCaseSpec.hs deleted file mode 100644 index 9ebf7d5043..0000000000 --- a/plugins/hls-tactics-plugin/old/test/CodeLens/EmptyCaseSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CodeLens.EmptyCaseSpec where - -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - let test = mkCodeLensTest - noTest = mkNoCodeLensTest - - describe "golden" $ do - test "EmptyCaseADT" - test "EmptyCaseShadow" - test "EmptyCaseParens" - test "EmptyCaseNested" - test "EmptyCaseApply" - test "EmptyCaseGADT" - test "EmptyCaseLamCase" - - describe "no code lenses" $ do - noTest "EmptyCaseSpuriousGADT" - diff --git a/plugins/hls-tactics-plugin/old/test/Main.hs b/plugins/hls-tactics-plugin/old/test/Main.hs deleted file mode 100644 index 00a71905e1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import qualified Spec -import Test.Hls -import Test.Tasty.Hspec - -main :: IO () -main = testSpecs Spec.spec >>= defaultTestRunner . testGroup "tactics" diff --git a/plugins/hls-tactics-plugin/old/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/old/test/ProviderSpec.hs deleted file mode 100644 index 4eea30f5b3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/ProviderSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ProviderSpec where - -import Wingman.Types -import Test.Hspec -import Utils - - -spec :: Spec -spec = do - mkTest - "Produces intros code action" - "T1" 2 14 - [ (id, Intros, "") - ] - - mkTest - "Won't suggest intros on the wrong type" - "T2" 8 8 - [ (not, Intros, "") - ] - - goldenTestMany "SubsequentTactics" - [ InvokeTactic Intros "" 4 5 - , InvokeTactic Destruct "du" 4 8 - , InvokeTactic Auto "" 4 15 - ] diff --git a/plugins/hls-tactics-plugin/old/test/Spec.hs b/plugins/hls-tactics-plugin/old/test/Spec.hs deleted file mode 100644 index 5416ef6a86..0000000000 --- a/plugins/hls-tactics-plugin/old/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/plugins/hls-tactics-plugin/old/test/UnificationSpec.hs b/plugins/hls-tactics-plugin/old/test/UnificationSpec.hs deleted file mode 100644 index 148a40eaaa..0000000000 --- a/plugins/hls-tactics-plugin/old/test/UnificationSpec.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnificationSpec where - -import Control.Arrow -import Control.Monad (replicateM, join) -import Control.Monad.State (evalState) -import Data.Bool (bool) -import Data.Functor ((<&>)) -import Data.Maybe (mapMaybe) -import qualified Data.Set as S -import Data.Traversable -import Data.Tuple (swap) -import Development.IDE.GHC.Compat.Core (substTy, mkBoxedTupleTy) -import Test.Hspec -import Test.QuickCheck -import Wingman.GHC -import Wingman.Machinery (newUnivar) -import Wingman.Types - -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Tc.Utils.TcType (tcGetTyVar_maybe) -#else -import TcType (tcGetTyVar_maybe) -#endif - - -spec :: Spec -spec = describe "unification" $ do - it "should be able to unify univars with skolems on either side of the equality" $ do - property $ do - -- Pick some number of unification vars and skolem - n <- choose (1, 20) - let (skolems, take n -> univars) - = splitAt n - $ flip evalState defaultTacticState - $ replicateM (n * 2) newUnivar - -- Randomly pair them - skolem_uni_pairs <- - for (zip skolems univars) randomSwap - let (lhs, rhs) - = mkBoxedTupleTy *** mkBoxedTupleTy - $ unzip skolem_uni_pairs - pure $ - counterexample (show skolems) $ - counterexample (show lhs) $ - counterexample (show rhs) $ - case tryUnifyUnivarsButNotSkolems - (S.fromList $ mapMaybe tcGetTyVar_maybe skolems) - (CType lhs) - (CType rhs) of - Just subst -> - conjoin $ join $ - [ -- For each pair, running the unification over the univar should - -- result in the skolem - zip univars skolems <&> \(uni, skolem) -> - let substd = substTy subst uni - in counterexample (show substd) $ - counterexample (show skolem) $ - CType substd === CType skolem - - -- And also, no two univars should equal to one another - -- before or after substitution. - , zip univars (tail univars) <&> \(uni1, uni2) -> - let uni1_sub = substTy subst uni1 - uni2_sub = substTy subst uni2 - in counterexample (show uni1) $ - counterexample (show uni2) $ - CType uni1 =/= CType uni2 .&&. - CType uni1_sub =/= CType uni2_sub - ] - Nothing -> True === False - - -randomSwap :: (a, a) -> Gen (a, a) -randomSwap ab = do - which <- arbitrary - pure $ bool swap id which ab - - diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs deleted file mode 100644 index fe3c2cded4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} - -module Utils where - -import Control.DeepSeq (deepseq) -import qualified Control.Exception as E -import Control.Lens hiding (List, failing, (<.>), (.=)) -import Control.Monad (unless, void) -import Control.Monad.IO.Class -import Data.Aeson -import Data.Foldable -import Data.Function (on) -import Data.IORef (writeIORef) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Ide.Plugin.Tactic as Tactic -import Ide.Types (IdePlugins(..)) -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title, error) -import System.Directory (doesFileExist) -import System.FilePath -import Test.Hls -import Test.Hspec -import Test.Hspec.Formatters (FailureReason(ExpectedButGot)) -import Wingman.LanguageServer (mkShowMessageParams) -import Wingman.Types - - -plugin :: PluginTestDescriptor Log -plugin = mkPluginTestDescriptor Tactic.descriptor "tactics" - ------------------------------------------------------------------------------- --- | Get a range at the given line and column corresponding to having nothing --- selected. --- --- NB: These coordinates are in "file space", ie, 1-indexed. -pointRange :: Int -> Int -> Range -pointRange - (subtract 1 -> fromIntegral -> line) - (subtract 1 -> fromIntegral -> col) = - Range (Position line col) (Position line $ col + 1) - - ------------------------------------------------------------------------------- --- | Get the title of a code action. -codeActionTitle :: (Command |? CodeAction) -> Maybe Text -codeActionTitle InL{} = Nothing -codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title - - -resetGlobalHoleRef :: IO () -resetGlobalHoleRef = writeIORef globalHoleRef 0 - - -runSessionForTactics :: Session a -> IO a -runSessionForTactics act = do - recorder <- pluginTestRecorder - runSessionWithServer' - (plugin recorder) - def - (def { ignoreLogNotifications = False }) - fullCaps - tacticPath - act - ------------------------------------------------------------------------------- --- | Make a tactic unit test. -mkTest - :: Foldable t - => String -- ^ The test name - -> FilePath -- ^ The file name stem (without extension) to load - -> Int -- ^ Cursor line - -> Int -- ^ Cursor column - -> t ( Bool -> Bool -- Use 'not' for actions that shouldn't be present - , TacticCommand -- An expected command ... - , Text -- ... for this variable - ) -- ^ A collection of (un)expected code actions. - -> SpecWith (Arg Bool) -mkTest name fp line col ts = it name $ do - resetGlobalHoleRef - actions <- E.handle (\(UnexpectedResponseError _ _) -> pure []) - $ runSessionForTactics $ do - doc <- openDoc (fp <.> "hs") "haskell" - -- wait for diagnostics to start coming - void waitForDiagnostics - -- wait for the entire build to finish, so that Tactics code actions that - -- use stale data will get uptodate stuff - void $ waitForTypecheck doc - getCodeActions doc $ pointRange line col - let titles = mapMaybe codeActionTitle actions - for_ ts $ \(f, tc, var) -> do - let title = tacticTitle tc var - liftIO $ - (title `elem` titles) `shouldSatisfy` f - -data InvokeTactic = InvokeTactic - { it_command :: TacticCommand - , it_argument :: Text - , it_line :: Int - , it_col :: Int - } - -invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session () -invokeTactic doc InvokeTactic{..} = do - -- wait for the entire build to finish, so that Tactics code actions that - -- use stale data will get uptodate stuff - void waitForDiagnostics - void $ waitForTypecheck doc - actions <- getCodeActions doc $ pointRange it_line it_col - case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of - Just (InR CodeAction {_command = Just c}) -> do - executeCommand c - void $ skipManyTill anyMessage $ message SMethod_WorkspaceApplyEdit - _ -> error $ show actions - - -mkGoldenTest - :: (Text -> Text -> Assertion) - -> [InvokeTactic] - -> FilePath - -> SpecWith () -mkGoldenTest eq invocations input = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - traverse_ (invokeTactic doc) invocations - edited <- documentContents doc - let expected_name = input <.> "expected" <.> "hs" - -- Write golden tests if they don't already exist - liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited `eq` expected - - -mkCodeLensTest - :: FilePath - -> SpecWith () -mkCodeLensTest input = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForDiagnostics - lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc - for_ lenses $ \(CodeLens _ (Just cmd) _) -> - executeCommand cmd - _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) - edited <- documentContents doc - let expected_name = input <.> "expected" <.> "hs" - -- Write golden tests if they don't already exist - liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited `shouldBe` expected - - ------------------------------------------------------------------------------- --- | A test that no code lenses can be run in the file -mkNoCodeLensTest - :: FilePath - -> SpecWith () -mkNoCodeLensTest input = - it (input <> " (no code lenses)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForBuildQueue - lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc - liftIO $ lenses `shouldBe` [] - - - -isWingmanLens :: CodeLens -> Bool -isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _) - = T.isInfixOf ":tactics:" cmd -isWingmanLens _ = False - - -mkShowMessageTest - :: TacticCommand - -> Text - -> Int - -> Int - -> FilePath - -> UserFacingMessage - -> SpecWith () -mkShowMessageTest tc occ line col input ufm = - it (input <> " (golden)") $ do - resetGlobalHoleRef - runSessionForTactics $ do - doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForDiagnostics - actions <- getCodeActions doc $ pointRange line col - Just (InR CodeAction {_command = Just c}) - <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions - executeCommand c - TNotificationMessage _ _ err <- skipManyTill anyMessage (message SMethod_WindowShowMessage) - liftIO $ err `shouldBe` mkShowMessageParams ufm - - -goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col] - -goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith () -goldenTestMany = flip $ mkGoldenTest shouldBe - -goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col] - - -shouldBeIgnoringSpaces :: Text -> Text -> Assertion -shouldBeIgnoringSpaces = assertFun f "" - where - f = (==) `on` T.unwords . T.words - - -assertFun - :: Show a - => (a -> a -> Bool) - -> String -- ^ The message prefix - -> a -- ^ The expected value - -> a -- ^ The actual value - -> Assertion -assertFun eq preface expected actual = - unless (eq actual expected) $ do - (prefaceMsg - `deepseq` expectedMsg - `deepseq` actualMsg - `deepseq` - E.throwIO - (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg)) - where - prefaceMsg - | null preface = Nothing - | otherwise = Just preface - expectedMsg = show expected - actualMsg = show actual - - - ------------------------------------------------------------------------------- --- | Don't run a test. -failing :: Applicative m => String -> b -> m () -failing _ _ = pure () - - -tacticPath :: FilePath -tacticPath = "old/test/golden" - - -executeCommandWithResp :: Command -> Session (TResponseMessage 'Method_WorkspaceExecuteCommand) -executeCommandWithResp cmd = do - let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SMethod_WorkspaceExecuteCommand execParams - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.expected.hs deleted file mode 100644 index 8ccb9f083d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = "" diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.hs deleted file mode 100644 index f04451e24c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoEmptyString.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.expected.hs deleted file mode 100644 index 4b50c6c074..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Synthesized b a = Synthesized - { syn_trace :: b - , syn_val :: a - } - deriving (Eq, Show) - - -mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a -mapTrace fbb (Synthesized b a) - = Synthesized {syn_trace = fbb b, syn_val = a} - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.hs deleted file mode 100644 index c92e6adb5b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoEndo.hs +++ /dev/null @@ -1,10 +0,0 @@ -data Synthesized b a = Synthesized - { syn_trace :: b - , syn_val :: a - } - deriving (Eq, Show) - - -mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a -mapTrace = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.expected.hs deleted file mode 100644 index 5846428ee7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -import Data.Functor.Contravariant - -class Semigroupal cat t1 t2 to f where - combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y')) - -comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d) -comux = case combine of { (Op f) -> f } - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.hs deleted file mode 100644 index 9ee00c9255..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoForallClassMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -import Data.Functor.Contravariant - -class Semigroupal cat t1 t2 to f where - combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y')) - -comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d) -comux = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.expected.hs deleted file mode 100644 index 367f6e54d9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = a /: f a - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.hs deleted file mode 100644 index 4675331aea..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApply.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.expected.hs deleted file mode 100644 index ce40bf0cd6..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = (a /: f a) x - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.hs deleted file mode 100644 index 55a706ab9b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixApplyMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.expected.hs deleted file mode 100644 index 7adea169d1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = (a /: f a) --> x diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.hs deleted file mode 100644 index 729e1a2227..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoInfixInfix.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.expected.hs deleted file mode 100644 index 8addba654f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - -amIASingleton :: Maybe [a] -> Maybe a -amIASingleton (JustSingleton a) = Just a - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.hs deleted file mode 100644 index 25a44666e7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoPatSynUse.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - -amIASingleton :: Maybe [a] -> Maybe a -amIASingleton (JustSingleton a) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.expected.hs deleted file mode 100644 index 2521b651eb..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT b a where - GBool :: b -> GADT b Bool - GInt :: GADT b Int - --- wingman would prefer to use GBool since then it can use its argument. But --- that won't unify with GADT Int, so it is forced to pick GInt and ignore the --- argument. -test :: b -> GADT b Int -test _ = GInt - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.hs deleted file mode 100644 index b15621e091..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoSplitGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT b a where - GBool :: b -> GADT b Bool - GInt :: GADT b Int - --- wingman would prefer to use GBool since then it can use its argument. But --- that won't unify with GADT Int, so it is forced to pick GInt and ignore the --- argument. -test :: b -> GADT b Int -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.expected.hs deleted file mode 100644 index cdb8506d01..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = id -- id - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.hs deleted file mode 100644 index 448a7f5de5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqCtx.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = _ -- id - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.expected.hs deleted file mode 100644 index cea9517794..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = id - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.hs deleted file mode 100644 index eae2246722..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.expected.hs deleted file mode 100644 index 9f2b954867..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y a = a - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.hs deleted file mode 100644 index 2292a3972f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaEqGADTDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 = _ - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.expected.hs deleted file mode 100644 index ba8df349e4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -data Fix f a = Fix (f (Fix f a)) - -instance ( Functor f - -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire - -- on this case. By explicitly adding the @Functor (Fix f)@ - -- dictionary, we can get Wingman to generate the right definition. - , Functor (Fix f) - ) => Functor (Fix f) where - fmap fab (Fix f) = Fix (fmap (fmap fab) f) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.hs deleted file mode 100644 index 014e6441da..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaFix.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -data Fix f a = Fix (f (Fix f a)) - -instance ( Functor f - -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire - -- on this case. By explicitly adding the @Functor (Fix f)@ - -- dictionary, we can get Wingman to generate the right definition. - , Functor (Fix f) - ) => Functor (Fix f) where - fmap = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.expected.hs deleted file mode 100644 index e74f2aba40..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = pure - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.hs deleted file mode 100644 index e1b20a4b3b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.expected.hs deleted file mode 100644 index 4d4b1f9579..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X a = pure a - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.hs deleted file mode 100644 index d92d0bd97d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.expected.hs deleted file mode 100644 index 446a4d73b3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t _) = t -lookMeUp (AtS ea') (HCons t hl') = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.hs deleted file mode 100644 index b0b520347d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaMultipleUnification.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t hl') = _ -lookMeUp (AtS ea') (HCons t hl') = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.expected.hs deleted file mode 100644 index 23d96223f3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -showMe :: (forall x. Show x => x -> String) -> Int -> String -showMe f = f - -showedYou :: Int -> String -showedYou = showMe (\x -> show x) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.hs deleted file mode 100644 index 0e92ac35f3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRankN.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -showMe :: (forall x. Show x => x -> String) -> Int -> String -showMe f = f - -showedYou :: Int -> String -showedYou = showMe (\x -> _) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.expected.hs deleted file mode 100644 index 9e42bc946e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = id -- id - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.hs deleted file mode 100644 index df15580ad2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaRefl.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = _ -- id - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.expected.hs deleted file mode 100644 index 36aed1af65..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z a = a -- id - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.hs deleted file mode 100644 index 3beccba7a5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaReflDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 = _ -- id - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.expected.hs deleted file mode 100644 index e680f0265c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.expected.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -data A = A -data B = B -data X = X -data Y = Y - - -data Pairrow ax by where - Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y) - -test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y) -test2 = Pairrow - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.hs deleted file mode 100644 index e6ceeb1bcd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoThetaSplitUnification.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -data A = A -data B = B -data X = X -data Y = Y - - -data Pairrow ax by where - Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y) - -test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y) -test2 = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.expected.hs deleted file mode 100644 index 3668830620..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t _) = t -lookMeUp (AtS ea') (HCons _ hl') = lookMeUp ea' hl' - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.hs deleted file mode 100644 index 40226739db..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoTypeLevel.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.expected.hs deleted file mode 100644 index 2885a1ca05..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test _ = () diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.hs deleted file mode 100644 index 5345192969..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoUnusedPatternMatch.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoZip.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoZip.expected.hs deleted file mode 100644 index 997bc09a33..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoZip.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] -zip_it_up_and_zip_it_out _ [] = [] -zip_it_up_and_zip_it_out [] (_ : _) = [] -zip_it_up_and_zip_it_out (a : as') (b : bs') - = (a, b) : zip_it_up_and_zip_it_out as' bs' - diff --git a/plugins/hls-tactics-plugin/old/test/golden/AutoZip.hs b/plugins/hls-tactics-plugin/old/test/golden/AutoZip.hs deleted file mode 100644 index 98d6335988..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/AutoZip.hs +++ /dev/null @@ -1,3 +0,0 @@ -zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] -zip_it_up_and_zip_it_out = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/ConProviders.hs b/plugins/hls-tactics-plugin/old/test/golden/ConProviders.hs deleted file mode 100644 index 19dbc3c6e5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/ConProviders.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- Should suggest Left and Right, but not [] -t1 :: Either a b -t1 = _ - - -data ManyConstructors = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 - -noCtorsIfMany :: ManyConstructors -noCtorsIfMany = _ - - -data GADT a where - IntGADT :: GADT Int - BoolGADT :: GADT Bool - VarGADT :: GADT a - -gadtCtor :: GADT Int -gadtCtor = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.expected.hs deleted file mode 100644 index 392bd9d2cd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -and :: Bool -> Bool -> Bool -and False False = _w0 -and False True = _w1 -and True False = _w2 -and True True = _w3 diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.hs deleted file mode 100644 index 892eab679c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllAnd.hs +++ /dev/null @@ -1,2 +0,0 @@ -and :: Bool -> Bool -> Bool -and x y = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.expected.hs deleted file mode 100644 index 536d15b107..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func False y = _w0 -has_a_func True y = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.hs deleted file mode 100644 index 6996698400..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllFunc.hs +++ /dev/null @@ -1,3 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func x y = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.expected.hs deleted file mode 100644 index 0e4c0985fa..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp AtZ (HCons t hl') = _w0 -lookMeUp (AtS ea') (HCons t hl') = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.hs deleted file mode 100644 index 3ac66d5444..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllGADTEvidence.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Kind - -data Nat = Z | S Nat - -data HList (ls :: [Type]) where - HNil :: HList '[] - HCons :: t -> HList ts -> HList (t ': ts) - -data ElemAt (n :: Nat) t (ts :: [Type]) where - AtZ :: ElemAt 'Z t (t ': ts) - AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts) - -lookMeUp :: ElemAt i ty tys -> HList tys -> ty -lookMeUp ea hl = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.expected.hs deleted file mode 100644 index 366a3eac70..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.expected.hs +++ /dev/null @@ -1,27 +0,0 @@ -data ABC = A | B | C - -many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () -many () (Left a) False Nothing A = _w0 -many () (Left a) False Nothing B = _w1 -many () (Left a) False Nothing C = _w2 -many () (Left a) False (Just abc') A = _w3 -many () (Left a) False (Just abc') B = _w4 -many () (Left a) False (Just abc') C = _w5 -many () (Left a) True Nothing A = _w6 -many () (Left a) True Nothing B = _w7 -many () (Left a) True Nothing C = _w8 -many () (Left a) True (Just abc') A = _w9 -many () (Left a) True (Just abc') B = _wa -many () (Left a) True (Just abc') C = _wb -many () (Right b') False Nothing A = _wc -many () (Right b') False Nothing B = _wd -many () (Right b') False Nothing C = _we -many () (Right b') False (Just abc') A = _wf -many () (Right b') False (Just abc') B = _wg -many () (Right b') False (Just abc') C = _wh -many () (Right b') True Nothing A = _wi -many () (Right b') True Nothing B = _wj -many () (Right b') True Nothing C = _wk -many () (Right b') True (Just abc') A = _wl -many () (Right b') True (Just abc') B = _wm -many () (Right b') True (Just abc') C = _wn diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.hs deleted file mode 100644 index ab0a4dccb9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllMany.hs +++ /dev/null @@ -1,4 +0,0 @@ -data ABC = A | B | C - -many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () -many u e b mabc abc = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.expected.hs deleted file mode 100644 index dc1ea66c51..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -and :: (a, b) -> Bool -> Bool -> Bool -and (a, b) False False = _w0 -and (a, b) False True = _w1 -and (a, b) True False = _w2 -and (a, b) True True = _w3 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.hs deleted file mode 100644 index 358223ae67..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllNonVarTopMatch.hs +++ /dev/null @@ -1,3 +0,0 @@ -and :: (a, b) -> Bool -> Bool -> Bool -and (a, b) x y = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructAllProvider.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructAllProvider.hs deleted file mode 100644 index 8d115e828d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructAllProvider.hs +++ /dev/null @@ -1,12 +0,0 @@ --- we need to name the args ourselves first -nothingToDestruct :: [a] -> [a] -> [a] -nothingToDestruct = _ - - --- can't destruct all for non-top-level holes -notTop :: Bool -> Bool -> Bool -notTop a b = a && _ - --- destruct all is ok -canDestructAll :: Bool -> Bool -> Bool -canDestructAll a b = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.expected.hs deleted file mode 100644 index e885b489a1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.expected.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data FreePro r c a b where - ID :: FreePro r c x x - Comp :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z - Copy :: FreePro r c x (x, x) - Consume :: FreePro r c x () - Swap :: FreePro r c (a, b) (b, a) - SwapE :: FreePro r c (Either a b) (Either b a) - Fst :: FreePro r c (a, b) a - Snd :: FreePro r c (a, b) b - InjectL :: FreePro r c a (Either a b) - InjectR :: FreePro r c b (Either a b) - Unify :: FreePro r c (Either a a) a - First :: FreePro r c a b -> FreePro r c (a, m) (b, m) - Second :: FreePro r c a b -> FreePro r c (m, a) (m, b) - Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b') - Fanout :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b') - Left' :: FreePro r c a b -> FreePro r c (Either a x) (Either b x) - Right' :: FreePro r c a b -> FreePro r c (Either x a) (Either x b) - EitherOf :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b') - Fanin :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b - LiftC :: c a b -> FreePro r c a b - Zero :: FreePro r c x y - Plus :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y - Unleft :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b - Unright :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b - - -cthulhu :: FreePro r c a b -> FreePro r c a b -cthulhu ID = _w0 -cthulhu (Comp fp' fp_rcyb) = _w1 -cthulhu Copy = _w2 -cthulhu Consume = _w3 -cthulhu Swap = _w4 -cthulhu SwapE = _w5 -cthulhu Fst = _w6 -cthulhu Snd = _w7 -cthulhu InjectL = _w8 -cthulhu InjectR = _w9 -cthulhu Unify = _wa -cthulhu (First fp') = _wb -cthulhu (Second fp') = _wc -cthulhu (Alongside fp' fp_rca'b') = _wd -cthulhu (Fanout fp' fp_rcab') = _we -cthulhu (Left' fp') = _wf -cthulhu (Right' fp') = _wg -cthulhu (EitherOf fp' fp_rca'b') = _wh -cthulhu (Fanin fp' fp_rca'b) = _wi -cthulhu (LiftC cab) = _wj -cthulhu Zero = _wk -cthulhu (Plus fp' fp_rcab) = _wl -cthulhu (Unleft fp') = _wm -cthulhu (Unright fp') = _wn diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.hs deleted file mode 100644 index a2d04bb6a2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructCthulhu.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data FreePro r c a b where - ID :: FreePro r c x x - Comp :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z - Copy :: FreePro r c x (x, x) - Consume :: FreePro r c x () - Swap :: FreePro r c (a, b) (b, a) - SwapE :: FreePro r c (Either a b) (Either b a) - Fst :: FreePro r c (a, b) a - Snd :: FreePro r c (a, b) b - InjectL :: FreePro r c a (Either a b) - InjectR :: FreePro r c b (Either a b) - Unify :: FreePro r c (Either a a) a - First :: FreePro r c a b -> FreePro r c (a, m) (b, m) - Second :: FreePro r c a b -> FreePro r c (m, a) (m, b) - Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b') - Fanout :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b') - Left' :: FreePro r c a b -> FreePro r c (Either a x) (Either b x) - Right' :: FreePro r c a b -> FreePro r c (Either x a) (Either x b) - EitherOf :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b') - Fanin :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b - LiftC :: c a b -> FreePro r c a b - Zero :: FreePro r c x y - Plus :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y - Unleft :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b - Unright :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b - - -cthulhu :: FreePro r c a b -> FreePro r c a b -cthulhu fp = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.expected.hs deleted file mode 100644 index e463935583..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test (Heya n) = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.hs deleted file mode 100644 index a93e1974fb..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructDataFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructInt.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructInt.expected.hs deleted file mode 100644 index 0f14deef83..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructInt.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test (Test in') = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructInt.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructInt.hs deleted file mode 100644 index 432a6d4074..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructInt.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test t = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructPun.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructPun.expected.hs deleted file mode 100644 index bfd8d09074..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructPun.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a = False, b} = _w0 -foo Foo {a = True, b} = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructPun.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructPun.hs deleted file mode 100644 index c7b410c5e3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructPun.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a, b} = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.expected.hs deleted file mode 100644 index eee4cbd587..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test False = _w0 -test True = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.hs deleted file mode 100644 index 30a9d884b7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructTyFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.expected.hs deleted file mode 100644 index 3016c4ef4e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.expected.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -type family T1 a where - T1 a = T2 Int - -type family T2 a -type instance T2 Int = T3 - -type family T3 where - T3 = Yo - -data family Yo -data instance Yo = Heya Int - -test :: T1 Bool -> Int -test (Heya n) = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.hs b/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.hs deleted file mode 100644 index 191fa7b044..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/DestructTyToDataFam.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -type family T1 a where - T1 a = T2 Int - -type family T2 a -type instance T2 Int = T3 - -type family T3 where - T3 = Yo - -data family Yo -data instance Yo = Heya Int - -test :: T1 Bool -> Int -test b = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.expected.hs deleted file mode 100644 index 84d2b80d0e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - A n -> _ - B b -> _ - C -> _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.hs deleted file mode 100644 index 37d3b6c357..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseADT.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.expected.hs deleted file mode 100644 index 1895dd6256..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -blah = case show 5 of - [] -> _ - c : s -> _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.hs deleted file mode 100644 index 29647e2cda..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseApply.hs +++ /dev/null @@ -1 +0,0 @@ -blah = case show 5 of diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.expected.hs deleted file mode 100644 index 409be2aa03..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - MyInt :: GADT Int - MyBool :: GADT Bool - MyVar :: GADT a - - -test :: GADT Int -> GADT Bool -test x = case x of - MyInt -> _ - MyVar -> _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.hs deleted file mode 100644 index ba08ddae54..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseGADT.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - MyInt :: GADT Int - MyBool :: GADT Bool - MyVar :: GADT a - - -test :: GADT Int -> GADT Bool -test x = case x of - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.expected.hs deleted file mode 100644 index 048f437368..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case - False -> _ - True -> _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.hs deleted file mode 100644 index ef490eb751..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseLamCase.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.expected.hs deleted file mode 100644 index ef873a7c41..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test = - case (case (Just "") of - Nothing -> _ - Just s -> _) of - True -> _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.hs deleted file mode 100644 index a72781a7c6..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseNested.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = - case (case (Just "") of) of - True -> _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.expected.hs deleted file mode 100644 index 18aacf2ae2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = True && (case True of - False -> _ - True -> _) diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.hs deleted file mode 100644 index 2ac71b042e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseParens.hs +++ /dev/null @@ -1 +0,0 @@ -test = True && case True of diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.expected.hs deleted file mode 100644 index 2c5158b856..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -data Foo = A Int | B Bool | C - --- Make sure we don't shadow the i and b bindings when we empty case --- split -foo :: Int -> Bool -> Foo -> () -foo i b x = case x of - A n -> _ - B b' -> _ - C -> _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.hs deleted file mode 100644 index c57af5b849..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseShadow.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Foo = A Int | B Bool | C - --- Make sure we don't shadow the i and b bindings when we empty case --- split -foo :: Int -> Bool -> Foo -> () -foo i b x = case x of - diff --git a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseSpuriousGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseSpuriousGADT.hs deleted file mode 100644 index 25906fe536..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/EmptyCaseSpuriousGADT.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Foo a where - Foo :: Foo Int - -foo :: Foo Bool -> () -foo x = case x of - diff --git a/plugins/hls-tactics-plugin/old/test/golden/Fgmap.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/Fgmap.expected.hs deleted file mode 100644 index 4f4921fa05..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/Fgmap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = fmap . fmap diff --git a/plugins/hls-tactics-plugin/old/test/golden/Fgmap.hs b/plugins/hls-tactics-plugin/old/test/golden/Fgmap.hs deleted file mode 100644 index de1968474e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/Fgmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.expected.hs deleted file mode 100644 index 825b00ebea..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth fab (fa, ga) = (fmap fab fa, fmap fab ga) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.hs deleted file mode 100644 index 29d8ea62b2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapBoth.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.expected.hs deleted file mode 100644 index 5dc5026f8b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap (\ m -> m >>= id) diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.hs deleted file mode 100644 index 98a40133ea..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapJoin.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.expected.hs deleted file mode 100644 index ac4b54ae9d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = let f = ( (\ m -> m >>= id) :: m (m a) -> m a) in fmap f diff --git a/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.hs b/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.hs deleted file mode 100644 index e6fe6cbd0d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/FmapJoinInLet.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = let f = (_ :: m (m a) -> m a) in fmap f diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenApplicativeThen.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenApplicativeThen.hs deleted file mode 100644 index 29ce9f5132..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenApplicativeThen.hs +++ /dev/null @@ -1,2 +0,0 @@ -useThen :: Applicative f => f Int -> f a -> f a -useThen = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.expected.hs deleted file mode 100644 index 6f7af5c3fd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.expected.hs +++ /dev/null @@ -1,53 +0,0 @@ --- Emulate a quickcheck import; deriveArbitrary works on any type with the --- right name and kind -data Gen a - -data Obj - = Square Int Int - | Circle Int - | Polygon [(Int, Int)] - | Rotate2 Double Obj - | Empty - | Full - | Complement Obj - | UnionR Double [Obj] - | DifferenceR Double Obj [Obj] - | IntersectR Double [Obj] - | Translate Double Double Obj - | Scale Double Double Obj - | Mirror Double Double Obj - | Outset Double Obj - | Shell Double Obj - | WithRounding Double Obj - - -arbitrary :: Gen Obj -arbitrary - = let - terminal - = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary, - Polygon <$> arbitrary, pure Empty, pure Full] - in - sized - $ (\ n - -> case n <= 1 of - True -> oneof terminal - False - -> oneof - $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary, - Complement <$> scale (subtract 1) arbitrary, - (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary) - <*> scale (flip div 2) arbitrary, - (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((Translate <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Scale <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Mirror <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary, - (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary, - (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary] - <> terminal)) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.hs deleted file mode 100644 index f45d2d1fea..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrary.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Emulate a quickcheck import; deriveArbitrary works on any type with the --- right name and kind -data Gen a - -data Obj - = Square Int Int - | Circle Int - | Polygon [(Int, Int)] - | Rotate2 Double Obj - | Empty - | Full - | Complement Obj - | UnionR Double [Obj] - | DifferenceR Double Obj [Obj] - | IntersectR Double [Obj] - | Translate Double Double Obj - | Scale Double Double Obj - | Mirror Double Double Obj - | Outset Double Obj - | Shell Double Obj - | WithRounding Double Obj - - -arbitrary :: Gen Obj -arbitrary = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.expected.hs deleted file mode 100644 index 786e381ca8..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary - = (((Obj <$> arbitrary) <*> arbitrary) <*> arbitrary) <*> arbitrary \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.hs deleted file mode 100644 index a6a7d171a3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenArbitrarySingleConstructor.hs +++ /dev/null @@ -1,6 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary = _ \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.expected.hs deleted file mode 100644 index 1e7ccecde4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ --- There used to be a bug where we were unable to perform a nested split. The --- more serious regression test of this is 'AutoTupleSpec'. -bigTuple :: (a, b, c, d) -> (a, b, (c, d)) -bigTuple (a, b, c, d) = (a, b, (c, d)) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.hs deleted file mode 100644 index 1ede521a5f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenBigTuple.hs +++ /dev/null @@ -1,4 +0,0 @@ --- There used to be a bug where we were unable to perform a nested split. The --- more serious regression test of this is 'AutoTupleSpec'. -bigTuple :: (a, b, c, d) -> (a, b, (c, d)) -bigTuple = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.expected.hs deleted file mode 100644 index f7756898e0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' fac _ (Left a) = fac a -either' _ fbc (Right b) = fbc b diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.hs deleted file mode 100644 index eb34cd8209..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherAuto.hs +++ /dev/null @@ -1,2 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.expected.hs deleted file mode 100644 index c18f2ec476..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit a (Left fab) = Left (fab a) -eitherSplit a (Right fac) = Right (fac a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.hs deleted file mode 100644 index dee865d1a2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenEitherHomomorphic.hs +++ /dev/null @@ -1,2 +0,0 @@ -eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFish.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFish.hs deleted file mode 100644 index ce38700b58..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFish.hs +++ /dev/null @@ -1,5 +0,0 @@ --- There was an old bug where we would only pull skolems from the hole, rather --- than the entire hypothesis. Because of this, the 'b' here would be --- considered a univar, which could then be unified with the skolem 'c'. -fish :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c -fish amb bmc a = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.expected.hs deleted file mode 100644 index 2b32b3a9cd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Tree a = Leaf a | Branch (Tree a) (Tree a) - -instance Functor Tree where - fmap fab (Leaf a) = Leaf (fab a) - fmap fab (Branch tr' tr_a) = Branch (fmap fab tr') (fmap fab tr_a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.hs deleted file mode 100644 index 679e7902df..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFmapTree.hs +++ /dev/null @@ -1,4 +0,0 @@ -data Tree a = Leaf a | Branch (Tree a) (Tree a) - -instance Functor Tree where - fmap = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.expected.hs deleted file mode 100644 index 89db0adb76..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 _ b [] = b -foldr2 fabb b (a : as') = fabb a (foldr2 fabb b as') diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.hs deleted file mode 100644 index bade9c1e7a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFoldr.hs +++ /dev/null @@ -1,2 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.expected.hs deleted file mode 100644 index 5b39ea5a4b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe a Nothing = a -fromMaybe _ (Just a') = a' diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.hs deleted file mode 100644 index e3046a29c3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenFromMaybe.hs +++ /dev/null @@ -1,2 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.expected.hs deleted file mode 100644 index 88f33dd2da..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = MkCtxGADT () diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.hs deleted file mode 100644 index 1c47dd0e07..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTAuto.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = _auto diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.expected.hs deleted file mode 100644 index 3f5f4fa157..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data CtxGADT where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT - -ctxGADT :: CtxGADT -> String -ctxGADT (MkCtxGADT a) = _w0 diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.hs deleted file mode 100644 index 588cf362a2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data CtxGADT where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT - -ctxGADT :: CtxGADT -> String -ctxGADT gadt = _decons diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.expected.hs deleted file mode 100644 index 4f4b2d3a4a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data E a b where - E :: forall a b. (b ~ a, Ord a) => b -> E a [a] - -ctxGADT :: E a b -> String -ctxGADT (E b) = _w0 diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.hs deleted file mode 100644 index 9eca759e85..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenGADTDestructCoercion.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data E a b where - E :: forall a b. (b ~ a, Ord a) => b -> E a [a] - -ctxGADT :: E a b -> String -ctxGADT gadt = _decons diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.expected.hs deleted file mode 100644 index 7b3d1beda0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = id diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.hs deleted file mode 100644 index be8903fec0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdTypeFam.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.expected.hs deleted file mode 100644 index 5c509d6507..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap fab (Ident a) = Ident (fab a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.hs deleted file mode 100644 index 6d1de50992..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIdentityFunctor.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.expected.hs deleted file mode 100644 index 0ae8c4bbac..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah n b fab s = _w0 diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.hs deleted file mode 100644 index 5b4e6e241f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenIntros.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.expected.hs deleted file mode 100644 index e941214796..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Cont r a = ((a -> r) -> r) - -joinCont :: Cont r (Cont r a) -> Cont r a -joinCont f far = f (\ g -> g far) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.hs deleted file mode 100644 index f2c63714da..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenJoinCont.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Cont r a = ((a -> r) -> r) - -joinCont :: Cont r (Cont r a) -> Cont r a -joinCont = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.expected.hs deleted file mode 100644 index ec44241736..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList _ [] = [] -fmapList fab (a : as') = fab a : fmapList fab as' diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.hs deleted file mode 100644 index 85293daaf4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenListFmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.expected.hs deleted file mode 100644 index 99bc0cd6d0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -note :: e -> Maybe a -> Either e a -note e Nothing = Left e -note _ (Just a) = Right a diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.hs deleted file mode 100644 index c9e0c820e4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenNote.hs +++ /dev/null @@ -1,2 +0,0 @@ -note :: e -> Maybe a -> Either e a -note = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.expected.hs deleted file mode 100644 index 8f2bc80ea7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList a = a : [] diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.hs deleted file mode 100644 index 3a3293b4ec..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenPureList.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.expected.hs deleted file mode 100644 index 7f8f73e5b7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead [] = Nothing -safeHead (x : _) = Just x diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.hs deleted file mode 100644 index 6a5d27c0d1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSafeHead.hs +++ /dev/null @@ -1,2 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.expected.hs deleted file mode 100644 index 05ba83e9fe..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = show diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.hs deleted file mode 100644 index 9ec5e27bcf..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShow.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.expected.hs deleted file mode 100644 index d8a78b3017..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose fba = show . fba diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.hs deleted file mode 100644 index c99768e4e5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowCompose.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.expected.hs deleted file mode 100644 index c32357d1a9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test a f = f (show a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.hs deleted file mode 100644 index 8e6e5eae6b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenShowMapChar.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.expected.hs deleted file mode 100644 index e0a5dbb565..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = super - diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.hs deleted file mode 100644 index 86a9fed7bc..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSuperclass.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.expected.hs deleted file mode 100644 index e09cb3800a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap (a, b) = (b, a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.hs deleted file mode 100644 index 9243955c54..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwap.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.expected.hs deleted file mode 100644 index 1d2bc0a605..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany (a, b, c, d, e) = (e, d, c, b, a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.hs b/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.hs deleted file mode 100644 index b1f6c0fb2a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/GoldenSwapMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.expected.hs deleted file mode 100644 index 0039ab768e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x False = _w0 - x True = _w1 - pure () diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.hs deleted file mode 100644 index bf12200131..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructLetBinding.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x = _ - pure () diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.expected.hs deleted file mode 100644 index 462e5edf99..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x False = _w0 -x True = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.hs deleted file mode 100644 index 98a4bd552c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.expected.hs deleted file mode 100644 index 4ba80e2455..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Test where - -x :: Bool -> Int -x False = _w0 -x True = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.hs deleted file mode 100644 index 2afdc50ca5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructOne.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Test where - -x :: Bool -> Int -x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructProvider.hs b/plugins/hls-tactics-plugin/old/test/golden/IntroDestructProvider.hs deleted file mode 100644 index f0d127dd50..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntroDestructProvider.hs +++ /dev/null @@ -1,9 +0,0 @@ -hasAlgTy :: Maybe Int -> Int -hasAlgTy = _ - -hasFunTy :: (Int -> Int) -> Int -hasFunTy = _ - -isSaturated :: Bool -> Int -isSaturated b = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.expected.hs deleted file mode 100644 index 97668d8c90..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -too_many :: a -> b -> c -too_many a b = _w0 diff --git a/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.hs b/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.hs deleted file mode 100644 index 066f123a47..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/IntrosTooMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -too_many :: a -> b -> c -too_many = [wingman| intros a b c d e f g h i j k l m n o p q r s t u v w x y z |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.expected.hs deleted file mode 100644 index c97ba98a6a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Data.Monoid - -data Big a = Big [Bool] (Sum Int) String (Endo a) Any - -instance Semigroup (Big a) where - (Big bs sum s en any) <> (Big bs' sum' str en' any') - = Big - (bs <> bs') (sum <> sum') (s <> str) (en <> en') (any <> any') - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.hs deleted file mode 100644 index 49ea10b8b4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownBigSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Monoid - -data Big a = Big [Bool] (Sum Int) String (Endo a) Any - -instance Semigroup (Big a) where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.expected.hs deleted file mode 100644 index 8bef710c69..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -data Semi = Semi [String] Int - -instance Semigroup Int => Semigroup Semi where - (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) (n <> i) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.hs deleted file mode 100644 index 11e53f4191..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownCounterfactualSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -data Semi = Semi [String] Int - -instance Semigroup Int => Semigroup Semi where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.expected.hs deleted file mode 100644 index 179937cb6a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - (Test a) <> (Test c) = Test (a <> c) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.hs deleted file mode 100644 index ed4182c6d9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownDestructedSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - Test a <> Test c = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.expected.hs deleted file mode 100644 index f64222977b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = Monoid mempty _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.hs deleted file mode 100644 index 7c6bfc5ccd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.expected.hs deleted file mode 100644 index 3f18919e80..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.hs deleted file mode 100644 index 1193c14a3b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMissingSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.expected.hs deleted file mode 100644 index 627217b285..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -data Foo = Foo - -instance Semigroup Foo where - (<>) _ _ = Foo - - -data Bar = Bar Foo Foo - -instance Semigroup Bar where - (Bar foo foo') <> (Bar foo2 foo3) - = Bar (foo <> foo2) (foo' <> foo3) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.hs deleted file mode 100644 index 8a03a029af..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownModuleInstanceSemigroup.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Foo = Foo - -instance Semigroup Foo where - (<>) _ _ = Foo - - -data Bar = Bar Foo Foo - -instance Semigroup Bar where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.expected.hs deleted file mode 100644 index 6ad1e2bf92..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = Monoid mempty - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.hs deleted file mode 100644 index 0667bee28c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.expected.hs deleted file mode 100644 index 317f2e770b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid a => Monoid (Mono a) where - mempty = Monoid mempty mempty - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.hs deleted file mode 100644 index 8ba7bc6d98..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownPolyMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid a => Monoid (Mono a) where - mempty = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.expected.hs deleted file mode 100644 index 3711af103a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (Semi a) <> (Semi a') = Semi (a <> a') - diff --git a/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.hs b/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.hs deleted file mode 100644 index f5e38276fe..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/KnownThetaSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (<>) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.expected.hs deleted file mode 100644 index c65b7d07d0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - case b of - False -> _w0 - True -> _w1 - pure () - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.hs deleted file mode 100644 index 4598f0eba1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - _ - pure () - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.expected.hs deleted file mode 100644 index 32e08c94a8..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test b = id $ (case b of - False -> _w0 - True -> _w1) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.hs deleted file mode 100644 index 83a3e4785b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutDollarApp.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test b = id $ _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.expected.hs deleted file mode 100644 index b4d3ee6a0e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ --- keep layout that was written by the user in infix -foo :: Bool -> a -> a -False `foo` a = _w0 -True `foo` a = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.hs deleted file mode 100644 index 60d198e5da..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutInfixKeep.hs +++ /dev/null @@ -1,4 +0,0 @@ --- keep layout that was written by the user in infix -foo :: Bool -> a -> a -b `foo` a = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.expected.hs deleted file mode 100644 index d8b34c8939..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test = \b -> case b of - False -> _w0 - True -> _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.hs deleted file mode 100644 index 3fead2a25d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutLam.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test = \b -> _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.expected.hs deleted file mode 100644 index e8bc6ccc87..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -test :: Bool -> Bool -test b = True && (case b of - False -> _w0 - True -> _w1) diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.hs deleted file mode 100644 index a4c05b7539..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutOpApp.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> Bool -test b = True && _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.expected.hs deleted file mode 100644 index bffe1b6852..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) False a = _w0 -(-/) True a = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.hs deleted file mode 100644 index bfe7bdafb3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutPrefixKeep.hs +++ /dev/null @@ -1,3 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) b a = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.expected.hs deleted file mode 100644 index ef639a9839..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Pair a b = Pair {pa :: a, pb :: b} - -p :: Pair (a -> a) (a -> b -> c -> b) -p = Pair {pa = _, pb = \ a b c -> _w0} - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.hs deleted file mode 100644 index 47a9895c2e..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutRec.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Pair a b = Pair {pa :: a, pb :: b} - -p :: Pair (a -> a) (a -> b -> c -> b) -p = Pair {pa = _, pb = _} - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.expected.hs deleted file mode 100644 index 9bcb21c9e7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -class Test a where - test :: Bool -> a - test False = _w0 - test True = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.hs deleted file mode 100644 index c082169c7b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitClass.hs +++ /dev/null @@ -1,4 +0,0 @@ -class Test a where - test :: Bool -> a - test x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.expected.hs deleted file mode 100644 index 6b73dfb0ec..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = case b of - False -> _w0 - True -> _w1 diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.hs deleted file mode 100644 index be2d0d30f5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitGuard.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.expected.hs deleted file mode 100644 index 8095217673..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in case a of { (n, s) -> _w0 } - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.hs deleted file mode 100644 index ce6e0341c4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitIn.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.expected.hs deleted file mode 100644 index ba63836df3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t False = _w0 - t True = _w1 - in _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.hs deleted file mode 100644 index 71529d7dd3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitLet.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t b = _ - in _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.expected.hs deleted file mode 100644 index 0f7ee4e388..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - - -test :: Maybe [Bool] -> Maybe Bool -test (JustSingleton False) = _w0 -test (JustSingleton True) = _w1 - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.hs deleted file mode 100644 index 0497bb7244..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPatSyn.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - - -test :: Maybe [Bool] -> Maybe Bool -test (JustSingleton a) = _ - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.expected.hs deleted file mode 100644 index b92544f622..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern Blah :: a -> Maybe a -pattern Blah a = Just a - -test :: Maybe Bool -> a -test (Blah False) = _w0 -test (Blah True) = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.hs deleted file mode 100644 index 3cabb3c64b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern Blah :: a -> Maybe a -pattern Blah a = Just a - -test :: Maybe Bool -> a -test (Blah a) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.expected.hs deleted file mode 100644 index d123c652d7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> Nothing) = _w0 -splitLookup (lookup 5 -> (Just s)) = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.hs deleted file mode 100644 index 6baed55abd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitViewPat.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> a) = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.expected.hs deleted file mode 100644 index 28ad669007..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -data A = A | B | C - -some :: A -> IO () -some a = do - foo - bar a - where - foo = putStrLn "Hi" - - bar :: A -> IO () - bar A = _w0 - bar B = _w1 - bar C = _w2 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.hs b/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.hs deleted file mode 100644 index 5035df1b0c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/LayoutSplitWhere.hs +++ /dev/null @@ -1,12 +0,0 @@ -data A = A | B | C - -some :: A -> IO () -some a = do - foo - bar a - where - foo = putStrLn "Hi" - - bar :: A -> IO () - bar x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MessageCantUnify.hs b/plugins/hls-tactics-plugin/old/test/golden/MessageCantUnify.hs deleted file mode 100644 index 713f686338..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MessageCantUnify.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs #-} - -data Z ab where - Z :: (a -> b) -> Z '(a, b) - -test :: Z ab -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MessageForallA.hs b/plugins/hls-tactics-plugin/old/test/golden/MessageForallA.hs deleted file mode 100644 index 1498dfd8e4..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MessageForallA.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -test = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/MessageNotEnoughGas.hs b/plugins/hls-tactics-plugin/old/test/golden/MessageNotEnoughGas.hs deleted file mode 100644 index 9156cc0053..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MessageNotEnoughGas.hs +++ /dev/null @@ -1,13 +0,0 @@ -test - :: (a1 -> a2) - -> (a2 -> a3) - -> (a3 -> a4) - -> (a4 -> a5) - -> (a5 -> a6) - -> (a6 -> a7) - -> (a7 -> a8) - -> (a8 -> a9) - -> (a9 -> a10) - -> a1 -> a10 -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.expected.hs deleted file mode 100644 index 3c56bdbee9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.expected.hs +++ /dev/null @@ -1 +0,0 @@ -foo = [wingman||] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.hs deleted file mode 100644 index fdfbd7289d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBegin.hs +++ /dev/null @@ -1 +0,0 @@ -foo = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.expected.hs deleted file mode 100644 index c8aa76e837..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = [wingman||] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.hs deleted file mode 100644 index 2aa2d1caa3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBeginNoWildify.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.expected.hs deleted file mode 100644 index 00421ee479..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.hs deleted file mode 100644 index d25670bca1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBindAll.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split; assumption |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.expected.hs deleted file mode 100644 index 05f86c9963..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, _w0) diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.hs deleted file mode 100644 index fe6c118829..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaBindOne.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split, assumption |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.expected.hs deleted file mode 100644 index aac10101ec..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.expected.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data AST a where - BoolLit :: Bool -> AST Bool - IntLit :: Int -> AST Int - If :: AST Bool -> AST a -> AST a -> AST a - Equal :: AST a -> AST a -> AST Bool - -eval :: AST a -> a -eval (BoolLit b) = b -eval (IntLit n) = n -eval (If ast ast' ast_a) - = let - ast_c = eval ast - ast'_c = eval ast' - ast_a_c = eval ast_a - in _w0 ast_c ast'_c ast_a_c -eval (Equal ast ast') - = let - ast_c = eval ast - ast'_c = eval ast' - in _w1 ast_c ast'_c - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.hs deleted file mode 100644 index 26e3a03cec..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataAST.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data AST a where - BoolLit :: Bool -> AST Bool - IntLit :: Int -> AST Int - If :: AST Bool -> AST a -> AST a -> AST a - Equal :: AST a -> AST a -> AST Bool - -eval :: AST a -> a -eval = [wingman| intros x, cata x; collapse |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.expected.hs deleted file mode 100644 index 58b4fb4ffc..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f, Yo g) => Yo (f :*: g) where - yo (fx :*: gx) - = let - fx_c = yo fx - gx_c = yo gx - in _w0 fx_c gx_c - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.hs deleted file mode 100644 index 14dc163f4d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapse.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f, Yo g) => Yo (f :*: g) where - yo = [wingman| intros x, cata x, collapse |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.expected.hs deleted file mode 100644 index e9cef291a3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f) => Yo (M1 _1 _2 f) where - yo (M1 fx) = yo fx - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.hs deleted file mode 100644 index c1abb0acf2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaCataCollapseUnary.hs +++ /dev/null @@ -1,8 +0,0 @@ -import GHC.Generics - -class Yo f where - yo :: f x -> Int - -instance (Yo f) => Yo (M1 _1 _2 f) where - yo = [wingman| intros x, cata x, collapse |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.expected.hs deleted file mode 100644 index c9d2f0cff9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = ((a, b), c) diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.hs deleted file mode 100644 index 97e5b424ba..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaChoice.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = [wingman| split; split | assume c; assume a | assume b |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.expected.hs deleted file mode 100644 index 90216da0a2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -whats_it_deep_of - :: (a -> a) - -> [(Int, Either Bool (Maybe [a]))] - -> [(Int, Either Bool (Maybe [a]))] --- The assumption here is necessary to tie-break in favor of the longest --- nesting of fmaps. -whats_it_deep_of f = fmap (fmap (fmap (fmap (fmap f)))) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.hs deleted file mode 100644 index 3afcdcc4e1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaDeepOf.hs +++ /dev/null @@ -1,8 +0,0 @@ -whats_it_deep_of - :: (a -> a) - -> [(Int, Either Bool (Maybe [a]))] - -> [(Int, Either Bool (Maybe [a]))] --- The assumption here is necessary to tie-break in favor of the longest --- nesting of fmaps. -whats_it_deep_of f = [wingman| nested fmap, assumption |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.expected.hs deleted file mode 100644 index f589d989f7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -class Blah a b | a -> b, b -> a -instance Blah Int Bool - -foo :: Int -foo = 10 - -bar :: Blah a b => a -> b -bar = undefined - -qux :: Bool -qux = bar foo - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.hs deleted file mode 100644 index 36d0d4bf73..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaFundeps.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -class Blah a b | a -> b, b -> a -instance Blah Int Bool - -foo :: Int -foo = 10 - -bar :: Blah a b => a -> b -bar = undefined - -qux :: Bool -qux = [wingman| use bar, use foo |] - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.expected.hs deleted file mode 100644 index 21569c7c19..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = (foo <$> _w0) <*> _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.hs deleted file mode 100644 index f9506cb03b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiom.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = [wingman| idiom (use foo) |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.expected.hs deleted file mode 100644 index e39e9a9fab..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = (Rec <$> _w0) <*> _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.hs deleted file mode 100644 index 87397da160..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaIdiomRecord.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = [wingman| idiom (ctor Rec) |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.expected.hs deleted file mode 100644 index 54c3678c21..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test - = let - a = _w0 - b = _w1 - c = _w2 - in _w3 diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.hs deleted file mode 100644 index ae570bae7b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaLetSimple.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Int -test = [wingman| let a b c |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.expected.hs deleted file mode 100644 index e0b60b74fa..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b -maybeAp Nothing Nothing = Nothing -maybeAp Nothing (Just _) = Nothing -maybeAp (Just _) Nothing = Nothing -maybeAp (Just fab) (Just a) = Just (fab a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.hs deleted file mode 100644 index 6159db4ecd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaMaybeAp.hs +++ /dev/null @@ -1,11 +0,0 @@ -maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b -maybeAp = [wingman| - intros, - destruct_all, - obvious, - obvious, - obvious, - ctor Just, - application, - assumption - |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.expected.hs deleted file mode 100644 index f92e7d40af..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Data.Monoid - -data Foo = Foo (Sum Int) (Sum Int) - -mappend2 :: Foo -> Foo -> Foo -mappend2 (Foo sum sum') (Foo sum2 sum3) - = Foo (mappend sum sum2) (mappend sum' sum3) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.hs deleted file mode 100644 index 77572569ff..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaPointwise.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Monoid - -data Foo = Foo (Sum Int) (Sum Int) - -mappend2 :: Foo -> Foo -> Foo -mappend2 = [wingman| intros f1 f2, destruct_all, ctor Foo; pointwise (use mappend); assumption|] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaTry.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaTry.expected.hs deleted file mode 100644 index 0940f9ea21..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaTry.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = (_w0, a) diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaTry.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaTry.hs deleted file mode 100644 index 582189bcbc..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaTry.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = [wingman| split; try (assumption) |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.expected.hs deleted file mode 100644 index c72f18589c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = isAlpha - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.hs deleted file mode 100644 index 87ac26bbcb..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseImport.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = [wingman| intro c, use isAlpha, assume c |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.expected.hs deleted file mode 100644 index 1afee3471a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = test - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.hs deleted file mode 100644 index 0f791818d1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseLocal.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.expected.hs deleted file mode 100644 index acf46a75a0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = test - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.hs deleted file mode 100644 index 4723befd10..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.expected.hs deleted file mode 100644 index 85012d7aaf..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = _w0 <> _w1 diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.hs deleted file mode 100644 index 4afe5f572d..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaUseSymbol.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = [wingman| use (<>) |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.expected.hs deleted file mode 100644 index 895e9333c0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = _w0 a diff --git a/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.hs b/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.hs deleted file mode 100644 index 75c6ab0445..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/MetaWithArg.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = [wingman| with_arg, assumption |] diff --git a/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.expected.hs deleted file mode 100644 index 4bbd4d283a..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah _ = Record - diff --git a/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.hs b/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.hs deleted file mode 100644 index 82b994b936..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/NewtypeRecord.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/ProvideAlreadyDestructed.hs b/plugins/hls-tactics-plugin/old/test/golden/ProvideAlreadyDestructed.hs deleted file mode 100644 index 2da53afbf5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/ProvideAlreadyDestructed.hs +++ /dev/null @@ -1,9 +0,0 @@ -foo :: Bool -> () -foo x = - if True - then - case x of - True -> _ - False -> () - else - _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/ProvideLocalHyOnly.hs b/plugins/hls-tactics-plugin/old/test/golden/ProvideLocalHyOnly.hs deleted file mode 100644 index 6a15b198dd..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/ProvideLocalHyOnly.hs +++ /dev/null @@ -1,2 +0,0 @@ -basilisk :: Monoid Bool => a -basilisk = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/ProviderHomomorphism.hs b/plugins/hls-tactics-plugin/old/test/golden/ProviderHomomorphism.hs deleted file mode 100644 index dc096f38f1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/ProviderHomomorphism.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} - -data GADT a where - B1 :: GADT Bool - B2 :: GADT Bool - Int :: GADT Int - Var :: GADT a - - -hasHomo :: GADT Bool -> GADT a -hasHomo g = _ - -cantHomo :: GADT a -> GADT Int -cantHomo g = _ - -hasHomoLam :: GADT Bool -> GADT a -hasHomoLam = _ - -cantHomoLam :: GADT a -> GADT Int -cantHomoLam = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/PunGADT.expected.hs deleted file mode 100644 index 9bdcd61516..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - - -split :: GADT a -> a -split GADT {blah, bar} = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/PunGADT.hs deleted file mode 100644 index 250479e758..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - - -split :: GADT a -> a -split x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunMany.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/PunMany.expected.hs deleted file mode 100644 index 7b661c2ee5..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunMany.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Many - = Hello { world :: String } - | Goodbye { a :: Int, b :: Bool, c :: Many } - -test :: Many -> Many -test Hello {world} = _w0 -test Goodbye {a, b, c} = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunMany.hs b/plugins/hls-tactics-plugin/old/test/golden/PunMany.hs deleted file mode 100644 index 77234a7359..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunMany.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Many - = Hello { world :: String } - | Goodbye { a :: Int, b :: Bool, c :: Many } - -test :: Many -> Many -test x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.expected.hs deleted file mode 100644 index 5b3eaf2559..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.expected.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - Bar :: - { zoo :: Bool - , baxter :: a - , another :: a - } -> GADT Bool - Baz :: GADT Int - - -split :: GADT Bool -> a -split GADT {blah, bar} = _w0 -split Bar {zoo, baxter, another} = _w1 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.hs deleted file mode 100644 index 70badb7ae2..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunManyGADT.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - Bar :: - { zoo :: Bool - , baxter :: a - , another :: a - } -> GADT Bool - Baz :: GADT Int - - -split :: GADT Bool -> a -split x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.expected.hs deleted file mode 100644 index d3cc689a04..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax Bar {ax = n, bax} = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.hs b/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.hs deleted file mode 100644 index f2cce07cbc..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunShadowing.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunSimple.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/PunSimple.expected.hs deleted file mode 100644 index 65bc2d28d0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunSimple.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar Bar {ax, bax} = _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/PunSimple.hs b/plugins/hls-tactics-plugin/old/test/golden/PunSimple.hs deleted file mode 100644 index 6707399c28..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/PunSimple.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar x = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RecordCon.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RecordCon.expected.hs deleted file mode 100644 index cfc2235bfb..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RecordCon.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -data MyRecord a = Record - { field1 :: a - , field2 :: Int - } - -blah :: (a -> Int) -> a -> MyRecord a -blah f a = Record {field1 = a, field2 = f a} - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RecordCon.hs b/plugins/hls-tactics-plugin/old/test/golden/RecordCon.hs deleted file mode 100644 index 651983e8a3..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RecordCon.hs +++ /dev/null @@ -1,9 +0,0 @@ -data MyRecord a = Record - { field1 :: a - , field2 :: Int - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineCon.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineCon.expected.hs deleted file mode 100644 index 7110f637da..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineCon.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = (_w0, _w1, _w2) - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineCon.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineCon.hs deleted file mode 100644 index dc611f6e93..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineCon.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.expected.hs deleted file mode 100644 index 605f5e0a5c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - One :: (b -> Int) -> GADT Int - Two :: GADT Bool - -test :: z -> GADT Int -test z = One _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.hs deleted file mode 100644 index 6ac2853173..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineGADT.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - One :: (b -> Int) -> GADT Int - Two :: GADT Bool - -test :: z -> GADT Int -test z = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.expected.hs deleted file mode 100644 index 5c99dfc3a1..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test a = _w0 diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.hs deleted file mode 100644 index afe7524957..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineIntro.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.expected.hs deleted file mode 100644 index 2d72de4c9b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = \ m_n -> _w0 - where - -- Don't delete me! - blah = undefined - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.hs deleted file mode 100644 index a9e4ca1db7..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineIntroWhere.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = _ - where - -- Don't delete me! - blah = undefined - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineReader.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineReader.expected.hs deleted file mode 100644 index 267e6b8015..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineReader.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = Reader _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/RefineReader.hs b/plugins/hls-tactics-plugin/old/test/golden/RefineReader.hs deleted file mode 100644 index 9e68e115e9..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/RefineReader.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.expected.hs deleted file mode 100644 index c76acc0d31..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -data ADT = One | Two Int | Three | Four Bool ADT | Five - -case_split :: ADT -> Int -case_split One = _ -case_split (Two i) = _ -case_split Three = _ -case_split (Four b One) = _w0 -case_split (Four b (Two n)) = _w1 -case_split (Four b Three) = _w2 -case_split (Four b (Four b' adt)) = _w3 -case_split (Four b Five) = _w4 -case_split Five = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.hs b/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.hs deleted file mode 100644 index ba66257007..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/SplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -data ADT = One | Two Int | Three | Four Bool ADT | Five - -case_split :: ADT -> Int -case_split One = _ -case_split (Two i) = _ -case_split Three = _ -case_split (Four b a) = _ -case_split Five = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.expected.hs deleted file mode 100644 index e638fa311c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f (Dummy n) = n - diff --git a/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.hs b/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.hs deleted file mode 100644 index 7487adf038..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/SubsequentTactics.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/T1.hs b/plugins/hls-tactics-plugin/old/test/golden/T1.hs deleted file mode 100644 index 7ab382d69f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/T1.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapEither :: (a -> b) -> Either c a -> Either c b -fmapEither = _lalala - diff --git a/plugins/hls-tactics-plugin/old/test/golden/T2.hs b/plugins/hls-tactics-plugin/old/test/golden/T2.hs deleted file mode 100644 index 20b1644a8f..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/T2.hs +++ /dev/null @@ -1,12 +0,0 @@ -eitherFmap :: (a -> b) -> Either e a -> Either e b -eitherFmap fa eab = _ - -global :: Bool -global = True - -foo :: Int -foo = _ - -dontSuggestLambdaCase :: Either a b -> Int -dontSuggestLambdaCase = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/T3.hs b/plugins/hls-tactics-plugin/old/test/golden/T3.hs deleted file mode 100644 index 1bb42a9b02..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/T3.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -suggestHomomorphicLC :: Either a b -> Either a b -suggestHomomorphicLC = _ - -suggestLC :: Either a b -> Int -suggestLC = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.expected.hs deleted file mode 100644 index 26d6d77b8b..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Left _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.hs deleted file mode 100644 index 59d03ae7d0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConLeft.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConPair.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConPair.expected.hs deleted file mode 100644 index 1a5caad890..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConPair.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = (_w0, _w1) diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConPair.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConPair.hs deleted file mode 100644 index 2d15fe3500..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConPair.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = _ diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConRight.expected.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConRight.expected.hs deleted file mode 100644 index f36809804c..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConRight.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Right _w0 - diff --git a/plugins/hls-tactics-plugin/old/test/golden/UseConRight.hs b/plugins/hls-tactics-plugin/old/test/golden/UseConRight.hs deleted file mode 100644 index 59d03ae7d0..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/UseConRight.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/plugins/hls-tactics-plugin/old/test/golden/hie.yaml b/plugins/hls-tactics-plugin/old/test/golden/hie.yaml deleted file mode 100644 index 7aa4f9e0ad..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/hie.yaml +++ /dev/null @@ -1 +0,0 @@ -cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/plugins/hls-tactics-plugin/old/test/golden/test.cabal b/plugins/hls-tactics-plugin/old/test/golden/test.cabal deleted file mode 100644 index 845edafa26..0000000000 --- a/plugins/hls-tactics-plugin/old/test/golden/test.cabal +++ /dev/null @@ -1,17 +0,0 @@ -name: test -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Author name here -maintainer: example@example.com -copyright: 2017 Author name here -category: Web -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: T1, T2 - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall -fwarn-unused-imports diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index e12e5e9f35..aadd56bbde 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -28,10 +28,6 @@ import qualified Ide.Plugin.Cabal as Cabal import qualified Ide.Plugin.Class as Class #endif -#if hls_haddockComments -import qualified Ide.Plugin.HaddockComments as HaddockComments -#endif - #if hls_eval import qualified Ide.Plugin.Eval as Eval #endif @@ -50,18 +46,10 @@ import qualified Ide.Plugin.Rename as Rename import qualified Ide.Plugin.Retrie as Retrie #endif -#if hls_tactic -import qualified Ide.Plugin.Tactic as Tactic -#endif - #if hls_hlint import qualified Ide.Plugin.Hlint as Hlint #endif -#if hls_stan -import qualified Ide.Plugin.Stan as Stan -#endif - #if hls_moduleName import qualified Ide.Plugin.ModuleName as ModuleName #endif @@ -165,9 +153,6 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins -- cabalFormattingProvider in the Default Config let pId = "cabal-fmt" in CabalFmt.descriptor (pluginRecorder pId) pId: #endif -#if hls_tactic - let pId = "tactics" in Tactic.descriptor (pluginRecorder pId) pId: -#endif #if hls_ormolu let pId = "ormolu" in Ormolu.descriptor (pluginRecorder pId) pId : #endif @@ -186,9 +171,6 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_class let pId = "class" in Class.descriptor (pluginRecorder pId) pId: #endif -#if hls_haddockComments - let pId = "haddockComments" in HaddockComments.descriptor (pluginRecorder pId) pId: -#endif #if hls_eval let pId = "eval" in Eval.descriptor (pluginRecorder pId) pId: #endif @@ -204,9 +186,6 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_hlint let pId = "hlint" in Hlint.descriptor (pluginRecorder pId) pId: #endif -#if hls_stan - let pId = "stan" in Stan.descriptor (pluginRecorder pId) pId : -#endif #if hls_splice Splice.descriptor "splice" : #endif diff --git a/stack-lts21.yaml b/stack-lts21.yaml index 81f7d89b1b..c119576d1f 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -23,7 +23,6 @@ packages: - ./plugins/hls-floskell-plugin - ./plugins/hls-fourmolu-plugin - ./plugins/hls-gadt-plugin - # - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin @@ -34,9 +33,7 @@ packages: - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - # - ./plugins/hls-stan-plugin - ./plugins/hls-stylish-haskell-plugin - # - ./plugins/hls-tactics-plugin ghc-options: "$everything": -haddock diff --git a/stack.yaml b/stack.yaml index 540737f6ab..d335049fca 100644 --- a/stack.yaml +++ b/stack.yaml @@ -23,7 +23,6 @@ packages: # - ./plugins/hls-floskell-plugin - ./plugins/hls-fourmolu-plugin - ./plugins/hls-gadt-plugin - # - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin @@ -34,9 +33,7 @@ packages: - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - # - ./plugins/hls-stan-plugin - ./plugins/hls-stylish-haskell-plugin - # - ./plugins/hls-tactics-plugin ghc-options: "$everything": -haddock diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f82c5787c4..dfe9ba680b 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -8,7 +8,6 @@ import Control.Lens hiding (List) import Control.Monad import Data.Aeson.Lens (_Object) import Data.List -import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Compile (sourceTypecheck) @@ -307,16 +306,6 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "The wingman plugin doesn't yet compile in GHC92/GHC94" $ - testCase "doesn't work when wingman is active" $ - runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "TypedHoles.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - liftIO $ do - dontExpectCodeAction cas ["replace _ with minBound"] - dontExpectCodeAction cas ["replace _ with foo _"] - , testCase "shows more suggestions" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles2.hs" "haskell" @@ -340,17 +329,6 @@ typedHoleTests = testGroup "typed hole code actions" [ , " where" , " stuff (A a) = A (a + 1)" ] - - , knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "The wingman plugin doesn't yet compile in GHC92/GHC94" $ - testCase "doesnt show more suggestions when wingman is active" $ - runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "TypedHoles2.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - - liftIO $ do - dontExpectCodeAction cas ["replace _ with foo2 _"] - dontExpectCodeAction cas ["replace _ with A _"] ] signatureTests :: TestTree @@ -433,7 +411,6 @@ unusedTermTests = testGroup "unused term code actions" [ testConfig :: Config testConfig = def { formattingProvider = "none" - , plugins = M.insert "tactics" (def { plcGlobalOn = False }) (plugins def) }