diff --git a/cabal-ghc90.project b/cabal-ghc90.project index 38f318fdc4..fa2b2743e8 100644 --- a/cabal-ghc90.project +++ b/cabal-ghc90.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin tests: true diff --git a/cabal-ghc921.project b/cabal-ghc921.project index 8d22333014..8e6da76e6f 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin with-compiler: ghc-9.2.1 diff --git a/cabal.project b/cabal.project index e1c8aa98cf..21b372980b 100644 --- a/cabal.project +++ b/cabal.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-alternate-number-format-plugin ./plugins/hls-qualify-imported-names-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/docs/features.md b/docs/features.md index 2939daee00..dfb0b6b516 100644 --- a/docs/features.md +++ b/docs/features.md @@ -18,7 +18,7 @@ Many of these are standard LSP features, but a lot of special features are provi | [Highlight references](#highlight-references) | `textDocument/documentHighlight` | | [Code actions](#code-actions) | `textDocument/codeAction` | | [Code lenses](#code-lenses) | `textDocument/codeLens` | -| [Selection range](#selection-range) | `textDocument/selectionRange` | +| [Selection range](#selection-range) | `textDocument/selectionRange` | The individual sections below also identify which [HLS plugin](./what-is-hls.md#hls-plugins) is responsible for providing the given functionality, which is useful if you want to raise an issue report or contribute! Additionally, not all plugins are supported on all versions of GHC, see the [GHC version support page](supported-versions.md) for details. @@ -237,6 +237,26 @@ Provides a variety of code actions for interactive code development, see =1.0.0.0 cpp-options: -DselectionRange +common changeTypeSignature + if flag(changeTypeSignature) + build-depends: hls-change-type-signature-plugin ^>=1.0.0.0 + cpp-options: -DchangeTypeSignature + -- formatters common floskell @@ -334,6 +344,7 @@ executable haskell-language-server -- plugins , example-plugins , callHierarchy + , changeTypeSignature , class , haddockComments , eval diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 5df855f356..8dc33fbdbe 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -27,6 +27,7 @@ module Ide.PluginUtils subRange, positionInRange, usePropertyLsp, + getNormalizedFilePath, response, handleMaybe, handleMaybeM, @@ -34,6 +35,7 @@ module Ide.PluginUtils where +import Control.Lens ((^.)) import Control.Monad.Extra (maybeM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) @@ -54,6 +56,7 @@ import Language.LSP.Types hiding SemanticTokensEdit (_start)) import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities +import Language.LSP.Types.Lens (uri) -- --------------------------------------------------------------------- @@ -243,6 +246,15 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- +getNormalizedFilePath :: Monad m => PluginId -> TextDocumentIdentifier -> ExceptT String m NormalizedFilePath +getNormalizedFilePath (PluginId plId) docId = handleMaybe errMsg + $ uriToNormalizedFilePath + $ toNormalizedUri uri' + where + errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri' <> " to NormalizedFilePath" + uri' = docId ^. uri + +-- --------------------------------------------------------------------- handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return diff --git a/plugins/hls-change-type-signature-plugin/LICENSE b/plugins/hls-change-type-signature-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-change-type-signature-plugin/README.md b/plugins/hls-change-type-signature-plugin/README.md new file mode 100644 index 0000000000..0c93f53296 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/README.md @@ -0,0 +1,16 @@ +# Change Type Signature Plugin + +The change type signature plugin provides a code action to change a user's current type signature to it's actual type signature. +The plugin does not work in all error scenarios. Currently, the plugin uses GHC diagnostic messages to recover the actual type of a function. +If the plugin receives enough information it can correctly change the signature. + +## Demo + +![Change Type Signature One](change1.gif) + +![Change Type Signature Two](change2.gif) + + +## Changelog +### 1.0.0.0 +- First Release diff --git a/plugins/hls-change-type-signature-plugin/change1.gif b/plugins/hls-change-type-signature-plugin/change1.gif new file mode 100644 index 0000000000..de06051545 Binary files /dev/null and b/plugins/hls-change-type-signature-plugin/change1.gif differ diff --git a/plugins/hls-change-type-signature-plugin/change2.gif b/plugins/hls-change-type-signature-plugin/change2.gif new file mode 100644 index 0000000000..b7d007524d Binary files /dev/null and b/plugins/hls-change-type-signature-plugin/change2.gif differ diff --git a/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal new file mode 100644 index 0000000000..64bc9b8a4a --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.4 +name: hls-change-type-signature-plugin +version: 1.0.0.0 +synopsis: Change a declarations type signature with a Code Action +description: + Please see the README on GitHub at + +license: Apache-2.0 +license-file: LICENSE +author: Nick Suchecki +maintainer: nicksuchecki@gmail.com +category: Development +build-type: Simple +extra-source-files: + LICENSE + README.md + test/testdata/*.hs + test/testdata/*.yaml + +library + exposed-modules: Ide.Plugin.ChangeTypeSignature + hs-source-dirs: src + build-depends: + , base >=4.12 && < 5 + , ghcide ^>=1.6 + , hls-plugin-api ^>=1.3 + , lsp-types + , regex-tdfa + , syb + , text + , transformers + , unordered-containers + + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: + ConstraintKinds + DataKinds + ExplicitNamespaces + FlexibleContexts + NamedFieldPuns + OverloadedStrings + RecordWildCards + TypeOperators + + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall + build-depends: + , base >=4.12 && < 5 + , filepath + , hls-change-type-signature-plugin + , hls-test-utils ^>=1.2 + , lsp + , QuickCheck + , regex-tdfa + , text + default-extensions: + NamedFieldPuns + OverloadedStrings + TypeOperators + ViewPatterns diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs new file mode 100644 index 0000000000..ff86652710 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +-- | An HLS plugin to provide code actions to change type signatures +module Ide.Plugin.ChangeTypeSignature (descriptor + -- * For Unit Tests + , errorMessageRegexes + ) where + +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (asum) +import qualified Data.HashMap.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (realSrcSpanToRange) +import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) +import Development.IDE.Core.Service (IdeState, runAction) +import Development.IDE.Core.Shake (use) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util (prettyPrint) +import Generics.SYB (extQ, something) +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, response) +import Ide.Types (PluginDescriptor (..), + PluginId, PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Types +import Text.Regex.TDFA ((=~)) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler } + +codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionHandler ideState plId CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = response $ do + nfp <- getNormalizedFilePath plId (TextDocumentIdentifier uri) + decls <- getDecls ideState nfp + let actions = mapMaybe (generateAction uri decls) diags + pure $ List actions + +getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] +getDecls state = handleMaybeM "Error: Could not get Parsed Module" + . liftIO + . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source)) + . runAction "changeSignature.GetParsedModule" state + . use GetParsedModule + +-- | Text representing a Declaration's Name +type DeclName = Text +-- | The signature provided by GHC Error Message (Expected type) +type ExpectedSig = Text +-- | The signature provided by GHC Error Message (Actual type) +type ActualSig = Text + +-- | DataType that encodes the necessary information for changing a type signature +data ChangeSignature = ChangeSignature { + -- | The expected type based on Signature + expectedType :: ExpectedSig + -- | the Actual Type based on definition + , actualType :: ActualSig + -- | the declaration name to be updated + , declName :: DeclName + -- | the location of the declaration signature + , declSrcSpan :: RealSrcSpan + -- | the diagnostic to solve + , diagnostic :: Diagnostic + } + +-- | Constraint needed to trackdown OccNames in signatures +type SigName = (HasOccName (IdP GhcPs)) + +-- | Create a CodeAction from a Diagnostic +generateAction :: SigName => Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction) +generateAction uri decls diag = changeSigToCodeAction uri <$> diagnosticToChangeSig decls diag + +-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan +diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature +diagnosticToChangeSig decls diagnostic = do + -- regex match on the GHC Error Message + (expectedType, actualType, declName) <- matchingDiagnostic diagnostic + -- Find the definition and it's location + declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName) + pure $ ChangeSignature{..} + + +-- | If a diagnostic has the proper message create a ChangeSignature from it +matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName) +matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes + where + unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName) + -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match + unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name) + unwrapMatch _ = Nothing + +-- | List of regexes that match various Error Messages +errorMessageRegexes :: [Text] +errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests + "Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’" + , "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’" + ] + +-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches +-- both the name given and the Expected Type, and return the type signature location +findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan +findSigLocOfStringDecl decls expectedType declName = something (const Nothing `extQ` findSig `extQ` findLocalSig) decls + where + -- search for Top Level Signatures + findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan + findSig = \case + L (locA -> (RealSrcSpan rss _)) (SigD _ sig) -> case sig of + ts@(TypeSig _ idsSig _) -> isMatch ts idsSig >> pure rss + _ -> Nothing + _ -> Nothing + + -- search for Local Signatures + findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan + findLocalSig = \case + (L (locA -> (RealSrcSpan rss _)) ts@(TypeSig _ idsSig _)) -> isMatch ts idsSig >> pure rss + _ -> Nothing + + -- Does the declName match? and does the expected signature match? + isMatch ts idsSig = do + ghcSig <- sigToText ts + guard (any compareId idsSig && expectedType == ghcSig) + + -- Given an IdP check to see if it matches the declName + compareId (L _ id') = declName == occNameString (occName id') + + + +-- | Pretty Print the Type Signature (to validate GHC Error Message) +sigToText :: Sig GhcPs -> Maybe Text +sigToText = \case + ts@TypeSig {} -> stripSignature $ T.pack $ prettyPrint ts + _ -> Nothing + +stripSignature :: Text -> Maybe Text +-- for whatever reason incoming signatures MAY have new lines after "::" or "=>" +stripSignature sig = case T.filter (/= '\n') sig =~ sigRegex :: (Text, Text, Text, [Text]) of + -- No constraints (Monad m =>) + (_, _, _, [sig']) -> Just $ T.strip sig' + -- Ignore constraints (Monad m =>) + (_, _, _, [_, sig']) -> Just $ T.strip sig' + _ -> Nothing + where + -- we want to test everthing after the constraints (GHC never gives us the constraint in the expected signature) + sigRegex = ".* :: (.*=>)?(.*)" :: Text + + +changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction +changeSigToCodeAction uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType + , _kind = Just (CodeActionUnknown "quickfix.changeSignature") + , _diagnostics = Just $ List [diagnostic] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType) + , _command = Nothing + , _xdata = Nothing + } + +mkChangeSigTitle :: Text -> Text -> Text +mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> "’ to: " <> actualType + +mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit +mkChangeSigEdit uri ss replacement = + let txtEdit = TextEdit (realSrcSpanToRange ss) replacement + changes = Just $ Map.singleton uri (List [txtEdit]) + in WorkspaceEdit changes Nothing Nothing + +mkNewSignature :: Text -> Text -> Text +mkNewSignature declName actualType = declName <> " :: " <> actualType diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs new file mode 100644 index 0000000000..2cfb7b35c4 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -0,0 +1,123 @@ +module Main where + +import Data.Either (rights) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes) +import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +import System.FilePath ((<.>), ()) +import Test.Hls (CodeAction (..), + CodeActionKind (CodeActionQuickFix), + Command, IdeState, + PluginDescriptor, + Position (Position), + Range (Range), Session, + TestName, TestTree, + TextDocumentIdentifier, + assertBool, assertFailure, + defaultTestRunner, + executeCodeAction, + getCodeActions, + goldenWithHaskellDoc, liftIO, + openDoc, runSessionWithServer, + testCase, testGroup, toEither, + type (|?) (InR), + waitForDiagnostics, + waitForProgressDone, (@=?), + (@?=)) +import Text.Regex.TDFA ((=~)) + +main :: IO () +main = defaultTestRunner test + +changeTypeSignaturePlugin :: PluginDescriptor IdeState +changeTypeSignaturePlugin = ChangeTypeSignature.descriptor "changeTypeSignature" + +test :: TestTree +test = testGroup "changeTypeSignature" [ + codeActionTest "TExpectedActual" 4 11 + , codeActionTest "TRigidType" 4 14 + , codeActionTest "TLocalBinding" 6 21 + , codeActionTest "TLocalBindingShadow1" 10 7 + , codeActionTest "TLocalBindingShadow2" 6 21 + , codeActionProperties "TErrorGivenPartialSignature" [(4, 13)] $ \actions -> liftIO $ length actions @?= 0 + , testRegexes + ] + +testRegexes :: TestTree +testRegexes = testGroup "Regex Testing" [ + testRegexOne + , testRegexTwo + ] + where + regex1 = errorMessageRegexes !! 0 + regex2 = errorMessageRegexes !! 1 + +testRegexOne :: TestTree +testRegexOne = testGroup "Regex One" [ + regexTest "error1.txt" regex True + , regexTest "error2.txt" regex True + , regexTest "error3.txt" regex False + , regexTest "error4.txt" regex True + , regexTest "error5.txt" regex True + ] + where + regex = errorMessageRegexes !! 0 + +testRegexTwo :: TestTree +testRegexTwo = testGroup "Regex Two" [ + regexTest "error1.txt" regex False + , regexTest "error2.txt" regex False + , regexTest "error3.txt" regex True + , regexTest "error4.txt" regex False + , regexTest "error5.txt" regex False + ] + where + regex = errorMessageRegexes !! 1 + +testDataDir :: FilePath +testDataDir = "test" "testdata" + +goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenChangeSignature fp = goldenWithHaskellDoc changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" + +codeActionTest :: FilePath -> Int -> Int -> TestTree +codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do + waitForDiagnostics -- code actions are triggered from Diagnostics + actions <- getCodeActions doc (pointRange line col) + foundActions <- findChangeTypeActions actions + liftIO $ length foundActions @?= 1 + executeCodeAction (head foundActions) + +codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree +codeActionProperties fp locs assertions = testCase fp $ do + runSessionWithServer changeTypeSignaturePlugin testDataDir $ do + openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions + where + codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs + +findChangeTypeActions :: [Command |? CodeAction] -> Session [CodeAction] +findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither + where + isChangeTypeAction CodeAction{_kind} = case _kind of + Nothing -> False + Just kind -> case kind of + "quickfix.changeSignature" -> True + _ -> False + + +regexTest :: FilePath -> Text -> Bool -> TestTree +regexTest fp regex shouldPass = testCase fp $ do + msg <- TIO.readFile (testDataDir fp) + case (msg =~ regex :: (Text, Text, Text, [Text]), shouldPass) of + ((_, _, _, [_, _, _, _]), True) -> pure () + ((_, _, _, [_, _, _, _]), False) -> assertFailure $ "Unexpected match: " <> fp <> " with " <> T.unpack regex + (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex + (_, False) -> pure () + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs new file mode 100644 index 0000000000..caa595242a --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs @@ -0,0 +1,4 @@ +module ErrorGivenPartialSignature where + +partial :: Int -> Int +partial x = init x diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs new file mode 100644 index 0000000000..1d331c00bd --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: [Int] -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs new file mode 100644 index 0000000000..2a7629c392 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: Int -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs new file mode 100644 index 0000000000..4e15704726 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs @@ -0,0 +1,6 @@ +module TLocalBinding where + +local :: Int -> Int +local x = let test :: [Int] -> Int + test = head . reverse + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs new file mode 100644 index 0000000000..3937213237 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs @@ -0,0 +1,6 @@ +module TLocalBinding where + +local :: Int -> Int +local x = let test :: Int -> Int + test = head . reverse + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs new file mode 100644 index 0000000000..b8a5243f18 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs @@ -0,0 +1,9 @@ +module TLocalBindingShadow1 where + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: [Double] -> Double +test = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs new file mode 100644 index 0000000000..80a2cce85e --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs @@ -0,0 +1,9 @@ +module TLocalBindingShadow1 where + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: Int -> Double +test = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs new file mode 100644 index 0000000000..749ebc56b1 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs @@ -0,0 +1,9 @@ +module TLocalBindingShadow2 where + +local :: Int -> Int +local x = let test :: [Int] -> Int + test = head . reverse + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs new file mode 100644 index 0000000000..c274a462bc --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs @@ -0,0 +1,9 @@ +module TLocalBindingShadow2 where + +local :: Int -> Int +local x = let test :: Int -> Int + test = head . reverse + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs new file mode 100644 index 0000000000..0158112123 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: [[Int]] -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs new file mode 100644 index 0000000000..d5d7fa4b10 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: a -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt new file mode 100644 index 0000000000..37f0aa4a81 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘Int’ + with ‘Data.HashSet.Internal.HashSet Int’ + Expected type: Int -> Int + Actual type: Data.HashSet.Internal.HashSet Int -> Int + • In the expression: head . toList + In an equation for ‘test’: test = head . toList diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt new file mode 100644 index 0000000000..497f8350a5 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘b0 -> t0 a0 -> b0’ with ‘Int’ + Expected type: Int -> Int + Actual type: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 + • Probable cause: ‘foldl’ is applied to too few arguments + In the expression: foldl + In an equation for ‘test’: test = foldl diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt new file mode 100644 index 0000000000..0cbddad7c4 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt @@ -0,0 +1,10 @@ + • Couldn't match expected type ‘Int’ with actual type ‘[Int]’ + • In the expression: map (+ x) [1, 2, 3] + In an equation for ‘test’: + test x + = map (+ x) [1, 2, 3] + where + go = head . reverse + | +152 | test x = map (+ x) [1,2,3] + | ^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt new file mode 100644 index 0000000000..323cf7d4db --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt @@ -0,0 +1,19 @@ + • Couldn't match type ‘a’ with ‘[[Int]]’ + ‘a’ is a rigid type variable bound by + the type signature for: + test :: forall a. Ord a => a -> Int + at src/Ide/Plugin/ChangeTypeSignature.hs:154:1-25 + Expected type: a -> Int + Actual type: [[Int]] -> Int + • In the expression: go . head . reverse + In an equation for ‘test’: + test + = go . head . reverse + where + go = head . reverse + • Relevant bindings include + test :: a -> Int + (bound at src/Ide/Plugin/ChangeTypeSignature.hs:155:1) + | +155 | test = go . head . reverse + | ^^^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt new file mode 100644 index 0000000000..a7a5d9a20b --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt @@ -0,0 +1,15 @@ + • Couldn't match type ‘(a0 -> m0 b0) -> m0 (t0 b0)’ with ‘Int’ + Expected type: Int -> Int + Actual type: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + • Probable cause: ‘forM’ is applied to too few arguments + In the expression: forM + In an equation for ‘test’: test = forM + In an equation for ‘implicit’: + implicit + = return OpTEmpty + where + test :: Int -> Int + test = forM + | +82 | test = forM + | ^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..8af53b6833 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml @@ -0,0 +1,12 @@ +cradle: + direct: + arguments: + - -i + - -i. + - TExpectedActual + - TRigidType + - TErrorGivenPartialSignature + - TLocalBinding + - TLocalBindingShadow1 + - TLocalBindingShadow2 + - -Wall diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index c50a666198..b8f73e5d3c 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -31,6 +31,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 4a20d069c1..eee77c13ba 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 30c32d808b..1fd9b152e4 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index e6ddbe7651..54f681e5a9 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index fec732f0f5..2583adc92b 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml index dfe06176e5..4ddb4df079 100644 --- a/stack-9.0.2.yaml +++ b/stack-9.0.2.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 diff --git a/stack-9.2.1.yaml b/stack-9.2.1.yaml index 49b917e73b..5cad2e5a5d 100644 --- a/stack-9.2.1.yaml +++ b/stack-9.2.1.yaml @@ -28,8 +28,9 @@ packages: - ./plugins/hls-pragmas-plugin - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin -# - ./plugins/hls-alternate-number-format-plugin +- ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 diff --git a/stack.yaml b/stack.yaml index c5b2ecccd3..3baaf4529d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock