diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/hls-refactor-plugin.cabal b/hls-refactor-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-refactor-plugin.cabal @@ -0,0 +1,124 @@ +cabal-version: 3.0 +name: hls-refactor-plugin +version: 1.0.0.0 +synopsis: Exactprint refactorings for Haskell Language Server +description: + Please see the README on GitHub at + +license: Apache-2.0 +license-file: LICENSE +author: The Haskell IDE Team +copyright: The Haskell IDE Team +maintainer: zubin.duggal@gmail.com +category: Development +build-type: Simple +extra-source-files: + LICENSE + test/data/**/*.hs + test/data/**/*.yaml + +library + if impl(ghc >= 9.3) + buildable: False + else + buildable: True + exposed-modules: Development.IDE.GHC.ExactPrint + Development.IDE.GHC.Compat.ExactPrint + Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.Util + Development.IDE.GHC.Dump + other-modules: Development.IDE.Plugin.CodeAction.Args + Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.CodeAction.PositionIndexed + default-extensions: + BangPatterns + CPP + DataKinds + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + ViewPatterns + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , ghc + , bytestring + , ghc-boot + , regex-tdfa + , text-rope + , ghcide ^>=1.8 + , hls-plugin-api ^>=1.3 || ^>=1.4 || ^>= 1.5 + , lsp + , text + , transformers + , unordered-containers + , containers + , ghc-exactprint < 1 || >= 1.4 + , extra + , retrie + , syb + , hls-graph + , dlist + , deepseq + , mtl + , lens + , data-default + , time + ghc-options: -Wall -Wno-name-shadowing + default-language: Haskell2010 + +test-suite tests + if impl(ghc >= 9.3) + buildable: False + else + buildable: True + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports + build-depends: + , base + , filepath + , hls-refactor-plugin + , hls-test-utils ^>=1.4 + , lens + , lsp-types + , text + , aeson + , hls-plugin-api + , parser-combinators + , data-default + , extra + , text-rope + , containers + , ghcide + , ghcide-test-utils + , shake + , hls-plugin-api + , lsp-test + , network-uri + , directory + , async + , regex-tdfa + , tasty-rerun + , tasty-hunit + , tasty-expected-failure + , tasty diff --git a/src/Development/IDE/GHC/Compat/ExactPrint.hs b/src/Development/IDE/GHC/Compat/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -0,0 +1,38 @@ +-- | This module contains compatibility constructs to write type signatures across +-- multiple ghc-exactprint versions, accepting that anything more ambitious is +-- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint +module Development.IDE.GHC.Compat.ExactPrint +#if MIN_VERSION_ghc(9,3,0) + ( ) where +#else + ( ExactPrint + , exactPrint + , makeDeltaAst + , Retrie.Annotated, pattern Annotated, astA, annsA + ) where + +#if !MIN_VERSION_ghc(9,2,0) +import Control.Arrow ((&&&)) +#else +import Development.IDE.GHC.Compat.Parser +#endif +import Language.Haskell.GHC.ExactPrint as Retrie +import qualified Retrie.ExactPrint as Retrie + +#if !MIN_VERSION_ghc(9,2,0) +class ExactPrint ast where + makeDeltaAst :: ast -> ast + makeDeltaAst = id + +instance ExactPrint ast +#endif + +#if !MIN_VERSION_ghc(9,2,0) +pattern Annotated :: ast -> Anns -> Retrie.Annotated ast +pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA)) +#else +pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast +pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) +#endif + +#endif diff --git a/src/Development/IDE/GHC/Dump.hs b/src/Development/IDE/GHC/Dump.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Dump.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.GHC.Dump(showAstDataHtml) where +import Data.Data hiding (Fixity) +import Development.IDE.GHC.Compat hiding (NameAnn) +import Development.IDE.GHC.Compat.ExactPrint +#if MIN_VERSION_ghc(8,10,1) +import GHC.Hs.Dump +#else +import HsDumpAst +#endif +#if MIN_VERSION_ghc(9,2,1) +import qualified Data.ByteString as B +import Development.IDE.GHC.Compat.Util +import Generics.SYB (ext1Q, ext2Q, extQ) +import GHC.Hs +#endif +#if MIN_VERSION_ghc(9,0,1) +import GHC.Plugins +#else +import GhcPlugins +#endif +import Prelude hiding ((<>)) + +-- | Show a GHC syntax tree in HTML. +#if MIN_VERSION_ghc(9,2,1) +showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc +#else +showAstDataHtml :: (Data a, Outputable a) => a -> SDoc +#endif +showAstDataHtml a0 = html $ + header $$ + body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat + [ +#if MIN_VERSION_ghc(9,2,1) + li (pre $ text (exactPrint a0)), + li (showAstDataHtml' a0), + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) +#else + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan +#if MIN_VERSION_ghc(9,3,0) + NoBlankEpAnnotations +#endif + a0) +#endif + ]) + where + tag = tag' [] + tag' attrs t cont = + angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs]) + <> cont + <> angleBrackets (char '/' <> text t) + ul = tag' [("class", text (show @String "nested"))] "ul" + li = tag "li" + caret x = tag' [("class", text "caret")] "span" "" <+> x + nested foo cts +#if MIN_VERSION_ghc(9,2,1) && !MIN_VERSION_ghc(9,3,0) + | cts == empty = foo +#endif + | otherwise = foo $$ (caret $ ul cts) + body cts = tag "body" $ cts $$ tag "script" (text js) + header = tag "head" $ tag "style" $ text css + html = tag "html" + pre = tag "pre" +#if MIN_VERSION_ghc(9,2,1) + showAstDataHtml' :: Data a => a -> SDoc + showAstDataHtml' = + (generic + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan + `extQ` annotation + `extQ` annotationModule + `extQ` annotationAddEpAnn + `extQ` annotationGrhsAnn + `extQ` annotationEpAnnHsCase + `extQ` annotationEpAnnHsLet + `extQ` annotationAnnList + `extQ` annotationEpAnnImportDecl + `extQ` annotationAnnParen + `extQ` annotationTrailingAnn + `extQ` annotationEpaLocation + `extQ` addEpAnn + `extQ` lit `extQ` litr `extQ` litt + `extQ` sourceText + `extQ` deltaPos + `extQ` epaAnchor + `extQ` anchorOp + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var + `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + `extQ` srcSpanAnnA + `extQ` srcSpanAnnL + `extQ` srcSpanAnnP + `extQ` srcSpanAnnC + `extQ` srcSpanAnnN + ) + + where generic :: Data a => a -> SDoc + generic t = nested (text $ showConstr (toConstr t)) + (vcat (gmapQ (li . showAstDataHtml') t)) + + string :: String -> SDoc + string = text . normalize_newlines . show + + fastString :: FastString -> SDoc + fastString s = braces $ + text "FastString:" + <+> text (normalize_newlines . show $ s) + + bytestring :: B.ByteString -> SDoc + bytestring = text . normalize_newlines . show + + list [] = brackets empty + list [x] = "[]" $$ showAstDataHtml' x + list xs = nested "[]" (vcat $ map (li . showAstDataHtml') xs) + + -- Eliminate word-size dependence + lit :: HsLit GhcPs -> SDoc + lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + lit l = generic l + + litr :: HsLit GhcRn -> SDoc + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> SDoc + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + + numericLit :: String -> Integer -> SourceText -> SDoc + numericLit tag x s = braces $ hsep [ text tag + , generic x + , generic s ] + + sourceText :: SourceText -> SDoc + sourceText NoSourceText = text "NoSourceText" + sourceText (SourceText src) = text "SourceText" <+> text src + + epaAnchor :: EpaLocation -> SDoc + epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs + + anchorOp :: AnchorOperation -> SDoc + anchorOp UnchangedAnchor = "UnchangedAnchor" + anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp + + deltaPos :: DeltaPos -> SDoc + deltaPos (SameLine c) = text "SameLine" <+> ppr c + deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c + + name :: Name -> SDoc + name nm = braces $ text "Name:" <+> ppr nm + + occName n = braces $ + text "OccName:" + <+> text (occNameString n) + + moduleName :: ModuleName -> SDoc + moduleName m = braces $ text "ModuleName:" <+> ppr m + + srcSpan :: SrcSpan -> SDoc + srcSpan ss = char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + + realSrcSpan :: RealSrcSpan -> SDoc + realSrcSpan ss = braces $ char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + + addEpAnn :: AddEpAnn -> SDoc + addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s + + var :: Var -> SDoc + var v = braces $ text "Var:" <+> ppr v + + dataCon :: DataCon -> SDoc + dataCon c = braces $ text "DataCon:" <+> ppr c + + bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc + bagRdrName bg = braces $ + text "Bag(LocatedA (HsBind GhcPs)):" + $$ (list . bagToList $ bg) + + bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc + bagName bg = braces $ + text "Bag(LocatedA (HsBind Name)):" + $$ (list . bagToList $ bg) + + bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc + bagVar bg = braces $ + text "Bag(LocatedA (HsBind Var)):" + $$ (list . bagToList $ bg) + + nameSet ns = braces $ + text "NameSet:" + $$ (list . nameSetElemsStable $ ns) + + fixity :: Fixity -> SDoc + fixity fx = braces $ + text "Fixity:" + <+> ppr fx + + located :: (Data a, Data b) => GenLocated a b -> SDoc + located (L ss a) + = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) + + -- ------------------------- + + annotation :: EpAnn [AddEpAnn] -> SDoc + annotation = annotation' (text "EpAnn [AddEpAnn]") + + annotationModule :: EpAnn AnnsModule -> SDoc + annotationModule = annotation' (text "EpAnn AnnsModule") + + annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc + annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") + + annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") + + annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc + annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") + + annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc + annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") + + annotationAnnList :: EpAnn AnnList -> SDoc + annotationAnnList = annotation' (text "EpAnn AnnList") + + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") + + annotationAnnParen :: EpAnn AnnParen -> SDoc + annotationAnnParen = annotation' (text "EpAnn AnnParen") + + annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc + annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") + + annotationEpaLocation :: EpAnn EpaLocation -> SDoc + annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + + annotation' :: forall a .(Data a, Typeable a) + => SDoc -> EpAnn a -> SDoc + annotation' tag anns = nested (text $ showConstr (toConstr anns)) + (vcat (map li $ gmapQ showAstDataHtml' anns)) + + -- ------------------------- + + srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. (Typeable a, Data a) + => SDoc -> SrcSpanAnn' a -> SDoc + locatedAnn'' tag ss = + case cast ss of + Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> + nested "SrcSpanAnn" $ ( + li(showAstDataHtml' ann) + $$ li(srcSpan s)) + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> (text (showConstr (toConstr ss))) +#endif + + +normalize_newlines :: String -> String +normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs +normalize_newlines (x:xs) = x:normalize_newlines xs +normalize_newlines [] = [] + +css :: String +css = unlines + [ "body {background-color: black; color: white ;}" + , "/* Remove default bullets */" + , "ul, #myUL {" + , " list-style-type: none;" + , "}" + , "/* Remove margins and padding from the parent ul */" + , "#myUL {" + , " margin: 0; " + , " padding: 0; " + , "} " + , "/* Style the caret/arrow */ " + , ".caret { " + , " cursor: pointer; " + , " user-select: none; /* Prevent text selection */" + , "} " + , "/* Create the caret/arrow with a unicode, and style it */" + , ".caret::before { " + , " content: \"\\25B6 \"; " + , " color: white; " + , " display: inline-block; " + , " margin-right: 6px; " + , "} " + , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */" + , ".caret-down::before { " + , " transform: rotate(90deg); " + , "} " + , "/* Hide the nested list */ " + , ".nested { " + , " display: none; " + , "} " + , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */" + , ".active { " + , " display: block;}" + ] + +js :: String +js = unlines + [ "var toggler = document.getElementsByClassName(\"caret\");" + , "var i;" + , "for (i = 0; i < toggler.length; i++) {" + , " toggler[i].addEventListener(\"click\", function() {" + , " this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");" + , " this.classList.toggle(\"caret-down\");" + , " }); }" + ] diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-- | This module hosts various abstractions and utility functions to work with ghc-exactprint. +module Development.IDE.GHC.ExactPrint +#if MIN_VERSION_ghc(9,3,0) + ( ) where +#else + ( Graft(..), + graftDecls, + graftDeclsWithM, + annotate, + annotateDecl, + hoistGraft, + graftWithM, + graftExprWithM, + genericGraftWithSmallestM, + genericGraftWithLargestM, + graftSmallestDeclsWithM, + transform, + transformM, + ExactPrint(..), +#if !MIN_VERSION_ghc(9,2,0) + Anns, + Annotate, + setPrecedingLinesT, +#else + addParens, + addParensToCtxt, + modifyAnns, + removeComma, + -- * Helper function + eqSrcSpan, + epl, + epAnn, + removeTrailingComma, +#endif + annotateParsedSource, + getAnnotatedParsedSourceRule, + GetAnnotatedParsedSource(..), + ASTElement (..), + ExceptStringT (..), + TransformT, + Log(..), + ) +where + +import Control.Applicative (Alternative) +import Control.Arrow (right, (***)) +import Control.DeepSeq +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Zip +import Data.Bifunctor +import Data.Bool (bool) +import qualified Data.DList as DL +import Data.Either.Extra (mapLeft) +import Data.Foldable (Foldable (fold)) +import Data.Functor.Classes +import Data.Functor.Contravariant +import Data.Monoid (All (All), getAll) +import qualified Data.Text as T +import Data.Traversable (for) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (parseImport, + parsePattern, + parseType) +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.Graph (RuleResult, Rules) +import Development.IDE.Graph.Classes +import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) +import Generics.SYB +import Generics.SYB.GHC +import qualified GHC.Generics as GHC +import Ide.PluginUtils +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.LSP.Types +import Language.LSP.Types.Capabilities (ClientCapabilities) +import Retrie.ExactPrint hiding (Annotated (..), + parseDecl, parseExpr, + parsePattern, + parseType) +#if MIN_VERSION_ghc(9,2,0) +import GHC (EpAnn (..), + NameAdornment (NameParens), + NameAnn (..), + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + TrailingAnn (AddCommaAnn), + emptyComments, + spanAsAnchor) +import GHC.Parser.Annotation (AnnContext (..), + DeltaPos (SameLine), + EpaLocation (EpaDelta)) +#endif + +------------------------------------------------------------------------------ + +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + +instance Show (Annotated ParsedSource) where + show _ = "" + +instance NFData (Annotated ParsedSource) where + rnf = rwhnf + +data GetAnnotatedParsedSource = GetAnnotatedParsedSource + deriving (Eq, Show, Typeable, GHC.Generic) + +instance Hashable GetAnnotatedParsedSource +instance NFData GetAnnotatedParsedSource +type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource + +-- | Get the latest version of the annotated parse source with comments. +getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () +getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do + pm <- use GetParsedModuleWithComments nfp + return ([], fmap annotateParsedSource pm) + +#if MIN_VERSION_ghc(9,2,0) +annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0 +#else +annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource = fixAnns +#endif + +------------------------------------------------------------------------------ + +{- | A transformation for grafting source trees together. Use the semigroup + instance to combine 'Graft's, and run them via 'transform'. +-} +newtype Graft m a = Graft + { runGraft :: DynFlags -> a -> TransformT m a + } + +hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a +hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) + +newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} + deriving newtype + ( MonadTrans + , Monad + , Functor + , Applicative + , Alternative + , Foldable + , Contravariant + , MonadIO + , Eq1 + , Ord1 + , Show1 + , Read1 + , MonadZip + , MonadPlus + , Eq + , Ord + , Show + , Read + ) + +instance Monad m => Fail.MonadFail (ExceptStringT m) where + fail = ExceptStringT . ExceptT . pure . Left + +instance Monad m => Semigroup (Graft m a) where + Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags + +instance Monad m => Monoid (Graft m a) where + mempty = Graft $ const pure + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transform :: + DynFlags -> + ClientCapabilities -> + Uri -> + Graft (Either String) ParsedSource -> + Annotated ParsedSource -> + Either String WorkspaceEdit +transform dflags ccs uri f a = do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transformM :: + Monad m => + DynFlags -> + ClientCapabilities -> + Uri -> + Graft (ExceptStringT m) ParsedSource -> + Annotated ParsedSource -> + m (Either String WorkspaceEdit) +transformM dflags ccs uri f a = runExceptT $ + runExceptString $ do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + + +-- | Returns whether or not this node requires its immediate children to have +-- be parenthesized and have a leading space. +-- +-- A more natural type for this function would be to return @(Bool, Bool)@, but +-- we use 'All' instead for its monoid instance. +needsParensSpace :: + HsExpr GhcPs -> + -- | (Needs parens, needs space) + (All, All) +needsParensSpace HsLam{} = (All False, All False) +needsParensSpace HsLamCase{} = (All False, All True) +needsParensSpace HsApp{} = mempty +needsParensSpace HsAppType{} = mempty +needsParensSpace OpApp{} = mempty +needsParensSpace HsPar{} = (All False, All False) +needsParensSpace SectionL{} = (All False, All False) +needsParensSpace SectionR{} = (All False, All False) +needsParensSpace ExplicitTuple{} = (All False, All False) +needsParensSpace ExplicitSum{} = (All False, All False) +needsParensSpace HsCase{} = (All False, All True) +needsParensSpace HsIf{} = (All False, All False) +needsParensSpace HsMultiIf{} = (All False, All False) +needsParensSpace HsLet{} = (All False, All True) +needsParensSpace HsDo{} = (All False, All False) +needsParensSpace ExplicitList{} = (All False, All False) +needsParensSpace RecordCon{} = (All False, All True) +needsParensSpace RecordUpd{} = mempty +needsParensSpace _ = mempty + + +------------------------------------------------------------------------------ + +{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the + given @Located ast@. The node at that position must already be a @Located + ast@, or this is a no-op. +-} +graft' :: + forall ast a l. + (Data a, Typeable l, ASTElement l ast) => + -- | Do we need to insert a space before this grafting? In do blocks, the + -- answer is no, or we will break layout. But in function applications, + -- the answer is yes, or the function call won't get its argument. Yikes! + -- + -- More often the answer is yes, so when in doubt, use that. + Bool -> + SrcSpan -> + LocatedAn l ast -> + Graft (Either String) a +graft' needs_space dst val = Graft $ \dflags a -> do +#if MIN_VERSION_ghc(9,2,0) + val' <- annotate dflags needs_space val +#else + (anns, val') <- annotate dflags needs_space val + modifyAnnsT $ mappend anns +#endif + pure $ + everywhere' + ( mkT $ + \case + (L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> val' + l -> l + ) + a + + +-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts +-- parentheses if they're necessary. +graftExpr :: + forall a. + (Data a) => + SrcSpan -> + LHsExpr GhcPs -> + Graft (Either String) a +graftExpr dst val = Graft $ \dflags a -> do + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a + + runGraft + (graft' needs_space dst $ mk_parens val) + dflags + a + +getNeedsSpaceAndParenthesize :: + (ASTElement l ast, Data a) => + SrcSpan -> + a -> + (Bool, LocatedAn l ast -> LocatedAn l ast) +getNeedsSpaceAndParenthesize dst a = + -- Traverse the tree, looking for our replacement node. But keep track of + -- the context (parent HsExpr constructor) we're in while we do it. This + -- lets us determine wehther or not we need parentheses. + let (needs_parens, needs_space) = + everythingWithContext (Nothing, Nothing) (<>) + ( mkQ (mempty, ) $ \x s -> case x of + (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst -> + (s, s) + L _ x' -> (mempty, Just *** Just $ needsParensSpace x') + ) a + in ( maybe True getAll needs_space + , bool id maybeParensAST $ maybe False getAll needs_parens + ) + + +------------------------------------------------------------------------------ + +graftExprWithM :: + forall m a. + (Fail.MonadFail m, Data a) => + SrcSpan -> + (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + Graft m a +graftExprWithM dst trans = Graft $ \dflags a -> do + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a + + everywhereM' + ( mkM $ + \case + val@(L src _ :: LHsExpr GhcPs) + | locA src `eqSrcSpan` dst -> do + mval <- trans val + case mval of + Just val' -> do +#if MIN_VERSION_ghc(9,2,0) + val'' <- + hoistTransform (either Fail.fail pure) + (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + pure val'' +#else + (anns, val'') <- + hoistTransform (either Fail.fail pure) + (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + modifyAnnsT $ mappend anns + pure val'' +#endif + Nothing -> pure val + l -> pure l + ) + a + +graftWithM :: + forall ast m a l. + (Fail.MonadFail m, Data a, Typeable l, ASTElement l ast) => + SrcSpan -> + (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) -> + Graft m a +graftWithM dst trans = Graft $ \dflags a -> do + everywhereM' + ( mkM $ + \case + val@(L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> do + mval <- trans val + case mval of + Just val' -> do +#if MIN_VERSION_ghc(9,2,0) + val'' <- + hoistTransform (either Fail.fail pure) $ + annotate dflags True $ maybeParensAST val' + pure val'' +#else + (anns, val'') <- + hoistTransform (either Fail.fail pure) $ + annotate dflags True $ maybeParensAST val' + modifyAnnsT $ mappend anns + pure val'' +#endif + Nothing -> pure val + l -> pure l + ) + a + +-- | Run the given transformation only on the smallest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithSmallestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the smallest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> ast -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> + smallestM (genericIsSubspan proxy dst) (trans dflags) + +-- | Run the given transformation only on the largest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithLargestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the largest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> ast -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> + largestM (genericIsSubspan proxy dst) (trans dflags) + + +graftDecls :: + forall a. + (HasDecls a) => + SrcSpan -> + [LHsDecl GhcPs] -> + Graft (Either String) a +graftDecls dst decs0 = Graft $ \dflags a -> do + decs <- forM decs0 $ \decl -> do + annotateDecl dflags decl + let go [] = DL.empty + go (L src e : rest) + | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest + | otherwise = DL.singleton (L src e) <> go rest + modifyDeclsT (pure . DL.toList . go) a + +graftSmallestDeclsWithM :: + forall a. + (HasDecls a) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> + Graft (Either String) a +graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | dst `isSubspanOf` locA src = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + +graftDeclsWithM :: + forall a m. + (HasDecls a, Fail.MonadFail m) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> + Graft m a +graftDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | locA src `eqSrcSpan` dst = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + hoistTransform (either Fail.fail pure) $ + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + + +class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where + parseAST :: Parser (LocatedAn l ast) + maybeParensAST :: LocatedAn l ast -> LocatedAn l ast + {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with + the given @Located ast@. The node at that position must already be + a @Located ast@, or this is a no-op. + -} + graft :: + forall a. + (Data a) => + SrcSpan -> + LocatedAn l ast -> + Graft (Either String) a + graft dst = graft' True dst . maybeParensAST + +instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where + parseAST = parseExpr + maybeParensAST = parenthesize + graft = graftExpr + +instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where +#if __GLASGOW_HASKELL__ == 808 + parseAST = fmap (fmap $ right $ second dL) . parsePattern + maybeParensAST = dL . parenthesizePat appPrec . unLoc +#else + parseAST = parsePattern + maybeParensAST = parenthesizePat appPrec +#endif + +instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where + parseAST = parseType + maybeParensAST = parenthesizeHsType appPrec + +instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where + parseAST = parseDecl + maybeParensAST = id + +instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where + parseAST = parseImport + maybeParensAST = id + +instance ASTElement NameAnn RdrName where + parseAST df fp = parseWith df fp parseIdentifier + maybeParensAST = id + +------------------------------------------------------------------------------ + +#if !MIN_VERSION_ghc(9,2,0) +-- | Dark magic I stole from retrie. No idea what it does. +fixAnns :: ParsedModule -> Annotated ParsedSource +fixAnns ParsedModule {..} = + let ranns = relativiseApiAnns pm_parsed_source pm_annotations + in unsafeMkA pm_parsed_source ranns 0 +#endif + +------------------------------------------------------------------------------ + +-- | Given an 'LHSExpr', compute its exactprint annotations. +-- Note that this function will throw away any existing annotations (and format) +annotate :: (ASTElement l ast, Outputable l) +#if MIN_VERSION_ghc(9,2,0) + => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) +#else + => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (Anns, LocatedAn l ast) +#endif +annotate dflags needs_space ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast +#if MIN_VERSION_ghc(9,2,0) + expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered + pure expr' +#else + (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered + let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns + pure (anns',expr') +#endif + +-- | Given an 'LHsDecl', compute its exactprint annotations. +annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) +-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain +-- multiple matches. To work around this, we split the single +-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', +-- and then merge them all back together. +annotateDecl dflags + (L src ( + ValD ext fb@FunBind + { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} + })) = do + let set_matches matches = + ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} + +#if MIN_VERSION_ghc(9,2,0) + alts' <- for alts $ \alt -> do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags $ set_matches [alt] + lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case + (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) + -> pure alt' + _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" + + pure $ L src $ set_matches alts' +#else + (anns', alts') <- fmap unzip $ for alts $ \alt -> do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags $ set_matches [alt] + lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case + (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) + -> pure (setPrecedingLines alt' 1 0 ann, alt') + _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" + + modifyAnnsT $ mappend $ fold anns' + pure $ L src $ set_matches alts' +#endif +annotateDecl dflags ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast +#if MIN_VERSION_ghc(9,2,0) + lift $ mapLeft show $ parseDecl dflags uniq rendered +#else + (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered + let anns' = setPrecedingLines expr' 1 0 anns + modifyAnnsT $ mappend anns' + pure expr' +#endif + +------------------------------------------------------------------------------ + +-- | Print out something 'Outputable'. +render :: Outputable a => DynFlags -> a -> String +render dflags = showSDoc dflags . ppr + +------------------------------------------------------------------------------ + +-- | Put parentheses around an expression if required. +parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs +parenthesize = parenthesizeHsExpr appPrec + +------------------------------------------------------------------------------ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +eqSrcSpan :: SrcSpan -> SrcSpan -> Bool +eqSrcSpan l r = leftmost_smallest l r == EQ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +#if MIN_VERSION_ghc(9,2,0) +eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool +eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ +#else +eqSrcSpanA :: SrcSpan -> SrcSpan -> Bool +eqSrcSpanA l r = leftmost_smallest l r == EQ +#endif + +#if MIN_VERSION_ghc(9,2,0) +addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext +addParensToCtxt close_dp = addOpen . addClose + where + addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]} + addOpen other = other + addClose it + | Just c <- close_dp = it{ac_close = [c]} + | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]} + | otherwise = it + +epl :: Int -> EpaLocation +epl n = EpaDelta (SameLine n) [] + +epAnn :: SrcSpan -> ann -> EpAnn ann +epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments + +modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast +modifyAnns x f = first ((fmap.fmap) f) x + +removeComma :: SrcSpanAnnA -> SrcSpanAnnA +removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it +removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) + = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l) + where + isCommaAnn AddCommaAnn{} = True + isCommaAnn _ = False + +addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn +addParens True it@NameAnn{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnCommas{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnOnly{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True NameAnnTrailing{..} = + NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..} +addParens _ it = it + +removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast +removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l + +isCommaAnn :: TrailingAnn -> Bool +isCommaAnn AddCommaAnn{} = True +isCommaAnn _ = False +#endif + +#endif diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -0,0 +1,2062 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} + +module Development.IDE.Plugin.CodeAction + ( + mkExactprintPluginDescriptor, + iePluginDescriptor, + typeSigsPluginDescriptor, + bindingsPluginDescriptor, + fillHolePluginDescriptor, + extendImportPluginDescriptor, + -- * For testing + matchRegExMultipleImports + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow (second, + (&&&), + (>>>)) +import Control.Concurrent.STM.Stats (atomically) +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Extra +import Data.Aeson +import Data.Char +import qualified Data.DList as DL +import Data.Function +import Data.Functor +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import Data.List.Extra +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Ord (comparing) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope as Rope +import Data.Tuple.Extra (fst3) +import Development.IDE.Types.Logger hiding (group) +import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as E +import Development.IDE.GHC.Util (printOutputable, + printRdrName) +import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Plugin.CodeAction.Args +import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.Util +import Development.IDE.Plugin.CodeAction.PositionIndexed +import Development.IDE.Plugin.Completions.Types +import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Types.Exports +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified GHC.LanguageExtensions as Lang +import Ide.PluginUtils (subRange) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (ApplyWorkspaceEditParams(..), CodeAction (..), + CodeActionContext (CodeActionContext, _diagnostics), + CodeActionKind (CodeActionQuickFix, CodeActionUnknown), + CodeActionParams (CodeActionParams), + Command, + Diagnostic (..), + MessageType (..), + ShowMessageParams (..), + List (..), + ResponseError, + SMethod (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit, _range), + UInt, + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (InR), + uriToFilePath) +import GHC.Exts (fromList) +import Language.LSP.VFS (VirtualFile, + _file_text) +import Text.Regex.TDFA (mrAfter, + (=~), (=~~)) +#if MIN_VERSION_ghc(9,2,0) +import GHC (AddEpAnn (AddEpAnn), + Anchor (anchor_op), + AnchorOperation (..), + AnnsModule (am_main), + DeltaPos (..), + EpAnn (..), + EpaLocation (..), + LEpaComment, + LocatedA) + +#else +import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), + DeltaPos, + KeywordId (G), + deltaRow, + mkAnnKey) +#endif + +------------------------------------------------------------------------------------------------- + +-- | Generate code actions. +codeAction + :: IdeState + -> PluginId + -> CodeActionParams + -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do + contents <- LSP.getVirtualFile $ toNormalizedUri uri + liftIO $ do + let text = Rope.toText . (_file_text :: VirtualFile -> Rope.Rope) <$> contents + mbFile = toNormalizedFilePath' <$> uriToFilePath uri + diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile + let + actions = caRemoveRedundantImports parsedModule text diag xs uri + <> caRemoveInvalidExports parsedModule text diag xs uri + pure $ Right $ List actions + +------------------------------------------------------------------------------------------------- + +iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +iePluginDescriptor recorder plId = + let old = + mkGhcideCAsPlugin [ + wrap suggestExportUnusedTopBinding + , wrap suggestModuleTypo + , wrap suggestFixConstructorImport + , wrap suggestNewImport +#if !MIN_VERSION_ghc(9,3,0) + , wrap suggestExtendImport + , wrap suggestImportDisambiguation + , wrap suggestNewOrExtendImportForClassMethod + , wrap suggestHideShadow +#endif + ] + plId + in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction } + +typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ + mkGhcideCAsPlugin [ + wrap $ suggestSignature True + , wrap suggestFillTypeWildcard + , wrap suggestAddTypeAnnotationToSatisfyContraints +#if !MIN_VERSION_ghc(9,3,0) + , wrap removeRedundantConstraints + , wrap suggestConstraint +#endif + ] + plId + +bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ + mkGhcideCAsPlugin [ + wrap suggestReplaceIdentifier +#if !MIN_VERSION_ghc(9,3,0) + , wrap suggestImplicitParameter +#endif + , wrap suggestNewDefinition + , wrap suggestDeleteUnusedBinding + ] + plId + +fillHolePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +fillHolePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder (mkGhcideCAPlugin (wrap suggestFillHole) plId) + +extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) + { pluginCommands = [extendImportCommand] } + + +-- | Add the ability for a plugin to call GetAnnotatedParsedSource +mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a +mkExactprintPluginDescriptor recorder desc = desc { pluginRules = pluginRules desc >> getAnnotatedParsedSourceRule recorder } + +------------------------------------------------------------------------------------------------- + + +extendImportCommand :: PluginCommand IdeState +extendImportCommand = + PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler + +extendImportHandler :: CommandFunction IdeState ExtendImport +extendImportHandler ideState edit@ExtendImport {..} = do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do + let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . Map.toList + srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> printOutputable srcSpan + <> ")" + void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null + +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) +extendImportHandler' ideState ExtendImport {..} + | Just fp <- uriToFilePath doc, + nfp <- toNormalizedFilePath' fp = + do + (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ + runAction "extend import" ideState $ + runMaybeT $ do + -- We want accurate edits, so do not use stale data here + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + ps <- MaybeT $ use GetAnnotatedParsedSource nfp + (_, contents) <- MaybeT $ use GetFileContents nfp + return (msr, ps, contents) + let df = ms_hspp_opts msrModSummary + wantedModule = mkModuleName (T.unpack importName) + wantedQual = mkModuleName . T.unpack <$> importQual + existingImport = find (isWantedModule wantedModule wantedQual) msrImports + case existingImport of + Just imp -> do + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc +#if !MIN_VERSION_ghc(9,2,0) + (annsA ps) +#endif + $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) + + Nothing -> do + let n = newImport importName sym importQual False + sym = if isNothing importQual then Just it else Nothing + it = case thingParent of + Nothing -> newThing + Just p -> p <> "(" <> newThing <> ")" + t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) + return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) + | otherwise = + mzero + +isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool +isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = + not (isQualifiedImport it) && unLoc ideclName == wantedModule +isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) +isWantedModule _ _ _ = False + + +liftMaybe :: Monad m => Maybe a -> MaybeT m a +liftMaybe a = MaybeT $ pure a + +liftEither :: Monad m => Either e a -> MaybeT m a +liftEither (Left _) = mzero +liftEither (Right x) = return x + +------------------------------------------------------------------------------------------------- + +findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDecl pred decls = + listToMaybe + [ sig + | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, + any (pred . unLoc) idsSig + ] + +findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDeclRanged range decls = do + dec <- findDeclContainingLoc (_start range) decls + case dec of + L _ (SigD _ sig@TypeSig {}) -> Just sig + L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind + _ -> Nothing + +findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p) +findSigOfBind range bind = + case bind of + FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) + _ -> Nothing + where + findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) + findSigOfLMatch ls = do + match <- findDeclContainingLoc (_start range) ls + let grhs = m_grhss $ unLoc match +#if !MIN_VERSION_ghc(9,2,0) + span = getLoc $ reLoc $ grhssLocalBinds grhs + if _start range `isInsideSrcSpan` span + then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause + else do + grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + _ -> Nothing +#else + msum + [findSigOfBinds range (grhssLocalBinds grhs) -- where clause + , do +#if MIN_VERSION_ghc(9,3,0) + grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) +#else + grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) +#endif + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + ] +#endif + + findSigOfExpr :: HsExpr p -> Maybe (Sig p) + findSigOfExpr = go + where +#if MIN_VERSION_ghc(9,3,0) + go (HsLet _ _ binds _ _) = findSigOfBinds range binds +#else + go (HsLet _ binds _) = findSigOfBinds range binds +#endif + go (HsDo _ _ stmts) = do + stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) + case stmtlr of + LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR + _ -> Nothing + go _ = Nothing + +findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p) +findSigOfBinds range = go + where + go (HsValBinds _ (ValBinds _ binds lsigs)) = + case unLoc <$> findDeclContainingLoc (_start range) lsigs of + Just sig' -> Just sig' + Nothing -> do + lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) + findSigOfBind range (unLoc lHsBindLR) + go _ = Nothing + +findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) +findInstanceHead df instanceHead decls = + listToMaybe +#if !MIN_VERSION_ghc(9,2,0) + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] +#else + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] +#endif + +#if MIN_VERSION_ghc(9,2,0) +findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e) +#else +findDeclContainingLoc :: Foldable t => Position -> t (GenLocated SrcSpan e) -> Maybe (GenLocated SrcSpan e) +#endif +findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) + +-- Single: +-- This binding for ‘mod’ shadows the existing binding +-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 +-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) +-- Multi: +--This binding for ‘pack’ shadows the existing bindings +-- imported from ‘Data.ByteString’ at B.hs:6:1-22 +-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 +-- imported from ‘Data.Text’ at B.hs:7:1-16 +#if !MIN_VERSION_ghc(9,3,0) +suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] +suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} + | Just [identifier, modName, s] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = + suggests identifier modName s + | Just [identifier] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing bindings", + Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", + mods <- [(modName, s) | [_, modName, s] <- matched], + result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), + hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = + result <> [hideAll] + | otherwise = [] + where + L _ HsModule {hsmodImports} = astA ps + + suggests identifier modName s + | Just tcM <- mTcM, + Just har <- mHar, + [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents + else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] +#endif + +findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) +findImportDeclByModuleName decls modName = flip find decls $ \case + (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) + _ -> error "impossible" + +isTheSameLine :: SrcSpan -> SrcSpan -> Bool +isTheSameLine s1 s2 + | Just sl1 <- getStartLine s1, + Just sl2 <- getStartLine s2 = + sl1 == sl2 + | otherwise = False + where + getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x + +isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool +isUnusedImportedId + TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} + HAR {refMap} + identifier + modName + importSpan + | occ <- mkVarOcc identifier, + impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, + Just rdrEnv <- + listToMaybe + [ imv_all_exports + | ImportedModsVal {..} <- impModsVals, + imv_name == mkModuleName modName, + isTheSameLine imv_span importSpan + ], + [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right name, + refs <- M.lookup importedIdentifier refMap = + maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs + | otherwise = False + +suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} +-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant + | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" + , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports + , Just c <- contents + , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) + , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) + , not (null ranges') + = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] + +-- File.hs:16:1: warning: +-- The import of `Data.List' is redundant +-- except perhaps to import instances from `Data.List' +-- To import instances alone, use: import Data.List() + | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) + = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] + | otherwise = [] + +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] +caRemoveRedundantImports m contents digs ctxDigs uri + | Just pm <- m, + r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, + allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], + caRemoveAll <- removeAll allEdits, + ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits, + caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where + _changes = Just $ Map.singleton uri $ List tedit + _documentChanges = Nothing + _changeAnnotations = Nothing + removeAll tedit = InR $ CodeAction{..} where + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant imports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _isPreferred = Nothing + _command = Nothing + _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing + +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] +caRemoveInvalidExports m contents digs ctxDigs uri + | Just pm <- m, + Just txt <- contents, + txt' <- indexedByPosition $ T.unpack txt, + r <- mapMaybe (groupDiag pm) digs, + r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, + caRemoveCtx <- mapMaybe removeSingle r', + allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], + allRanges' <- extend txt' allRanges, + Just caRemoveAll <- removeAll allRanges', + ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges + + groupDiag pm dig + | Just (title, ranges) <- suggestRemoveRedundantExport pm dig + = Just (title, dig, ranges) + | otherwise = Nothing + + removeSingle (_, _, []) = Nothing + removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = title + _kind = Just CodeActionQuickFix + _diagnostics = Just $ List [diagnostic] + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + _isPreferred = Nothing + _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing + removeAll [] = Nothing + removeAll ranges = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant exports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + _isPreferred = Nothing + _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing + +suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) +suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} + | msg <- unifySpaces _message + , Just export <- hsmodExports + , Just exportRange <- getLocatedRange $ reLoc export + , exports <- unLoc export + , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) + <|> (,[_range]) <$> matchExportItem msg + <|> (,[_range]) <$> matchDupExport msg + , subRange _range exportRange + = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) + where + matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" + matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" + getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of + [] -> (txt, [_range]) + ranges -> (txt, ranges) +suggestRemoveRedundantExport _ _ = Nothing + +suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBinding + ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} + contents + Diagnostic{_range=_range,..} +-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ + | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + , Just indexedContent <- indexedByPosition . T.unpack <$> contents + = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) + in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) + | otherwise = [] + where + relatedRanges indexedContent name = + concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls + toRange = realSrcSpanToRange + extendForSpaces = extendToIncludePreviousNewlineIfPossible + + findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] + findRelatedSpans + indexedContent + name + (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + case lname of + (L nLoc _name) | isTheBinding nLoc -> + let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in + extendForSpaces indexedContent (toRange l) : + concatMap (findSig . reLoc) hsmodDecls + _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpans _ _ _ = [] + + extractNameAndMatchesFromFunBind + :: HsBind GhcPs + -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) + extractNameAndMatchesFromFunBind + FunBind + { fun_id=lname + , fun_matches=MG {mg_alts=L _ matches} + } = Just (reLoc lname, matches) + extractNameAndMatchesFromFunBind _ = Nothing + + findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] + findRelatedSigSpan indexedContent name l sig = + let maybeSpan = findRelatedSigSpan1 name sig + in case maybeSpan of + Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int + Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused + _ -> [] + + -- Second of the tuple means there is only one match + findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) + findRelatedSigSpan1 name (TypeSig _ lnames _) = + let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames + in case maybeIdx of + Nothing -> Nothing + Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True) + Just idx -> + let targetLname = getLoc $ reLoc $ lnames !! idx + startLoc = srcSpanStart targetLname + endLoc = srcSpanEnd targetLname + startLoc' = if idx == 0 + then startLoc + else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1) + endLoc' = if idx == 0 && idx < length lnames - 1 + then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1) + else endLoc + in Just (mkSrcSpan startLoc' endLoc', False) + findRelatedSigSpan1 _ _ = Nothing + + -- for where clause + findRelatedSpanForMatch + :: PositionIndexedString + -> String + -> LMatch GhcPs (LHsExpr GhcPs) + -> [Range] + findRelatedSpanForMatch + indexedContent + name + (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do + let go bag lsigs = + if isEmptyBag bag + then [] + else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag +#if !MIN_VERSION_ghc(9,2,0) + case grhssLocalBinds of + (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> go bag lsigs + _ -> [] +#else + case grhssLocalBinds of + (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs + _ -> [] +#endif + findRelatedSpanForMatch _ _ _ = [] + + findRelatedSpanForHsBind + :: PositionIndexedString + -> String + -> [LSig GhcPs] + -> LHsBind GhcPs + -> [Range] + findRelatedSpanForHsBind + indexedContent + name + lsigs + (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + if isTheBinding (getLoc lname) + then + let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs + else concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpanForHsBind _ _ _ _ = [] + + isTheBinding :: SrcSpan -> Bool + isTheBinding span = srcSpanToRange span == Just _range + + isSameName :: IdP GhcPs -> String -> Bool + isSameName x name = T.unpack (printOutputable x) == name + +data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll + deriving (Eq) + +getLocatedRange :: HasSrcSpan a => a -> Maybe Range +getLocatedRange = srcSpanToRange . getLoc + +suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} +-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ +-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ +-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ + | Just source <- srcOpt + , Just [_, name] <- + matchRegexUnifySpaces + _message + ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’" + , Just (exportType, _) <- + find (matchWithDiagnostic _range . snd) + . mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing) + $ hsmodDecls + , Just exports <- fmap (fmap reLoc) . reLoc <$> hsmodExports + , Just exportsEndPos <- _end <$> getLocatedRange exports + , let name' = printExport exportType name + sep = exportSep source $ map getLocatedRange <$> exports + exportName = case sep of + Nothing -> (if needsComma source exports then ", " else "") <> name' + Just s -> s <> name' + exportsEndPos' = exportsEndPos { _character = pred $ _character exportsEndPos } + insertPos = fromMaybe exportsEndPos' $ case (sep, unLoc exports) of + (Just _, exports'@(_:_)) -> fmap _end . getLocatedRange $ last exports' + _ -> Nothing + = Just ("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName) + | otherwise = Nothing + where + exportSep :: T.Text -> Located [Maybe Range] -> Maybe T.Text + exportSep src (L (RealSrcSpan _ _) xs@(_ : tl@(_ : _))) = + case mapMaybe (\(e, s) -> (,) <$> e <*> s) $ zip (fmap _end <$> xs) (fmap _start <$> tl) of + [] -> Nothing + bounds -> Just smallestSep + where + smallestSep + = snd + $ minimumBy (comparing fst) + $ map (T.length &&& id) + $ nubOrd + $ map (\(prevEnd, nextStart) -> textInRange (Range prevEnd nextStart) src) bounds + exportSep _ _ = Nothing + + -- We get the last export and the closing bracket and check for comma in that range. + needsComma :: T.Text -> Located [Located (IE GhcPs)] -> Bool + needsComma _ (L _ []) = False + needsComma source (L (RealSrcSpan l _) exports) = + let closeParen = _end $ realSrcSpanToRange l + lastExport = fmap _end . getLocatedRange $ last exports + in + case lastExport of + Just lastExport -> + not $ T.any (== ',') $ textInRange (Range lastExport closeParen) source + _ -> False + needsComma _ _ = False + + opLetter :: T.Text + opLetter = ":!#$%&*+./<=>?@\\^|-~" + + parenthesizeIfNeeds :: Bool -> T.Text -> T.Text + parenthesizeIfNeeds needsTypeKeyword x + | T.any (c ==) opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <> ")" + | otherwise = x + where + c = T.head x + + matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool + matchWithDiagnostic Range{_start=l,_end=r} x = + let loc = fmap _start . getLocatedRange $ x + in loc >= Just l && loc <= Just r + + printExport :: ExportsAs -> T.Text -> T.Text + printExport ExportName x = parenthesizeIfNeeds False x + printExport ExportPattern x = "pattern " <> x + printExport ExportFamily x = parenthesizeIfNeeds True x + printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" + + isTopLevel :: SrcSpan -> Bool + isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0 + + exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs)) + exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, reLoc fun_id) + exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id) + exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, reLoc tcdLName) + exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportFamily, reLoc $ fdLName tcdFam) + exportsAs _ = Nothing + +suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..} +-- File.hs:52:41: warning: +-- * Defaulting the following constraint to type ‘Integer’ +-- Num p0 arising from the literal ‘1’ +-- * In the expression: 1 +-- In an equation for ‘f’: f = 1 +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:228:7-25 +-- (IsString a0) +-- arising from the literal ‘"debug"’ +-- at A.hs:228:17-23 +-- * In the expression: traceShow "debug" a +-- In an equation for ‘f’: f a = traceShow "debug" a +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:255:28-43 +-- (IsString a0) +-- arising from the literal ‘"test"’ +-- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 +-- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ +-- In the expression: seq "test" seq "test" (traceShow "test") +-- In an equation for ‘f’: +-- f = seq "test" seq "test" (traceShow "test") + | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) + <|> matchRegexUnifySpaces _message (pat False False False True) + <|> matchRegexUnifySpaces _message (pat False False False False) + = codeEdit ty lit (makeAnnotatedLit ty lit) + | Just source <- sourceOpt + , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) + = let lit' = makeAnnotatedLit ty lit; + tir = textInRange _range source + in codeEdit ty lit (T.replace lit lit' tir) + | otherwise = [] + where + makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" + pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" + , if multiple then "s" else "" + , " to type ‘([^ ]+)’ " + , ".*arising from the literal ‘(.+)’" + , if inArg then ".+In the.+argument" else "" + , if at then ".+at" else "" + , if inExpr then ".+In the expression" else "" + , ".+In the expression" + ] + codeEdit ty lit replacement = + let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" + edits = [TextEdit _range replacement] + in [( title, edits )] + + +suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestReplaceIdentifier contents Diagnostic{_range=_range,..} +-- File.hs:52:41: error: +-- * Variable not in scope: +-- suggestAcion :: Maybe T.Text -> Range -> Range +-- * Perhaps you meant ‘suggestAction’ (line 83) +-- File.hs:94:37: error: +-- Not in scope: ‘T.isPrfixOf’ +-- Perhaps you meant one of these: +-- ‘T.isPrefixOf’ (imported from Data.Text), +-- ‘T.isInfixOf’ (imported from Data.Text), +-- ‘T.isSuffixOf’ (imported from Data.Text) +-- Module ‘Data.Text’ does not export ‘isPrfixOf’. + | renameSuggestions@(_:_) <- extractRenamableTerms _message + = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] + | otherwise = [] + +suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} +-- * Variable not in scope: +-- suggestAcion :: Maybe T.Text -> Range -> Range + | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" + = newDefinitionAction ideOptions parsedModule _range name typ + | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" + , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ + = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] + | otherwise = [] + where + message = unifySpaces _message + +newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] +newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ + | Range _ lastLineP : _ <- + [ realSrcSpanToRange sp + | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls + , _start `isInsideSrcSpan` l] + , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} + = [ ("Define " <> sig + , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])] + )] + | otherwise = [] + where + colon = if optNewColonConvention then " : " else " :: " + sig = name <> colon <> T.dropWhileEnd isSpace typ + ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule + +suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillTypeWildcard Diagnostic{_range=_range,..} +-- Foo.hs:3:8: error: +-- * Found type wildcard `_' standing for `p -> p1 -> p' + + | "Found type wildcard" `T.isInfixOf` _message + , " standing for " `T.isInfixOf` _message + , typeSignature <- extractWildCardTypeSignature _message + = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] + | otherwise = [] + +{- Handles two variants with different formatting + +1. Could not find module ‘Data.Cha’ + Perhaps you meant Data.Char (from base-4.12.0.0) + +2. Could not find module ‘Data.I’ + Perhaps you meant + Data.Ix (from base-4.14.3.0) + Data.Eq (from base-4.14.3.0) + Data.Int (from base-4.14.3.0) +-} +suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] +suggestModuleTypo Diagnostic{_range=_range,..} + | "Could not find module" `T.isInfixOf` _message = + case T.splitOn "Perhaps you meant" _message of + [_, stuff] -> + [ ("replace with " <> modul, TextEdit _range modul) + | modul <- mapMaybe extractModule (T.lines stuff) + ] + _ -> [] + | otherwise = [] + where + extractModule line = case T.words line of + [modul, "(from", _] -> Just modul + _ -> Nothing + + +suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillHole Diagnostic{_range=_range,..} + | Just holeName <- extractHoleName _message + , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = + let isInfixHole = _message =~ addBackticks holeName :: Bool in + map (proposeHoleFit holeName False isInfixHole) holeFits + ++ map (proposeHoleFit holeName True isInfixHole) refFits + | otherwise = [] + where + extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + addBackticks text = "`" <> text <> "`" + addParens text = "(" <> text <> ")" + proposeHoleFit holeName parenthise isInfixHole name = + let isInfixOperator = T.head name == '(' + name' = getOperatorNotation isInfixHole isInfixOperator name in + ( "replace " <> holeName <> " with " <> name + , TextEdit _range (if parenthise then addParens name' else name') + ) + getOperatorNotation True False name = addBackticks name + getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) + getOperatorNotation _isInfixHole _isInfixOperator name = name + +processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) +processHoleSuggestions mm = (holeSuggestions, refSuggestions) +{- + • Found hole: _ :: LSP.Handlers + + Valid hole fits include def + Valid refinement hole fits include + fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) + fromJust (_ :: Maybe LSP.Handlers) + haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams + LSP.Handlers) + T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) + T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) +-} + where + t = id @T.Text + holeSuggestions = do + -- get the text indented under Valid hole fits + validHolesSection <- + getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm + -- the Valid hole fits line can contain a hole fit + holeFitLine <- + mapHead + (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) + validHolesSection + let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine + guard (not $ T.null holeFit) + return holeFit + refSuggestions = do -- @[] + -- get the text indented under Valid refinement hole fits + refinementSection <- + getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm + -- get the text for each hole fit + holeFitLines <- getIndentedGroups (tail refinementSection) + let holeFit = T.strip $ T.unwords holeFitLines + guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" + return holeFit + + mapHead f (a:aa) = f a : aa + mapHead _ [] = [] + +-- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] +getIndentedGroups :: [T.Text] -> [[T.Text]] +getIndentedGroups [] = [] +getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll +-- | +-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] +getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] +getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of + (l:ll) -> case span (\l' -> indentation l < indentation l') ll of + (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest + _ -> [] + +indentation :: T.Text -> Int +indentation = T.length . T.takeWhile isSpace + +#if !MIN_VERSION_ghc(9,3,0) +suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] +suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} + | Just [binding, mod, srcspan] <- + matchRegexUnifySpaces _message + "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" + = suggestions hsmodImports binding mod srcspan + | Just (binding, mod_srcspan) <- + matchRegExMultipleImports _message + = mod_srcspan >>= uncurry (suggestions hsmodImports binding) + | otherwise = [] + where + canUseDatacon = case extractNotInScopeName _message of + Just NotInScopeTypeConstructorOrClass{} -> False + _ -> True + + suggestions decls binding mod srcspan + | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + [s] -> let x = realSrcSpanToRange s + in x{_end = (_end x){_character = succ (_character (_end x))}} + _ -> error "bug in srcspan parser", + Just decl <- findImportDeclByRange decls range, + Just ident <- lookupExportMap binding mod + = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod + , quickFixImportKind' "extend" importStyle + , uncurry extendImport (unImportStyle importStyle) decl + ) + | importStyle <- NE.toList $ importStyles ident + ] + | otherwise = [] + lookupExportMap binding mod + | Just match <- Map.lookup binding (getExportsMap exportsMap) + -- Only for the situation that data constructor name is same as type constructor name, + -- let ident with parent be in front of the one without. + , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) + , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch + , (not . null) idents -- Ensure fallback while `idents` is empty + , ident <- head idents + = Just ident + + -- fallback to using GHC suggestion even though it is not always correct + | otherwise + = Just IdentInfo + { name = mkVarOcc $ T.unpack binding + , rendered = binding + , parent = Nothing + , isDatacon = False + , moduleNameText = mod} +#endif + +data HidingMode + = HideOthers [ModuleTarget] + | ToQualified + Bool + -- ^ Parenthesised? + ModuleName + +data ModuleTarget + = ExistingImp (NonEmpty (LImportDecl GhcPs)) + | ImplicitPrelude [LImportDecl GhcPs] + +targetImports :: ModuleTarget -> [LImportDecl GhcPs] +targetImports (ExistingImp ne) = NE.toList ne +targetImports (ImplicitPrelude xs) = xs + +oneAndOthers :: [a] -> [(a, [a])] +oneAndOthers = go + where + go [] = [] + go (x : xs) = (x, xs) : map (second (x :)) (go xs) + +isPreludeImplicit :: DynFlags -> Bool +isPreludeImplicit = xopt Lang.ImplicitPrelude + +#if !MIN_VERSION_ghc(9,3,0) +-- | Suggests disambiguation for ambiguous symbols. +suggestImportDisambiguation :: + DynFlags -> + Maybe T.Text -> + Annotated ParsedSource -> + T.Text -> + Diagnostic -> + [(T.Text, [Either TextEdit Rewrite])] +suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..} + | Just [ambiguous] <- + matchRegexUnifySpaces + _message + "Ambiguous occurrence ‘([^’]+)’" + , Just modules <- + map last + <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" + , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" = + suggestions ambiguous modules (isJust local) + | otherwise = [] + where + L _ HsModule {hsmodImports} = astA ps + + locDic = + fmap (NE.fromList . DL.toList) $ + Map.fromListWith (<>) $ + map + ( \i@(L _ idecl) -> + ( T.pack $ moduleNameString $ unLoc $ ideclName idecl + , DL.singleton i + ) + ) + hsmodImports + toModuleTarget "Prelude" + | isPreludeImplicit df + = Just $ ImplicitPrelude $ + maybe [] NE.toList (Map.lookup "Prelude" locDic) + toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic + parensed = + "(" `T.isPrefixOf` T.strip (textInRange _range txt) + -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] + removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort + hasDuplicate xs = length xs /= length (S.fromList xs) + suggestions symbol mods local + | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of + Just targets -> suggestionsImpl symbol (map (, []) targets) local + Nothing -> [] + | otherwise = case mapM toModuleTarget mods of + Just targets -> suggestionsImpl symbol (oneAndOthers targets) local + Nothing -> [] + suggestionsImpl symbol targetsWithRestImports local = + sortOn fst + [ ( renderUniquify mode modNameText symbol False + , disambiguateSymbol ps fileContents diag symbol mode + ) + | (modTarget, restImports) <- targetsWithRestImports + , let modName = targetModuleName modTarget + modNameText = T.pack $ moduleNameString modName + , mode <- + [ ToQualified parensed qual + | ExistingImp imps <- [modTarget] +#if MIN_VERSION_ghc(9,0,0) + {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} + -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation + -- nubOrd can't be used since SrcSpan is intentionally no Ord + , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) +#else + , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) +#endif + $ NE.toList imps + ] + ++ [ToQualified parensed modName + | any (occursUnqualified symbol . unLoc) + (targetImports modTarget) + || case modTarget of + ImplicitPrelude{} -> True + _ -> False + ] + ++ [HideOthers restImports | not (null restImports)] + ] ++ [ ( renderUniquify mode T.empty symbol True + , disambiguateSymbol ps fileContents diag symbol mode + ) | local, not (null targetsWithRestImports) + , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) + ] + renderUniquify HideOthers {} modName symbol local = + "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports" + renderUniquify (ToQualified _ qual) _ symbol _ = + "Replace with qualified: " + <> T.pack (moduleNameString qual) + <> "." + <> symbol +suggestImportDisambiguation _ _ _ _ _ = [] +#endif + +occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool +occursUnqualified symbol ImportDecl{..} + | isNothing ideclAs = Just False /= + -- I don't find this particularly comprehensible, + -- but HLint suggested me to do so... + (ideclHiding <&> \(isHiding, L _ ents) -> + let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents + in isHiding && not occurs || not isHiding && occurs + ) +occursUnqualified _ _ = False + +symbolOccursIn :: T.Text -> IE GhcPs -> Bool +symbolOccursIn symb = any ((== symb). printOutputable) . ieNames + +targetModuleName :: ModuleTarget -> ModuleName +targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" +targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = + unLoc ideclName +targetModuleName (ExistingImp _) = + error "Cannot happen!" + +#if !MIN_VERSION_ghc(9,3,0) +disambiguateSymbol :: + Annotated ParsedSource -> + T.Text -> + Diagnostic -> + T.Text -> + HidingMode -> + [Either TextEdit Rewrite] +disambiguateSymbol ps fileContents Diagnostic {..} (T.unpack -> symbol) = \case + (HideOthers hiddens0) -> + [ Right $ hideSymbol symbol idecl + | ExistingImp idecls <- hiddens0 + , idecl <- NE.toList idecls + ] + ++ mconcat + [ if null imps + then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) ps fileContents + else Right . hideSymbol symbol <$> imps + | ImplicitPrelude imps <- hiddens0 + ] + (ToQualified parensed qualMod) -> + let occSym = mkVarOcc symbol + rdr = Qual qualMod occSym + in Right <$> [ if parensed + then Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @(HsExpr GhcPs) df $ + T.unpack $ printOutputable $ + HsVar @GhcPs noExtField $ + reLocA $ L (mkGeneralSrcSpan "") rdr + else Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @RdrName df $ + T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr + ] +#endif + +findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) +findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs + +suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] +suggestFixConstructorImport Diagnostic{_range=_range,..} + -- ‘Success’ is a data constructor of ‘Result’ + -- To import it use + -- import Data.Aeson.Types( Result( Success ) ) + -- or + -- import Data.Aeson.Types( Result(..) ) (lsp-ui) + | Just [constructor, typ] <- + matchRegexUnifySpaces _message + "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" + = let fixedImport = typ <> "(" <> constructor <> ")" + in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] + | otherwise = [] + +#if !MIN_VERSION_ghc(9,3,0) +-- | Suggests a constraint for a declaration for which a constraint is missing. +suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} + | Just missingConstraint <- findMissingConstraint _message + = let codeAction = if _message =~ ("the type signature for:" :: String) + then suggestFunctionConstraint df parsedModule + else suggestInstanceConstraint df parsedModule + in codeAction diag missingConstraint + | otherwise = [] + where + findMissingConstraint :: T.Text -> Maybe T.Text + findMissingConstraint t = + let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement + regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" + match = matchRegexUnifySpaces t regex + matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams + in match <|> matchImplicitParams <&> last + +-- | Suggests a constraint for an instance declaration for which a constraint is missing. +suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint + | Just instHead <- instanceHead + = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] + | otherwise = [] + where + instanceHead + -- Suggests a constraint for an instance declaration with no existing constraints. + -- • No instance for (Eq a) arising from a use of ‘==’ + -- Possible fix: add (Eq a) to the context of the instance declaration + -- • In the expression: x == y + -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y + -- In the instance declaration for ‘Eq (Wrap a)’ + | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" + , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls + = Just instHead + -- Suggests a constraint for an instance declaration with one or more existing constraints. + -- • Could not deduce (Eq b) arising from a use of ‘==’ + -- from the context: Eq a + -- bound by the instance declaration at /path/to/Main.hs:7:10-32 + -- Possible fix: add (Eq b) to the context of the instance declaration + -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ + -- In the expression: x == y && x' == y' + -- In an equation for ‘==’: + -- (Pair x x') == (Pair y y') = x == y && x' == y' + | Just [instanceLineStr, constraintFirstCharStr] + <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" +#if !MIN_VERSION_ghc(9,2,0) + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) +#else + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})}))) +#endif + <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls + = Just hsib_body + | otherwise + = Nothing + + readPositionNumber :: T.Text -> UInt + readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral + + actionTitle :: T.Text -> T.Text + actionTitle constraint = "Add `" <> constraint + <> "` to the context of the instance declaration" + +suggestImplicitParameter :: + ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} + | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, +#if !MIN_VERSION_ghc(9,2,0) + Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) +#else + Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})}) +#endif + <- findSigOfDecl (== funId) hsmodDecls + = + [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) + , appendConstraint (T.unpack implicitT) hsib_body)] + | otherwise = [] +#endif + +findTypeSignatureName :: T.Text -> Maybe T.Text +findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head + +#if !MIN_VERSION_ghc(9,3,0) +-- | Suggests a constraint for a type signature with any number of existing constraints. +suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint +-- • No instance for (Eq a) arising from a use of ‘==’ +-- Possible fix: +-- add (Eq a) to the context of +-- the type signature for: +-- eq :: forall a. a -> a -> Bool +-- • In the expression: x == y +-- In an equation for ‘eq’: eq x y = x == y + +-- • Could not deduce (Eq b) arising from a use of ‘==’ +-- from the context: Eq a +-- bound by the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- at Main.hs:5:1-42 +-- Possible fix: +-- add (Eq b) to the context of +-- the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- • In the second argument of ‘(&&)’, namely ‘y == y'’ +-- In the expression: x == x' && y == y' +-- In an equation for ‘eq’: +-- eq (Pair x y) (Pair x' y') = x == x' && y == y' + | Just typeSignatureName <- findTypeSignatureName _message +#if !MIN_VERSION_ghc(9,2,0) + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) +#else + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) +#endif + <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls + , title <- actionTitle missingConstraint typeSignatureName + = [(title, appendConstraint (T.unpack missingConstraint) sig)] + | otherwise + = [] + where + actionTitle :: T.Text -> T.Text -> T.Text + actionTitle constraint typeSignatureName = "Add `" <> constraint + <> "` to the context of the type signature for `" <> typeSignatureName <> "`" + +-- | Suggests the removal of a redundant constraint for a type signature. +removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} +-- • Redundant constraint: Eq a +-- • In the type signature for: +-- foo :: forall a. Eq a => a -> a +-- • Redundant constraints: (Monoid a, Show a) +-- • In the type signature for: +-- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool + -- Account for both "Redundant constraint" and "Redundant constraints". + | "Redundant constraint" `T.isInfixOf` _message + , Just typeSignatureName <- findTypeSignatureName _message +#if !MIN_VERSION_ghc(9,2,0) + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) +#else + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) +#endif + <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls + , Just redundantConstraintList <- findRedundantConstraints _message + , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig + = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] + | otherwise = [] + where + toRemove df list a = T.pack (showSDoc df (ppr a)) `elem` list + + parseConstraints :: T.Text -> [T.Text] + parseConstraints t = t + & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") + <&> T.strip + + stripConstraintsParens :: T.Text -> T.Text + stripConstraintsParens constraints = + if "(" `T.isPrefixOf` constraints + then constraints & T.drop 1 & T.dropEnd 1 & T.strip + else constraints + +{- +9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning: + ⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", + +9.0: "message": "⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", +-} + findRedundantConstraints :: T.Text -> Maybe [T.Text] + findRedundantConstraints t = t + & T.lines + -- In <9.2 it's the first line, in 9.2 it' the second line + & take 2 + & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) + & listToMaybe + <&> (head >>> parseConstraints) + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + actionTitle :: [T.Text] -> T.Text -> T.Text + actionTitle constraintList typeSignatureName = + "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" + <> formatConstraints constraintList + <> "` from the context of the type signature for `" <> typeSignatureName <> "`" + +------------------------------------------------------------------------------------------------- + +suggestNewOrExtendImportForClassMethod :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] +suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} + | Just [methodName, className] <- + matchRegexUnifySpaces + _message + "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", + idents <- + maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ + Map.lookup methodName $ getExportsMap packageExportsMap = + mconcat $ suggest <$> idents + | otherwise = [] + where + suggest identInfo@IdentInfo {moduleNameText} + | importStyle <- NE.toList $ importStyles identInfo, + mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleNameText) = + case mImportDecl of + -- extend + Just decl -> + [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, + quickFixImportKind' "extend" style, + [Right $ uncurry extendImport (unImportStyle style) decl] + ) + | style <- importStyle + ] + -- new + _ + | Just (range, indent) <- newImportInsertRange ps fileContents + -> + (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$> + [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False) + | style <- importStyle, + let rendered = renderImportStyle style + ] + <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] + | otherwise -> [] +#endif + +suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestNewImport packageExportsMap ps fileContents Diagnostic{_message} + | msg <- unifySpaces _message + , Just thingMissing <- extractNotInScopeName msg + , qual <- extractQualifiedModuleName msg + , qual' <- + extractDoesNotExportModuleName msg + >>= (findImportDeclByModuleName hsmodImports . T.unpack) + >>= ideclAs . unLoc + <&> T.pack . moduleNameString . unLoc + , Just (range, indent) <- newImportInsertRange ps fileContents + , extendImportSuggestions <- matchRegexUnifySpaces msg + "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" + = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " ")) + | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions + ] + where + L _ HsModule {..} = astA ps +suggestNewImport _ _ _ _ = [] + +constructNewImportSuggestions + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)] +constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd + [ suggestion + | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] + , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) + , canUseIdent thingMissing identInfo + , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules + , suggestion <- renderNewImport identInfo + ] + where + renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)] + renderNewImport identInfo + | Just q <- qual + = [(quickFixImportKind "new.qualified", newQualImport m q)] + | otherwise + = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False) + | importStyle <- NE.toList $ importStyles identInfo] ++ + [(quickFixImportKind "new.all", newImportAll m)] + where + m = moduleNameText identInfo + +newtype NewImport = NewImport {unNewImport :: T.Text} + deriving (Show, Eq, Ord) + +newImportToEdit :: NewImport -> Annotated ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) +newImportToEdit (unNewImport -> imp) ps fileContents + | Just (range, indent) <- newImportInsertRange ps fileContents + = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " ")) + | otherwise = Nothing + +-- | Finds the next valid position for inserting a new import declaration +-- * If the file already has existing imports it will be inserted under the last of these, +-- it is assumed that the existing last import declaration is in a valid position +-- * If the file does not have existing imports, but has a (module ... where) declaration, +-- the new import will be inserted directly under this declaration (accounting for explicit exports) +-- * If the file has neither existing imports nor a module declaration, +-- the import will be inserted at line zero if there are no pragmas, +-- * otherwise inserted one line after the last file-header pragma +newImportInsertRange :: Annotated ParsedSource -> T.Text -> Maybe (Range, Int) +newImportInsertRange ps fileContents + | Just ((l, c), col) <- case hsmodImports of + -- When there is no existing imports, we only cares about the line number, setting column and indent to zero. + [] -> (\line -> ((line, 0), 0)) <$> findPositionNoImports ps fileContents + _ -> findPositionFromImports (map reLoc hsmodImports) last + , let insertPos = Position (fromIntegral l) (fromIntegral c) + = Just (Range insertPos insertPos, col) + | otherwise = Nothing + where + L _ HsModule {..} = astA ps + +-- | Find the position for a new import when there isn't an existing one. +-- * If there is a module declaration, a new import should be inserted under the module declaration (including exports list) +-- * Otherwise, a new import should be inserted after any file-header pragma. +findPositionNoImports :: Annotated ParsedSource -> T.Text -> Maybe Int +findPositionNoImports ps fileContents = + maybe (Just (findNextPragmaPosition fileContents)) (findPositionAfterModuleName ps) hsmodName + where + L _ HsModule {..} = astA ps + +-- | find line number right after module ... where +findPositionAfterModuleName :: Annotated ParsedSource +#if MIN_VERSION_ghc(9,2,0) + -> LocatedA ModuleName +#else + -> Located ModuleName +#endif + -> Maybe Int +findPositionAfterModuleName ps hsmodName' = do + -- Note that 'where' keyword and comments are not part of the AST. They belongs to + -- the exact-print information. To locate it, we need to find the previous AST node, + -- calculate the gap between it and 'where', then add them up to produce the absolute + -- position of 'where'. + + lineOffset <- whereKeywordLineOffset -- Calculate the gap before 'where' keyword. + case prevSrcSpan of + UnhelpfulSpan _ -> Nothing + (RealSrcSpan prevSrcSpan' _) -> + -- add them up produce the absolute location of 'where' keyword + Just $ srcLocLine (realSrcSpanEnd prevSrcSpan') + lineOffset + where + L _ HsModule {..} = astA ps + + -- The last AST node before 'where' keyword. Might be module name or export list. + prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports + + -- The relative position of 'where' keyword (in lines, relative to the previous AST node). + -- The exact-print API changed a lot in ghc-9.2, so we need to handle it seperately for different compiler versions. + whereKeywordLineOffset :: Maybe Int +#if MIN_VERSION_ghc(9,2,0) + whereKeywordLineOffset = case hsmodAnn of + EpAnn _ annsModule _ -> do + -- Find the first 'where' + whereLocation <- fmap NE.head . NE.nonEmpty . mapMaybe filterWhere . am_main $ annsModule + epaLocationToLine whereLocation + EpAnnNotUsed -> Nothing + filterWhere (AddEpAnn AnnWhere loc) = Just loc + filterWhere _ = Nothing + + epaLocationToLine :: EpaLocation -> Maybe Int + epaLocationToLine (EpaSpan sp) = Just . srcLocLine . realSrcSpanEnd $ sp + epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments + -- 'priorComments' contains the comments right before the current EpaLocation + -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and + -- the current AST node + epaLocationToLine (EpaDelta (DifferentLine line _) priorComments) = Just (line + sumCommentsOffset priorComments) + + sumCommentsOffset :: [LEpaComment] -> Int + sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine (anchor_op anchor)) + + anchorOpLine :: AnchorOperation -> Int + anchorOpLine UnchangedAnchor = 0 + anchorOpLine (MovedAnchor (SameLine _)) = 0 + anchorOpLine (MovedAnchor (DifferentLine line _)) = line +#else + whereKeywordLineOffset = do + ann <- annsA ps M.!? mkAnnKey (astA ps) + deltaPos <- fmap NE.head . NE.nonEmpty .mapMaybe filterWhere $ annsDP ann + pure $ deltaRow deltaPos + + -- Before ghc 9.2, DeltaPos doesn't take comment into acccount, so we don't need to sum line offset of comments. + filterWhere :: (KeywordId, DeltaPos) -> Maybe DeltaPos + filterWhere (keywordId, deltaPos) = + if keywordId == G AnnWhere then Just deltaPos else Nothing +#endif + +findPositionFromImports :: HasSrcSpan a => t -> (t -> a) -> Maybe ((Int, Int), Int) +findPositionFromImports hsField f = case getLoc (f hsField) of + RealSrcSpan s _ -> + let col = calcCol s + in Just ((srcLocLine (realSrcSpanEnd s), col), col) + _ -> Nothing + where calcCol s = srcLocCol (realSrcSpanStart s) - 1 + +-- | Find the position one after the last file-header pragma +-- Defaults to zero if there are no pragmas in file +findNextPragmaPosition :: T.Text -> Int +findNextPragmaPosition contents = lineNumber + where + lineNumber = afterLangPragma . afterOptsGhc $ afterShebang + afterLangPragma = afterPragma "LANGUAGE" contents' + afterOptsGhc = afterPragma "OPTIONS_GHC" contents' + afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0 + contents' = T.lines contents + +afterPragma :: T.Text -> [T.Text] -> Int -> Int +afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum + +lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int +lastLineWithPrefix p contents lineNum = max lineNum next + where + next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents + +checkPragma :: T.Text -> T.Text -> Bool +checkPragma name = check + where + check l = isPragma l && getName l == name + getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l + isPragma = T.isPrefixOf "{-#" + +-- | Construct an import declaration with at most one symbol +newImport + :: T.Text -- ^ module name + -> Maybe T.Text -- ^ the symbol + -> Maybe T.Text -- ^ qualified name + -> Bool -- ^ the symbol is to be imported or hidden + -> NewImport +newImport modName mSymbol mQual hiding = NewImport impStmt + where + symImp + | Just symbol <- mSymbol + , symOcc <- mkVarOcc $ T.unpack symbol = + " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")" + | otherwise = "" + impStmt = + "import " + <> maybe "" (const "qualified ") mQual + <> modName + <> (if hiding then " hiding" else "") + <> symImp + <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual + +newQualImport :: T.Text -> T.Text -> NewImport +newQualImport modName qual = newImport modName Nothing (Just qual) False + +newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport +newUnqualImport modName symbol = newImport modName (Just symbol) Nothing + +newImportAll :: T.Text -> NewImport +newImportAll modName = newImport modName Nothing Nothing False + +hideImplicitPreludeSymbol :: T.Text -> NewImport +hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True + +canUseIdent :: NotInScope -> IdentInfo -> Bool +canUseIdent NotInScopeDataConstructor{} = isDatacon +canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon +canUseIdent _ = const True + +data NotInScope + = NotInScopeDataConstructor T.Text + | NotInScopeTypeConstructorOrClass T.Text + | NotInScopeThing T.Text + deriving Show + +notInScope :: NotInScope -> T.Text +notInScope (NotInScopeDataConstructor t) = t +notInScope (NotInScopeTypeConstructorOrClass t) = t +notInScope (NotInScopeThing t) = t + +extractNotInScopeName :: T.Text -> Maybe NotInScope +extractNotInScopeName x + | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" + = Just $ NotInScopeTypeConstructorOrClass name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" + = Just $ NotInScopeThing name + | otherwise + = Nothing + +extractQualifiedModuleName :: T.Text -> Maybe T.Text +extractQualifiedModuleName x + | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" + = Just m + | otherwise + = Nothing + +-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules +-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier +-- from the imported one. +-- +-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s): +-- 1. +-- import qualified Data.Text as T +-- +-- Module ‘Data.Text’ does not export ‘putStrLn’. +-- +-- 2. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- +-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +-- +-- 3. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- import qualified Data.Function as T +-- +-- Neither ‘Data.Function’, +-- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +extractDoesNotExportModuleName :: T.Text -> Maybe T.Text +extractDoesNotExportModuleName x + | Just [m] <- + matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" + <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" + = Just m + | otherwise + = Nothing +------------------------------------------------------------------------------------------------- + + +mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit +mkRenameEdit contents range name = + if maybeIsInfixFunction == Just True + then TextEdit range ("`" <> name <> "`") + else TextEdit range name + where + maybeIsInfixFunction = do + curr <- textInRange range <$> contents + pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr + + +-- | Extract the type and surround it in parentheses except in obviously safe cases. +-- +-- Inferring when parentheses are actually needed around the type signature would +-- require understanding both the precedence of the context of the hole and of +-- the signature itself. Inserting them (almost) unconditionally is ugly but safe. +extractWildCardTypeSignature :: T.Text -> T.Text +extractWildCardTypeSignature msg + | enclosed || not isApp || isToplevelSig = sig + | otherwise = "(" <> sig <> ")" + where + msgSigPart = snd $ T.breakOnEnd "standing for " msg + (sig, rest) = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart + -- If we're completing something like ‘foo :: _’ parens can be safely omitted. + isToplevelSig = errorMessageRefersToToplevelHole rest + -- Parenthesize type applications, e.g. (Maybe Char). + isApp = T.any isSpace sig + -- Do not add extra parentheses to lists, tuples and already parenthesized types. + enclosed = not (T.null sig) && (T.head sig, T.last sig) `elem` [('(', ')'), ('[', ']')] + +-- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@. +-- The former is considered toplevel case for which the function returns 'True', +-- the latter is not toplevel and the returned value is 'False'. +-- +-- When type hole is at toplevel then there’s a line starting with +-- "• In the type signature" which ends with " :: _" like in the +-- following snippet: +-- +-- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error: +-- • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’ +-- To use the inferred type, enable PartialTypeSignatures +-- • In the type signature: decl :: _ +-- In an equation for ‘splitAnnots’: +-- splitAnnots m@HsModule {hsmodAnn, hsmodDecls} +-- = undefined +-- where +-- ann :: SrcSpanAnnA +-- decl :: _ +-- L ann decl = head hsmodDecls +-- • Relevant bindings include +-- [REDACTED] +-- +-- When type hole is not at toplevel there’s a stack of where +-- the hole was located ending with "In the type signature": +-- +-- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error: +-- • Found type wildcard ‘_’ standing for ‘GhcPs’ +-- To use the inferred type, enable PartialTypeSignatures +-- • In the first argument of ‘HsDecl’, namely ‘_’ +-- In the type ‘HsDecl _’ +-- In the type signature: decl :: HsDecl _ +-- • Relevant bindings include +-- [REDACTED] +errorMessageRefersToToplevelHole :: T.Text -> Bool +errorMessageRefersToToplevelHole msg = + not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest + where + (prefix, rest) = T.breakOn "• In the type signature:" msg + +extractRenamableTerms :: T.Text -> [T.Text] +extractRenamableTerms msg + -- Account for both "Variable not in scope" and "Not in scope" + | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg + | otherwise = [] + where + extractSuggestions = map getEnclosed + . concatMap singleSuggestions + . filter isKnownSymbol + . T.lines + singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited + isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t + getEnclosed = T.dropWhile (== '‘') + . T.dropWhileEnd (== '’') + . T.dropAround (\c -> c /= '‘' && c /= '’') + +-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace +-- between the end of the range and the next newline), extend the range to take up the whole line. +extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range +extendToWholeLineIfPossible contents range@Range{..} = + let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents + extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line + in if extend then Range _start (Position (_line _end + 1) 0) else range + +splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) +splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x + | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x + , (preCol, postCol) <- T.splitAt col mid + = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) + | otherwise = (x, T.empty) + +-- | Returns [start .. end[ +textInRange :: Range -> T.Text -> T.Text +textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = + case compare startRow endRow of + LT -> + let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine + (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of + [] -> ("", []) + firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) + maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines + in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) + EQ -> + let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) + in T.take (endCol - startCol) (T.drop startCol line) + GT -> "" + where + linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) + +-- | Returns the ranges for a binding in an import declaration +rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] +rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies + where + b' = wrapOperatorInParens b +rangesForBindingImport _ _ = [] + +wrapOperatorInParens :: String -> String +wrapOperatorInParens x = + case uncons x of + -- see #2483 and #2859 + -- common lens functions use the _ prefix, and should not be wrapped in parens + Just ('_', _t) -> x + Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")" + Nothing -> mempty + +smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] +smallerRangesForBindingExport lies b = + concatMap (mapMaybe srcSpanToRange . ranges') lies + where + unqualify = snd . breakOnEnd "." + b' = wrapOperatorInParens . unqualify $ b +#if !MIN_VERSION_ghc(9,2,0) + ranges' (L _ (IEThingWith _ thing _ inners labels)) + | T.unpack (printOutputable thing) == b' = [] + | otherwise = + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] + ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b'] +#else + ranges' (L _ (IEThingWith _ thing _ inners)) + | T.unpack (printOutputable thing) == b' = [] + | otherwise = + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] +#endif + ranges' _ = [] + +rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] +rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] +#if !MIN_VERSION_ghc(9,2,0) +rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) +#else +rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) +#endif + | T.unpack (printOutputable thing) == b = [l] + | otherwise = + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] +#if !MIN_VERSION_ghc(9,2,0) + ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b] +#endif +rangesForBinding' _ _ = [] + +-- | 'matchRegex' combined with 'unifySpaces' +matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] +matchRegexUnifySpaces message = matchRegex (unifySpaces message) + +-- | 'allMatchRegex' combined with 'unifySpaces' +allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegexUnifySpaces message = + allMatchRegex (unifySpaces message) + +-- | Returns Just (the submatches) for the first capture, or Nothing. +matchRegex :: T.Text -> T.Text -> Maybe [T.Text] +matchRegex message regex = case message =~~ regex of + Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings + Nothing -> Nothing + +-- | Returns Just (all matches) for the first capture, or Nothing. +allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegex message regex = message =~~ regex + + +unifySpaces :: T.Text -> T.Text +unifySpaces = T.unwords . T.words + +-- functions to help parse multiple import suggestions + +-- | Returns the first match if found +regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text +regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of + Just (h:_) -> Just h + _ -> Nothing + +-- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and +-- | return (Data.Map, app/ModuleB.hs:2:1-18) +regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text) +regExPair (modname, srcpair) = do + x <- regexSingleMatch modname "‘([^’]*)’" + y <- regexSingleMatch srcpair "\\((.*)\\)" + return (x, y) + +-- | Process a list of (module_name, filename:src_span) values +-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] +regExImports :: T.Text -> Maybe [(T.Text, T.Text)] +regExImports msg = result + where + parts = T.words msg + isPrefix = not . T.isPrefixOf "(" + (mod, srcspan) = partition isPrefix parts + -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) + result = if length mod == length srcspan then + regExPair `traverse` zip mod srcspan + else Nothing + +matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) +matchRegExMultipleImports message = do + let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" + (binding, imports) <- case matchRegexUnifySpaces message pat of + Just [x, xs] -> Just (x, xs) + _ -> Nothing + imps <- regExImports imports + return (binding, imps) + +-- | Possible import styles for an 'IdentInfo'. +-- +-- The first 'Text' parameter corresponds to the 'rendered' field of the +-- 'IdentInfo'. +data ImportStyle + = ImportTopLevel T.Text + -- ^ Import a top-level export from a module, e.g., a function, a type, a + -- class. + -- + -- > import M (?) + -- + -- Some exports that have a parent, like a type-class method or an + -- associated type/data family, can still be imported as a top-level + -- import. + -- + -- Note that this is not the case for constructors, they must always be + -- imported as part of their parent data type. + + | ImportViaParent T.Text T.Text + -- ^ Import an export (first parameter) through its parent (second + -- parameter). + -- + -- import M (P(?)) + -- + -- @P@ and @?@ can be a data type and a constructor, a class and a method, + -- a class and an associated type/data family, etc. + + | ImportAllConstructors T.Text + -- ^ Import all constructors for a specific data type. + -- + -- import M (P(..)) + -- + -- @P@ can be a data type or a class. + deriving Show + +importStyles :: IdentInfo -> NonEmpty ImportStyle +importStyles IdentInfo {parent, rendered, isDatacon} + | Just p <- parent + -- Constructors always have to be imported via their parent data type, but + -- methods and associated type/data families can also be imported as + -- top-level exports. + = ImportViaParent rendered p + :| [ImportTopLevel rendered | not isDatacon] + <> [ImportAllConstructors p] + | otherwise + = ImportTopLevel rendered :| [] + +-- | Used for adding new imports +renderImportStyle :: ImportStyle -> T.Text +renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" +renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" +renderImportStyle (ImportAllConstructors p) = p <> "(..)" + +-- | Used for extending import lists +unImportStyle :: ImportStyle -> (Maybe String, String) +unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) +unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) +unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) + + +quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind +quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" +quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent" +quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors" + +quickFixImportKind :: T.Text -> CodeActionKind +quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -0,0 +1,300 @@ +module Development.IDE.Plugin.CodeAction.Args + ( CodeActionTitle, + CodeActionPreferred, + GhcideCodeActionResult, + GhcideCodeAction, + mkGhcideCAPlugin, + mkGhcideCAsPlugin, + ToTextEdit (..), + ToCodeAction (..), + wrap, + mkCA, + ) +where + +import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Either (fromRight) +import qualified Data.HashMap.Strict as Map +import Data.IORef.Extra +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Development.IDE hiding + (pluginHandlers) +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.ExactPrint +#if !MIN_VERSION_ghc(9,3,0) +import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, + rewriteToEdit) +#endif +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + GlobalBindingTypeSigsResult) +import Development.IDE.Spans.LocalBindings (Bindings) +import Development.IDE.Types.Exports (ExportsMap) +import Development.IDE.Types.Options (IdeOptions) +import Ide.Plugin.Config (Config) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types + +type CodeActionTitle = T.Text + +type CodeActionPreferred = Bool + +type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] + +type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult + +------------------------------------------------------------------------------------------------- + +{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} +runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do + let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key + caaGhcSession <- onceIO $ runRule GhcSession + caaExportsMap <- + onceIO $ + caaGhcSession >>= \case + Just env -> do + pkgExports <- envPackageExports env + localExports <- readTVarIO (exportsMap $ shakeExtras state) + pure $ localExports <> pkgExports + _ -> pure mempty + caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions + caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments + caaContents <- + onceIO $ + runRule GetFileContents >>= \case + Just (_, txt) -> pure txt + _ -> pure Nothing + caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule +#if !MIN_VERSION_ghc(9,3,0) + caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource +#endif + caaTmr <- onceIO $ runRule TypeCheck + caaHar <- onceIO $ runRule GetHieAst + caaBindings <- onceIO $ runRule GetBindings + caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + liftIO $ + concat + <$> sequence + [ runReaderT codeAction caa + | caaDiagnostic <- diags, + let caa = CodeActionArgs {..} + ] + +mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) +mkCA title kind isPreferred diags edit = + InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing + +mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState +mkGhcideCAPlugin codeAction plId = + (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ + \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do + results <- runGhcideCodeAction state params codeAction + pure $ + Right $ + List + [ mkCA title kind isPreferred diags edit + | (title, kind, isPreferred, tedit) <- results, + let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + ] + } + +mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState +mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions + +------------------------------------------------------------------------------------------------- + +class ToTextEdit a where + toTextEdit :: CodeActionArgs -> a -> IO [TextEdit] + +instance ToTextEdit TextEdit where + toTextEdit _ = pure . pure + +#if !MIN_VERSION_ghc(9,3,0) +instance ToTextEdit Rewrite where + toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ + runMaybeT $ do + df <- MaybeT caaDf +#if !MIN_VERSION_ghc(9,2,0) + ps <- MaybeT caaAnnSource + let r = rewriteToEdit df (annsA ps) rw +#else + let r = rewriteToEdit df rw +#endif + pure $ fromRight [] r +#endif + +instance ToTextEdit a => ToTextEdit [a] where + toTextEdit caa = foldMap (toTextEdit caa) + +instance ToTextEdit a => ToTextEdit (Maybe a) where + toTextEdit caa = maybe (pure []) (toTextEdit caa) + +instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where + toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) + +------------------------------------------------------------------------------------------------- + +data CodeActionArgs = CodeActionArgs + { caaExportsMap :: IO ExportsMap, + caaGhcSession :: IO (Maybe HscEnvEq), + caaIdeOptions :: IO IdeOptions, + caaParsedModule :: IO (Maybe ParsedModule), + caaContents :: IO (Maybe T.Text), + caaDf :: IO (Maybe DynFlags), +#if MIN_VERSION_ghc(9,3,0) + caaAnnSource :: IO (Maybe ParsedSource), +#else + caaAnnSource :: IO (Maybe (Annotated ParsedSource)), +#endif + caaTmr :: IO (Maybe TcModuleResult), + caaHar :: IO (Maybe HieAstResult), + caaBindings :: IO (Maybe Bindings), + caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult), + caaDiagnostic :: Diagnostic + } + +-- | There's no concurrency in each provider, +-- so we don't need to be thread-safe here +onceIO :: MonadIO m => IO a -> m (IO a) +onceIO io = do + var <- liftIO $ newIORef Nothing + pure $ + readIORef var >>= \case + Just x -> pure x + _ -> io >>= \x -> writeIORef' var (Just x) >> pure x + +------------------------------------------------------------------------------------------------- + +wrap :: (ToCodeAction a) => a -> GhcideCodeAction +wrap = toCodeAction + +class ToCodeAction a where + toCodeAction :: a -> GhcideCodeAction + +instance ToCodeAction GhcideCodeAction where + toCodeAction = id + +instance Semigroup GhcideCodeAction where + a <> b = toCodeAction [a, b] + +instance Monoid GhcideCodeAction where + mempty = pure [] + +instance ToCodeAction a => ToCodeAction [a] where + toCodeAction = fmap concat . mapM toCodeAction + +instance ToCodeAction a => ToCodeAction (Maybe a) where + toCodeAction = maybe (pure []) toCodeAction + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where + toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where + toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where + toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where + toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te + +------------------------------------------------------------------------------------------------- + +toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction +toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f + +toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction +toCodeAction2 get f = ReaderT $ \caa -> + get caa >>= \case + Just x -> flip runReaderT caa . toCodeAction . f $ x + _ -> pure [] + +toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction +toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f + +-- | this instance returns a delta AST, useful for exactprint transforms +instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where +#if !MIN_VERSION_ghc(9,3,0) + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> + x >>= \case + Just s -> flip runReaderT caa . toCodeAction . f . astA $ s + _ -> pure [] +#else + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> + x >>= \case + Just s -> flip runReaderT caa . toCodeAction . f . pm_parsed_source $ s + _ -> pure [] +#endif + +instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where + toCodeAction = toCodeAction3 caaExportsMap + +instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where + toCodeAction = toCodeAction3 caaIdeOptions + +instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x + +instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where + toCodeAction = toCodeAction1 caaParsedModule + +instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where + toCodeAction = toCodeAction2 caaParsedModule + +instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where + toCodeAction = toCodeAction1 caaContents + +instance ToCodeAction r => ToCodeAction (T.Text -> r) where + toCodeAction = toCodeAction2 caaContents + +instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where + toCodeAction = toCodeAction1 caaDf + +instance ToCodeAction r => ToCodeAction (DynFlags -> r) where + toCodeAction = toCodeAction2 caaDf + +#if !MIN_VERSION_ghc(9,3,0) +instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where + toCodeAction = toCodeAction1 caaAnnSource + +instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where + toCodeAction = toCodeAction2 caaAnnSource +#endif + +instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where + toCodeAction = toCodeAction1 caaTmr + +instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where + toCodeAction = toCodeAction2 caaTmr + +instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where + toCodeAction = toCodeAction1 caaHar + +instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where + toCodeAction = toCodeAction2 caaHar + +instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where + toCodeAction = toCodeAction1 caaBindings + +instance ToCodeAction r => ToCodeAction (Bindings -> r) where + toCodeAction = toCodeAction2 caaBindings + +instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction1 caaGblSigs + +instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction2 caaGblSigs + +instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where + toCodeAction = toCodeAction1 caaGhcSession + +instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where + toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession) diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -0,0 +1,725 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Development.IDE.Plugin.CodeAction.ExactPrint ( + Rewrite (..), + rewriteToEdit, + rewriteToWEdit, +#if !MIN_VERSION_ghc(9,2,0) + transferAnn, +#endif + + -- * Utilities + appendConstraint, + removeConstraint, + extendImport, + hideSymbol, + liftParseAST, + + wildCardSymbol +) where + +import Control.Monad +import Control.Monad.Trans +import Data.Char (isAlphaNum) +import Data.Data (Data) +import Data.Generics (listify) +import qualified Data.Text as T +import Development.IDE.GHC.Compat hiding (Annotation) +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.Util +import Development.IDE.Spans.Common +import GHC.Exts (IsList (fromList)) +import GHC.Stack (HasCallStack) +import Language.Haskell.GHC.ExactPrint +import Language.LSP.Types + +import Development.IDE.Plugin.CodeAction.Util + +-- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. +#if MIN_VERSION_ghc(9,2,0) +import Control.Lens (_head, _last, over) +import Data.Bifunctor (first) +import Data.Default (Default (..)) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import GHC (AddEpAnn (..), AnnContext (..), AnnList (..), + AnnParen (..), DeltaPos (SameLine), EpAnn (..), + EpaLocation (EpaDelta), + IsUnicodeSyntax (NormalSyntax), + NameAdornment (NameParens), + TrailingAnn (AddCommaAnn), addAnns, ann, + emptyComments, reAnnL) +#else +import Control.Applicative (Alternative ((<|>))) +import Control.Monad.Extra (whenJust) +import Data.Foldable (find) +import Data.Functor (($>)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust, + isNothing, mapMaybe) +import qualified Development.IDE.GHC.Compat.Util as Util +import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), + KeywordId (G), mkAnnKey) +#endif + +------------------------------------------------------------------------------ + +-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the +-- given 'ast'. +data Rewrite where + Rewrite :: +#if !MIN_VERSION_ghc(9,2,0) + Annotate ast => +#else + (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) => +#endif + -- | The 'SrcSpan' that we want to rewrite + SrcSpan -> + -- | The ast that we want to graft +#if !MIN_VERSION_ghc(9,2,0) + (DynFlags -> TransformT (Either String) (Located ast)) -> +#else + (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) -> +#endif + Rewrite + +------------------------------------------------------------------------------ +#if MIN_VERSION_ghc(9,2,0) +class ResetEntryDP ann where + resetEntryDP :: GenLocated ann ast -> GenLocated ann ast +instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where + -- resetEntryDP = flip setEntryDP (SameLine 0) + resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0) +instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where + resetEntryDP = id +#endif + +-- | Convert a 'Rewrite' into a list of '[TextEdit]'. +rewriteToEdit :: HasCallStack => + DynFlags -> +#if !MIN_VERSION_ghc(9,2,0) + Anns -> +#endif + Rewrite -> + Either String [TextEdit] +rewriteToEdit dflags +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + (Rewrite dst f) = do + (ast, anns , _) <- runTransformT +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + $ do + ast <- f dflags +#if !MIN_VERSION_ghc(9,2,0) + ast <$ setEntryDPT ast (DP (0, 0)) +#else + pure $ traceAst "REWRITE_result" $ resetEntryDP ast +#endif + let editMap = + [ TextEdit (fromJust $ srcSpanToRange dst) $ + T.pack $ exactPrint ast +#if !MIN_VERSION_ghc(9,2,0) + (fst anns) +#endif + ] + pure editMap + +-- | Convert a 'Rewrite' into a 'WorkspaceEdit' +rewriteToWEdit :: DynFlags + -> Uri +#if !MIN_VERSION_ghc(9,2,0) + -> Anns +#endif + -> Rewrite + -> Either String WorkspaceEdit +rewriteToWEdit dflags uri +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + r = do + edits <- rewriteToEdit dflags +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + r + return $ + WorkspaceEdit + { _changes = Just (fromList [(uri, List edits)]) + , _documentChanges = Nothing + , _changeAnnotations = Nothing + } + +------------------------------------------------------------------------------ + +#if !MIN_VERSION_ghc(9,2,0) +-- | Fix the parentheses around a type context +fixParens :: + (Monad m, Data (HsType pass), pass ~ GhcPass p0) => + Maybe DeltaPos -> + Maybe DeltaPos -> + LHsContext pass -> + TransformT m [LHsType pass] +fixParens + openDP closeDP + ctxt@(L _ elems) = do + -- Paren annotation for type contexts are usually quite screwed up + -- we remove duplicates and fix negative DPs + let parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] + modifyAnnsT $ + Map.adjust + ( \x -> + let annsMap = Map.fromList (annsDP x) + in x + { annsDP = + Map.toList $ + Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $ + Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $ + annsMap <> parens + } + ) + (mkAnnKey ctxt) + return $ map dropHsParTy elems +#endif + +dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass) +dropHsParTy (L _ (HsParTy _ ty)) = ty +dropHsParTy other = other + +removeConstraint :: + -- | Predicate: Which context to drop. + (LHsType GhcPs -> Bool) -> + LHsType GhcPs -> + Rewrite +removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" + where + go :: LHsType GhcPs -> Rewrite +#if !MIN_VERSION_ghc(9,2,0) + go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do +#endif + let ctxt' = filter (not . toRemove) ctxt + removeStuff = (toRemove <$> headMaybe ctxt) == Just True +#if !MIN_VERSION_ghc(9,2,0) + when removeStuff $ + setEntryDPT hst_body (DP (0, 0)) + return $ L l $ it{hst_ctxt = L l' ctxt'} +#else + let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body + return $ case ctxt' of + [] -> hst_body' + _ -> do + let ctxt'' = over _last (first removeComma) ctxt' + L l $ it{ hst_ctxt = Just $ L l' ctxt'' + , hst_body = hst_body' + } +#endif + go (L _ (HsParTy _ ty)) = go ty + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other + +-- | Append a constraint at the end of a type context. +-- If no context is present, a new one will be created. +appendConstraint :: + -- | The new constraint to append + String -> + -- | The type signature where the constraint is to be inserted, also assuming annotated + LHsType GhcPs -> + Rewrite +appendConstraint constraintT = go . traceAst "appendConstraint" + where +#if !MIN_VERSION_ghc(9,2,0) + go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do +#endif + constraint <- liftParseAST df constraintT +#if !MIN_VERSION_ghc(9,2,0) + setEntryDPT constraint (DP (0, 1)) + + -- Paren annotations are usually attached to the first and last constraints, + -- rather than to the constraint list itself, so to preserve them we need to reposition them + closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt + openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt + ctxt' <- fixParens + (join openParenDP) (join closeParenDP) + (L l' ctxt) + addTrailingCommaT (last ctxt') + return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]} +#else + constraint <- pure $ setEntryDP constraint (SameLine 1) + let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' + -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint + -- we have to reposition it manually into the AnnContext + close_dp = case ctxt of + [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close + _ -> Nothing + ctxt' = over _last (first addComma) $ map dropHsParTy ctxt + return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]} +#endif + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L _ (HsParTy _ ty)) = go ty + go ast@(L l _) = Rewrite (locA l) $ \df -> do + -- there isn't a context, so we must create one + constraint <- liftParseAST df constraintT + lContext <- uniqueSrcSpanT + lTop <- uniqueSrcSpanT +#if !MIN_VERSION_ghc(9,2,0) + let context = L lContext [constraint] + addSimpleAnnT context dp00 $ + (G AnnDarrow, DP (0, 1)) : + concat + [ [ (G AnnOpenP, dp00) + , (G AnnCloseP, dp00) + ] + | hsTypeNeedsParens sigPrec $ unLoc constraint + ] +#else + let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint] + annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens] + needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint + ast <- pure $ setEntryDP ast (SameLine 1) +#endif + + return $ reLocA $ L lTop $ HsQualTy noExtField context ast + +liftParseAST + :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) + => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) +liftParseAST df s = case parseAST df "" s of +#if !MIN_VERSION_ghc(9,2,0) + Right (anns, x) -> modifyAnnsT (anns <>) $> x +#else + Right x -> pure (makeDeltaAst x) +#endif + Left _ -> lift $ Left $ "No parse: " <> s + +#if !MIN_VERSION_ghc(9,2,0) +lookupAnn :: (Data a, Monad m) + => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) +lookupAnn comment la = do + anns <- getAnnsT + return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP + +dp00 :: DeltaPos +dp00 = DP (0, 0) + +-- | Copy anns attached to a into b with modification, then delete anns of a +transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () +transferAnn la lb f = do + anns <- getAnnsT + let oldKey = mkAnnKey la + newKey = mkAnnKey lb + oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns + putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns + +#endif + +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (a : _) = Just a + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe other = Just $ last other + +liftMaybe :: String -> Maybe a -> TransformT (Either String) a +liftMaybe _ (Just x) = return x +liftMaybe s _ = lift $ Left s + +------------------------------------------------------------------------------ +extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite +extendImport mparent identifier lDecl@(L l _) = + Rewrite (locA l) $ \df -> do + case mparent of + -- This will also work for `ImportAllConstructors` + Just parent -> extendImportViaParent df parent identifier lDecl + _ -> extendImportTopLevel identifier lDecl + +-- | Add an identifier or a data type to import list. Expects a Delta AST +-- +-- extendImportTopLevel "foo" AST: +-- +-- import A --> Error +-- import A (foo) --> Error +-- import A (bar) --> import A (bar, foo) +extendImportTopLevel :: + -- | rendered + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) +extendImportTopLevel thing (L l it@ImportDecl{..}) + | Just (hide, L l' lies) <- ideclHiding + , hasSibling <- not $ null lies = do + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing + let alreadyImported = + printOutputable (occName (unLoc rdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies) + when alreadyImported $ + lift (Left $ thing <> " already imported") + + let lie = reLocA $ L src $ IEName rdr + x = reLocA $ L top $ IEVar noExtField lie + + if x `elem` lies + then lift (Left $ thing <> " already imported") + else do +#if !MIN_VERSION_ghc(9,2,0) + anns <- getAnnsT + maybe (pure ()) addTrailingCommaT (lastMaybe lies) + addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] + addSimpleAnnT rdr dp00 [(G AnnVal, dp00)] + + -- When the last item already has a trailing comma, we append a trailing comma to the new item. + let isAnnComma (G AnnComma, _) = True + isAnnComma _ = False + shouldAddTrailingComma = maybe False nodeHasComma (lastMaybe lies) + && not (nodeHasComma (L l' lies)) + + nodeHasComma :: Data a => Located a -> Bool + nodeHasComma x = isJust $ Map.lookup (mkAnnKey x) anns >>= find isAnnComma . annsDP + when shouldAddTrailingComma (addTrailingCommaT x) + + -- Parens are attachted to `lies`, so if `lies` was empty previously, + -- we need change the ann key from `[]` to `:` to keep parens and other anns. + unless hasSibling $ + transferAnn (L l' lies) (L l' [x]) id + return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} +#else + let lies' = addCommaInImportList lies x + return $ L l it{ideclHiding = Just (hide, L l' lies')} +#endif +extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" + +wildCardSymbol :: String +wildCardSymbol = ".." + +-- | Add an identifier with its parent to import list +-- +-- extendImportViaParent "Bar" "Cons" AST: +-- +-- import A --> Error +-- import A (Bar(..)) --> Error +-- import A (Bar(Cons)) --> Error +-- import A () --> import A (Bar(Cons)) +-- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) +-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) +-- +-- extendImportViaParent "Bar" ".." AST: +-- import A () --> import A (Bar(..)) +-- import A (Foo, Bar) -> import A (Foo, Bar(..)) +-- import A (Foo, Bar()) -> import A (Foo, Bar(..)) +extendImportViaParent :: + DynFlags -> + -- | parent (already parenthesized if needs) + String -> + -- | rendered child + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) +extendImportViaParent df parent child (L l it@ImportDecl{..}) + | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies + where + go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) + | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" + go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) + -- ThingAbs ie => ThingWith ie child + | parent == unIEWrappedName ie = do + srcChild <- uniqueSrcSpanT + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + childLIE = reLocA $ L srcChild $ IEName childRdr +#if !MIN_VERSION_ghc(9,2,0) + x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] + -- take anns from ThingAbs, and attatch parens to it + transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} + addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] +#else + x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE] +#endif + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#if !MIN_VERSION_ghc(9,2,0) + go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) +#else + go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs) +#endif + -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) + | parent == unIEWrappedName ie + , child == wildCardSymbol = do +#if MIN_VERSION_ghc(9,2,0) + let it' = it{ideclHiding = Just (hide, lies)} + thing = IEThingWith newl twIE (IEWildcard 2) [] + newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' + lies = L l' $ reverse pre ++ [L l'' thing] ++ xs + return $ L l it' +#else + let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2) [] []) + modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann})) + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)} +#endif + | parent == unIEWrappedName ie + , hasSibling <- not $ null lies' = + do + srcChild <- uniqueSrcSpanT + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child +#if MIN_VERSION_ghc(9,2,0) + childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 +#endif + let alreadyImported = + printOutputable (occName (unLoc childRdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies') + when alreadyImported $ + lift (Left $ child <> " already included in " <> parent <> " imports") + + let childLIE = reLocA $ L srcChild $ IEName childRdr +#if !MIN_VERSION_ghc(9,2,0) + when hasSibling $ + addTrailingCommaT (last lies') + addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)] + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} +#else + let it' = it{ideclHiding = Just (hide, lies)} + lies = L l' $ reverse pre ++ + [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs + fixLast = if hasSibling then first addComma else id + return $ L l it' +#endif + go hide l' pre (x : xs) = go hide l' (x : pre) xs + go hide l' pre [] + | hasSibling <- not $ null pre = do + -- [] => ThingWith parent [child] + l'' <- uniqueSrcSpanT + srcParent <- uniqueSrcSpanT + srcChild <- uniqueSrcSpanT + parentRdr <- liftParseAST df parent + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + isParentOperator = hasParen parent +#if !MIN_VERSION_ghc(9,2,0) + when hasSibling $ + addTrailingCommaT (head pre) + let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr) + childLIE = reLocA $ L srcChild $ IEName childRdr +#else + let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr') + parentRdr' = modifyAnns parentRdr $ \case + it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1} + other -> other + childLIE = reLocA $ L srcChild $ IEName childRdr +#endif +#if !MIN_VERSION_ghc(9,2,0) + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] + -- Add AnnType for the parent if it's parenthesized (type operator) + when isParentOperator $ + addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))] + addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator + addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)] + addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] + -- Parens are attachted to `pre`, so if `pre` was empty previously, + -- we need change the ann key from `[]` to `:` to keep parens and other anns. + unless hasSibling $ + transferAnn (L l' $ reverse pre) (L l' [x]) id + + let lies' = reverse pre ++ [x] +#else + listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] + + lies' = addCommaInImportList (reverse pre) x +#endif + return $ L l it{ideclHiding = Just (hide, L l' lies')} +extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" + +#if MIN_VERSION_ghc(9,2,0) +-- Add an item in an import list, taking care of adding comma if needed. +addCommaInImportList :: + -- | Initial list + [LocatedAn AnnListItem a] + -- | Additionnal item + -> LocatedAn AnnListItem a + -> [LocatedAn AnnListItem a] +addCommaInImportList lies x = + fixLast lies ++ [newItem] + where + isTrailingAnnComma :: TrailingAnn -> Bool + isTrailingAnnComma (AddCommaAnn _) = True + isTrailingAnnComma _ = False + + -- check if there is an existing trailing comma + existingTrailingComma = fromMaybe False $ do + L lastItemSrcAnn _ <- lastMaybe lies + lastItemAnn <- case ann lastItemSrcAnn of + EpAnn _ lastItemAnn _ -> pure lastItemAnn + _ -> Nothing + pure $ any isTrailingAnnComma (lann_trailing lastItemAnn) + + hasSibling = not . null $ lies + + -- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the + -- preceding item already has one. + newItem = first (if existingTrailingComma then addComma else id) $ + setEntryDP x (SameLine $ if hasSibling then 1 else 0) + + -- Add the comma (if needed) + fixLast :: [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a] + fixLast = over _last (first (if existingTrailingComma then id else addComma)) +#endif + +unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String +unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ) + +hasParen :: String -> Bool +hasParen ('(' : _) = True +hasParen _ = False + +#if !MIN_VERSION_ghc(9,2,0) +unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)] +unqalDP c paren = + ( if paren + then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)] + else pure + ) + (G AnnVal, dp00) +#endif + +------------------------------------------------------------------------------ + +-- | Hide a symbol from import declaration +hideSymbol :: + String -> LImportDecl GhcPs -> Rewrite +hideSymbol symbol lidecl@(L loc ImportDecl{..}) = + case ideclHiding of + Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing + Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) + Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports +hideSymbol _ (L _ (XImportDecl _)) = + error "cannot happen" + +extendHiding :: + String -> + LImportDecl GhcPs -> +#if !MIN_VERSION_ghc(9,2,0) + Maybe (Located [LIE GhcPs]) -> +#else + Maybe (XRec GhcPs [LIE GhcPs]) -> +#endif + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +extendHiding symbol (L l idecls) mlies df = do + L l' lies <- case mlies of +#if !MIN_VERSION_ghc(9,2,0) + Nothing -> flip L [] <$> uniqueSrcSpanT +#else + Nothing -> do + src <- uniqueSrcSpanT + let ann = noAnnSrcSpanDP0 src + ann' = flip (fmap.fmap) ann $ \x -> x + {al_rest = [AddEpAnn AnnHiding (epl 1)] + ,al_open = Just $ AddEpAnn AnnOpenP (epl 1) + ,al_close = Just $ AddEpAnn AnnCloseP (epl 0) + } + return $ L ann' [] +#endif + Just pr -> pure pr + let hasSibling = not $ null lies + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + rdr <- liftParseAST df symbol +#if MIN_VERSION_ghc(9,2,0) + rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr) +#endif + let lie = reLocA $ L src $ IEName rdr + x = reLocA $ L top $ IEVar noExtField lie +#if MIN_VERSION_ghc(9,2,0) + x <- pure $ if hasSibling then first addComma x else x + lies <- pure $ over _head (`setEntryDP` SameLine 1) lies +#endif +#if !MIN_VERSION_ghc(9,2,0) + singleHide = L l' [x] + when (isNothing mlies) $ do + addSimpleAnnT + singleHide + dp00 + [ (G AnnHiding, DP (0, 1)) + , (G AnnOpenP, DP (0, 1)) + , (G AnnCloseP, DP (0, 0)) + ] + addSimpleAnnT x (DP (0, 0)) [] + addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr + if hasSibling + then do + addTrailingCommaT x + addSimpleAnnT (head lies) (DP (0, 1)) [] + unless (null $ tail lies) $ + addTrailingCommaT (head lies) -- Why we need this? + else forM_ mlies $ \lies0 -> do + transferAnn lies0 singleHide id +#endif + return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} + where + isOperator = not . all isAlphaNum . occNameString . rdrNameOcc + +deleteFromImport :: + String -> + LImportDecl GhcPs -> +#if !MIN_VERSION_ghc(9,2,0) + Located [LIE GhcPs] -> +#else + XRec GhcPs [LIE GhcPs] -> +#endif + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do + let edited = L lieLoc deletedLies + lidecl' = + L l $ + idecl + { ideclHiding = Just (False, edited) + } +#if !MIN_VERSION_ghc(9,2,0) + -- avoid import A (foo,) + whenJust (lastMaybe deletedLies) removeTrailingCommaT + when (not (null lies) && null deletedLies) $ do + transferAnn llies edited id + addSimpleAnnT + edited + dp00 + [ (G AnnOpenP, DP (0, 1)) + , (G AnnCloseP, DP (0, 0)) + ] +#endif + pure lidecl' + where + deletedLies = +#if MIN_VERSION_ghc(9,2,0) + over _last removeTrailingComma $ +#endif + mapMaybe killLie lies + killLie :: LIE GhcPs -> Maybe (LIE GhcPs) + killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v +#if !MIN_VERSION_ghc(9,2,0) + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) +#else + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons)) +#endif + | nam == symbol = Nothing + | otherwise = + Just $ + L lieL $ + IEThingWith + xt + ty + wild + (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) +#if !MIN_VERSION_ghc(9,2,0) + (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) +#endif + killLie v = Just v diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -0,0 +1,141 @@ +-- | Position indexed streams of characters +module Development.IDE.Plugin.CodeAction.PositionIndexed + ( PositionIndexed + , PositionIndexedString + , indexedByPosition + , indexedByPositionStartingFrom + , extendAllToIncludeCommaIfPossible + , extendToIncludePreviousNewlineIfPossible + , mergeRanges + ) +where + +import Data.Char +import Data.List +import Language.LSP.Types (Position (Position), + Range (Range, _end, _start)) + +type PositionIndexed a = [(Position, a)] + +type PositionIndexedString = PositionIndexed Char + +-- | Add position indexing to a String. +-- +-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ +-- > [ ((0,0),'h') +-- > , ((0,1),'e') +-- > , ((0,2),'y') +-- > , ((0,3),'\n') +-- > , ((1,0),' ') +-- > , ((1,1),'h') +-- > , ((1,2),'o') +-- > ] +indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString +indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where + f (_, []) = Nothing + f (p@(Position l _), '\n' : rest) = + Just ((p, '\n'), (Position (l + 1) 0, rest)) + f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) + +-- | Add position indexing to a String. +-- +-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) +indexedByPosition :: String -> PositionIndexedString +indexedByPosition = indexedByPositionStartingFrom (Position 0 0) + +-- | Returns a tuple (before, contents, after) if the range is present. +-- The range is present only if both its start and end positions are present +unconsRange + :: Range + -> PositionIndexed a + -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) +unconsRange Range {..} indexedString + | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString + , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest + = Just (before, mid, after) + | otherwise + = Nothing + +-- | Strips out all the positions included in the range. +-- Returns 'Nothing' if the start or end of the range are not included in the input. +stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) +stripRange r s = case unconsRange r s of + Just (b, _, a) -> Just (b ++ a) + Nothing -> Nothing + +-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. +-- Assumes input ranges are sorted on the start positions. +mergeRanges :: [Range] -> [Range] +mergeRanges (r : r' : rest) + | + -- r' is contained in r + _end r > _end r' = mergeRanges (r : rest) + | + -- r and r' are overlapping + _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) + + | otherwise = r : mergeRanges (r' : rest) +mergeRanges other = other + +-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas +-- +-- @ +-- a, |b|, c ===> a|, b|, c +-- a, b, |c| ===> a, b|, c| +-- a, |b|, |c| ===> a|, b||, c| +-- @ +-- +-- If 'acceptNoComma' is enabled, additional ranges are returned +-- +-- @ +-- |a| ===> |a| +-- |a|, |b| ===> |a,| |b| +-- @ +extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] +extendAllToIncludeCommaIfPossible acceptNoComma indexedString = + mergeRanges . go indexedString . sortOn _start + where + go _ [] = [] + go input (r : rr) + | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r + , Just input' <- stripRange r' input + = r' : go input' rr + | otherwise + = go input rr + +extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] +extendToIncludeCommaIfPossible acceptNoComma indexedString range + | Just (before, _, after) <- unconsRange range indexedString + , after' <- dropWhile (isSpace . snd) after + , before' <- dropWhile (isSpace . snd) (reverse before) + = + -- a, |b|, c ===> a|, b|, c + [ range { _start = start' } | (start', ',') : _ <- [before'] ] + ++ + -- a, |b|, c ===> a, |b, |c + [ range { _end = end' } + | (_, ',') : rest <- [after'] + , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest + ] + ++ + ([range | acceptNoComma]) + | otherwise + = [range] + +extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range +extendToIncludePreviousNewlineIfPossible indexedString range + | Just (before, _, _) <- unconsRange range indexedString + , maybeFirstSpacePos <- lastSpacePos $ reverse before + = case maybeFirstSpacePos of + Nothing -> range + Just pos -> range { _start = pos } + | otherwise = range + where + lastSpacePos :: PositionIndexedString -> Maybe Position + lastSpacePos [] = Nothing + lastSpacePos ((pos, c):xs) = + if not $ isSpace c + then Nothing -- didn't find any space + else case xs of + (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) + _ -> Just pos diff --git a/src/Development/IDE/Plugin/CodeAction/Util.hs b/src/Development/IDE/Plugin/CodeAction/Util.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/Util.hs @@ -0,0 +1,56 @@ +module Development.IDE.Plugin.CodeAction.Util where + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Utils.Outputable +#else +import Development.IDE.GHC.Util +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat +#endif +import Data.Data (Data) +import qualified Data.Unique as U +import Debug.Trace +import Development.IDE.GHC.Compat.ExactPrint as GHC +import GHC.Stack +import System.Environment.Blank (getEnvDefault) +import System.IO.Unsafe +import Text.Printf +import Development.IDE.GHC.Dump (showAstDataHtml) +import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime, + utcTimeToPOSIXSeconds) +-------------------------------------------------------------------------------- +-- Tracing exactprint terms + +-- Should in `Development.IDE.GHC.Orphans`, +-- leave it here to prevent cyclic module dependency + +{-# NOINLINE timestamp #-} +timestamp :: POSIXTime +timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime + +debugAST :: Bool +debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" + +-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection +traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a +traceAst lbl x + | debugAST = trace doTrace x + | otherwise = x + where +#if MIN_VERSION_ghc(9,2,0) + renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} +#else + renderDump = showSDocUnsafe . ppr +#endif + htmlDump = showAstDataHtml x + doTrace = unsafePerformIO $ do + u <- U.newUnique + let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) + writeFile htmlDumpFileName $ renderDump htmlDump + return $ unlines + [prettyCallStack callStack ++ ":" +#if MIN_VERSION_ghc(9,2,0) + , exactPrint x +#endif + , "file://" ++ htmlDumpFileName] + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,3747 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Main + ( main + ) where + +import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Test +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Types +import Language.LSP.Test +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) +import qualified Language.LSP.Types as LSP +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as L +import System.Directory +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Text.Regex.TDFA ((=~)) + + +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) +import Test.Hls + +import qualified Development.IDE.Plugin.CodeAction as Refactor +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde + +main :: IO () +main = defaultTestRunner tests + +refactorPlugin :: [PluginDescriptor IdeState] +refactorPlugin = + [ Refactor.iePluginDescriptor mempty "ghcide-code-actions-imports-exports" + , Refactor.typeSigsPluginDescriptor mempty "ghcide-code-actions-type-signatures" + , Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings" + , Refactor.fillHolePluginDescriptor mempty "ghcide-code-actions-fill-holes" + , Refactor.extendImportPluginDescriptor mempty "ghcide-completions-1" + ] ++ GhcIde.descriptors mempty + +tests :: TestTree +tests = + testGroup "refactor" + [ initializeTests + , codeActionTests + , codeActionHelperFunctionTests + , completionTests + ] + +initializeTests = withResource acquire release tests + where + tests :: IO (ResponseMessage Initialize) -> TestTree + tests getInitializeResponse = testGroup "initialize response capabilities" + [ chk " code action" _codeActionProvider (Just $ InL True) + , che " execute command" _executeCommandProvider [extendImportCommandId] + ] + where + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands + + acquire :: IO (ResponseMessage Initialize) + acquire = run initializeResponse + + + release :: ResponseMessage Initialize -> IO () + release = const $ pure () + + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + +completionTests :: TestTree +completionTests = + testGroup "auto import snippets" + [ completionCommandTest + "show imports not in list - simple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum)", "f = joi"] + (Position 3 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - multi-line" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum)", "f = joi"] + (Position 4 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - names with _" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] + (Position 3 11) + "mapM_" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] + , completionCommandTest + "show imports not in list - initial empty list" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , testGroup "qualified imports" + [ completionCommandTest + "single" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] + (Position 3 22) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] + , completionCommandTest + "as" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , completionCommandTest + "multiple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] + (Position 4 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] + ] + , testGroup "Data constructor" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionCommandTest + "parent imported abs" + ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionNoCommandTest + "parent imported all" + ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "function from Prelude" + ["module A where", "import Data.Maybe ()", "Nothing"] + (Position 2 4) + "Nothing" + , completionCommandTest + "type operator parent" + ["module A where", "import Data.Type.Equality ()", "f = Ref"] + (Position 2 8) + "Refl" + ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] + ] + , testGroup "Record completion" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionCommandTest + "parent imported" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + (Position 2 10) + "FormatParse {" + ] + , testGroup "Package completion" + [ completionCommandTest + "import Data.Sequence" + ["module A where", "foo :: Seq"] + (Position 1 9) + "Seq" + ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] + + , completionCommandTest + "qualified import" + ["module A where", "foo :: Seq.Seq"] + (Position 1 13) + "Seq" + ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] + ] + ] + +completionCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + [T.Text] -> + TestTree +completionCommandTest name src pos wanted expected = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- skipManyTill anyMessage (getCompletions docId pos) + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem {..} -> do + c <- assertJust "Expected a command" _command + executeCommand c + if src /= expected + then do + void $ skipManyTill anyMessage loggingNotification + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) + liftIO $ modifiedCode @?= T.unlines expected + else do + expectMessages SWorkspaceApplyEdit 1 $ \edit -> + liftIO $ assertFailure $ "Expected no edit but got: " <> show edit + +completionNoCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + TestTree +completionNoCommandTest name src pos wanted = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command + + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ suggestImportDisambiguationTests + , insertImportTests + , extendImportTests + , renameActionTests + , typeWildCardActionTests + , removeImportTests + , suggestImportClassMethodTests + , suggestImportTests + , suggestHideShadowTests + , fixConstructorImportTests + , fixModuleImportTypoTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + , deleteUnusedDefinitionTests + , addInstanceConstraintTests + , addFunctionConstraintTests + , removeRedundantConstraintsTests + , addTypeAnnotationsToLiteralsTest + , exportUnusedTests + , addImplicitParamsConstraintTests + , removeExportTests + ] + +insertImportTests :: TestTree +insertImportTests = testGroup "insert import" + [ checkImport + "module where keyword lower in file no exports" + "WhereKeywordLowerInFileNoExports.hs" + "WhereKeywordLowerInFileNoExports.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with exports" + "WhereDeclLowerInFile.hs" + "WhereDeclLowerInFile.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with comments before it" + "WhereDeclLowerInFileWithCommentsBeforeIt.hs" + "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" + "import Data.Int" + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for " + ++ "case when shebang is not placed at top of file") + (checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" + (checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid") + , checkImport + "pragmas not at top with module declaration" + "PragmaNotAtTopWithModuleDecl.hs" + "PragmaNotAtTopWithModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "pragmas not at top with imports" + "PragmaNotAtTopWithImports.hs" + "PragmaNotAtTopWithImports.expected.hs" + "import Data.Monoid" + , checkImport + "above comment at top of module" + "CommentAtTop.hs" + "CommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multiple comments below" + "CommentAtTopMultipleComments.hs" + "CommentAtTopMultipleComments.expected.hs" + "import Data.Monoid" + , checkImport + "above curly brace comment" + "CommentCurlyBraceAtTop.hs" + "CommentCurlyBraceAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multi-line comment" + "MultiLineCommentAtTop.hs" + "MultiLineCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no module explicit exports" + "NoExplicitExportCommentAtTop.hs" + "NoExplicitExportCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above two-dash comment with no pipe" + "TwoDashOnlyComment.hs" + "TwoDashOnlyComment.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no (module .. where) decl" + "NoModuleDeclarationCommentAtTop.hs" + "NoModuleDeclarationCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top with no (module .. where) decl" + "NoModuleDeclaration.hs" + "NoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (data dec is)" + "DataAtTop.hs" + "DataAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (newtype is)" + "NewTypeAtTop.hs" + "NewTypeAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with no explicit module exports" + "NoExplicitExports.hs" + "NoExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "add to correctly placed exisiting import" + "ImportAtTop.hs" + "ImportAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "add to multiple correctly placed exisiting imports" + "MultipleImportsAtTop.hs" + "MultipleImportsAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top of module" + "LangPragmaModuleAtTop.hs" + "LangPragmaModuleAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma and explicit module exports" + "LangPragmaModuleWithComment.hs" + "LangPragmaModuleWithComment.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top and no module declaration" + "LanguagePragmaAtTop.hs" + "LanguagePragmaAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with multiple lang pragmas and no module declaration" + "MultipleLanguagePragmasNoModuleDeclaration.hs" + "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs" + "LanguagePragmasThenShebangs.hs" + "LanguagePragmasThenShebangs.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs but no comment at top" + "PragmasAndShebangsNoComment.hs" + "PragmasAndShebangsNoComment.expected.hs" + "import Data.Monoid" + , checkImport + "module decl no exports under pragmas and shebangs" + "PragmasShebangsAndModuleDecl.hs" + "PragmasShebangsAndModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "module decl with explicit import under pragmas and shebangs" + "PragmasShebangsModuleExplicitExports.hs" + "PragmasShebangsModuleExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "module decl and multiple imports" + "ModuleDeclAndImports.hs" + "ModuleDeclAndImports.expected.hs" + "import Data.Monoid" + ] + +checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree +checkImport testComment originalPath expectedPath action = + testSessionWithExtraFiles "import-placement" testComment $ \dir -> + check (dir originalPath) (dir expectedPath) action + where + check :: FilePath -> FilePath -> T.Text -> Session () + check originalPath expectedPath action = do + oSrc <- liftIO $ readFileUtf8 originalPath + eSrc <- liftIO $ readFileUtf8 expectedPath + originalDoc <- createDoc originalPath "haskell" oSrc + _ <- waitForDiagnostics + shouldBeDoc <- createDoc expectedPath "haskell" eSrc + actionsOrCommands <- getAllCodeActions originalDoc + chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands + executeCodeAction chosenAction + originalDocAfterAction <- documentContents originalDoc + shouldBeDocContents <- documentContents shouldBeDoc + liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction + +renameActionTests :: TestTree +renameActionTests = testGroup "rename actions" + [ testSession "change to local variable name" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argNme" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argName" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "change to name of imported function" $ do + let content = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybToList" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybeToList" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "suggest multiple local variable names" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Char -> Char -> Char -> Char" + , "foo argument1 argument2 argument3 = argumentX" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) + ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] + return() + , testSession "change infix function" $ do + let content = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monnus` y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) + [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + executeCodeAction fixTypo + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monus` y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +typeWildCardActionTests :: TestTree +typeWildCardActionTests = testGroup "type wildcard actions" + [ testUseTypeSignature "global signature" + [ "func :: _" + , "func x = x" + ] + [ "func :: p -> p" + , "func x = x" + ] + , testUseTypeSignature "local signature" + [ "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + [ "func :: Int -> Int" + , "func x =" + , " let y :: Int" + , " y = x * 2" + , " in y" + ] + , testUseTypeSignature "multi-line message 1" + [ "func :: _" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "type in parentheses" + [ "func :: a -> _" + , "func x = (x, const x)" + ] + [ "func :: a -> (a, b -> a)" + , "func x = (x, const x)" + ] + , testUseTypeSignature "type in brackets" + [ "func :: _ -> Maybe a" + , "func xs = head xs" + ] + [ "func :: [Maybe a] -> Maybe a" + , "func xs = head xs" + ] + , testUseTypeSignature "unit type" + [ "func :: IO _" + , "func = putChar 'H'" + ] + [ "func :: IO ()" + , "func = putChar 'H'" + ] + , testUseTypeSignature "no spaces around '::'" + [ "func::_" + , "func x y = x + y" + ] + [ "func::Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testGroup "add parens if hole is part of bigger type" + [ testUseTypeSignature "subtype 1" + [ "func :: _ -> Integer -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 2" + [ "func :: Integer -> _ -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 3" + [ "func :: Integer -> Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 4" + [ "func :: Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> (Integer -> Integer)" + , "func x y = x + y" + ] + ] + ] + where + -- | Test session of given name, checking action "Use type signature..." + -- on a test file with given content and comparing to expected result. + testUseTypeSignature name textIn textOut = testSession name $ do + let fileStart = "module Testing where" + content = T.unlines $ fileStart : textIn + expectedContentAfterAction = T.unlines $ fileStart : textOut + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + liftIO $ expectedContentAfterAction @=? contentAfterAction + +{-# HLINT ignore "Use nubOrd" #-} +removeImportTests :: TestTree +removeImportTests = testGroup "remove import actions" + [ testSession "redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "qualified redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "stuffA = False" + , "stuffB :: Integer" + , "stuffB = 123" + , "stuffC = ()" + , "_stuffD = '_'" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding - unicode regression " $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "ε :: Double" + , "ε = 0.5" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), ε)" + , "a = A" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove ε from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..))" + , "a = A" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant operator" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "a !! _b = a" + , "a _b = a" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A ((), stuffB, (!!))" + , "main = print A.stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove !!, from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print A.stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant all import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), stuffB)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant constructor import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data D = A | B" + , "data E = F" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(A,B), E(F))" + , "main = B" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A, E, F from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(B))" + , "main = B" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "import containing the identifier Strict" $ do + let contentA = T.unlines + [ "module Strict where" + ] + _docA <- createDoc "Strict.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import Strict" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove all" $ do + let content = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix, (&))" + , "import qualified Data.Functor.Const" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL, InR))" + , "import qualified Data.Kind as K (Constraint, Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + doc <- createDoc "ModuleC.hs" "haskell" content + _ <- waitForDiagnostics + [_, _, _, _, InR action@CodeAction { _title = actionTitle }] + <- nub <$> getAllCodeActions doc + liftIO $ "Remove all redundant imports" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix)" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL))" + , "import qualified Data.Kind as K (Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove unused operators whose name ends with '.'" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "(@.) = 0 -- Must have an operator whose name ends with '.'" + , "a = 1 -- .. but also something else" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a, (@.))" + , "x = a -- Must use something from module A, but not (@.)" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove @. from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a)" + , "x = a -- Must use something from module A, but not (@.)" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testGroup "with checkAll" $ tests True + , testGroup "without checkAll" $ tests False + ] + where + tests overrideCheckProject = + [ testSession "extend all constructors for record field" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = B { a :: Int }" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A(B))" + , "f = a" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(a) to the import list of ModuleA" + , "Add a to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(..))" + , "f = a" + ]) + , testSession "extend all constructors with sibling" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors with comment" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors for type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add (:~:)(..) to the import list of Data.Type.Equality" + , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (..))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , testSession "extend all constructors for class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(..) to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(..))" + , "b = m2" + ]) + , testSession "extend single line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, stuffA)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add (.*) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, (.*))" + , "main = print (stuffB .* stuffB)" + ]) + , testSession "extend single line import with infix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList)" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + (Range (Position 2 5) (Position 2 6)) + [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" + , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" + ] + (T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + , testSession "extend single line import with prefix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes)" + , "x = Just 10" + ]) + (Range (Position 3 5) (Position 2 6)) + [ "Add Maybe(Just) to the import list of Data.Maybe" + , "Add Maybe(..) to the import list of Data.Maybe" + ] + (T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes, Maybe (Just))" + , "x = Just 10" + ]) + , testSession "extend single line import with type" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "type A = Double" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + , "b :: A" + , "b = 0" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = 0" + ]) + , testSession "extend single line import with constructor" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with constructor (with comments)" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A ({-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor{-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with mixed constructors" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = ConstructorFoo | ConstructorBar" + , "a = 1" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(ConstructorFoo) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + , testSession "extend single line qualified import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB, stuffA)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA" + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend multi line import with trailing comma" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB," + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA," + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with method within class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1, m2))" + , "b = m2" + ]) + , testSession "extend single line import with method without class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add m2 to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1), m2)" + , "b = m2" + ]) + , testSession "extend import list with multiple choices" $ template + [("ModuleA.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleA (bar) where" + , "bar = 10" + ]), + ("ModuleB.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleB (bar) where" + , "bar = 10" + ])] + ("ModuleC.hs", T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA ()" + , "foo = bar" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add bar to the import list of ModuleA", + "Add bar to the import list of ModuleB"] + (T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA (bar)" + , "foo = bar" + ]) + , testSession "extend import list with constructor of type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" + , "Add (:~:)(..) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (Refl))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , expectFailBecause "importing pattern synonyms is unsupported" + $ testSession "extend import list with pattern synonym" $ template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ]) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ]) + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type constructor name same as data constructor name" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "newtype Foo = Foo Int" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = Foo 1" + ]) + (Range (Position 3 4) (Position 3 6)) + ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo (Foo))" + , "f :: Foo" + , "f = Foo 1" + ]) + , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo = Foo" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA()" + , "f :: Foo" + , "f = undefined" + ]) + (Range (Position 2 4) (Position 2 6)) + ["Add Foo to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = undefined" + ]) + ] + where + codeActionTitle CodeAction{_title=x} = x + + template setUpModules moduleUnderTest range expectedTitles expectedContentB = do + configureCheckProject overrideCheckProject + + mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + actionsOrCommands <- getCodeActions docB range + let codeActions = + filter + (T.isPrefixOf "Add" . codeActionTitle) + [ca | InR ca <- actionsOrCommands] + actualTitles = codeActionTitle <$> codeActions + -- Note that we are not testing the order of the actions, as the + -- order of the expected actions indicates which one we'll execute + -- in this test, i.e., the first one. + liftIO $ sort expectedTitles @=? sort actualTitles + + -- Execute the action with the same title as the first expected one. + -- Since we tested that both lists have the same elements (possibly + -- in a different order), this search cannot fail. + let firstTitle:_ = expectedTitles + action = fromJust $ + find ((firstTitle ==) . codeActionTitle) codeActions + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +fixModuleImportTypoTests :: TestTree +fixModuleImportTypoTests = testGroup "fix module import typo" + [ testSession "works when single module suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.Cha" + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ <- getCodeActions doc (R 0 0 0 10) + liftIO $ actionTitle @?= "replace with Data.Char" + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Char" + , testSession "works when multiple modules suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.I" + _ <- waitForDiagnostics + actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) + let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] + liftIO $ actionTitles @?= [ "replace with Data.Eq" + , "replace with Data.Int" + , "replace with Data.Ix" + ] + let InR replaceWithDataEq : _ = actions + executeCodeAction replaceWithDataEq + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Eq" + ] + +suggestImportClassMethodTests :: TestTree +suggestImportClassMethodTests = + testGroup + "suggest import class methods" + [ testGroup + "new" + [ testSession "via parent" $ + template' + "import Data.Semigroup (Semigroup(stimes))" + (Range (Position 4 2) (Position 4 8)), + testSession "top level" $ + template' + "import Data.Semigroup (stimes)" + (Range (Position 4 2) (Position 4 8)), + testSession "all" $ + template' + "import Data.Semigroup" + (Range (Position 4 2) (Position 4 8)) + ], + testGroup + "extend" + [ testSession "via parent" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add Semigroup(stimes) to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (Semigroup (stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add stimes to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ] + ] + ] + where + decls = + [ "data X = X", + "instance Semigroup X where", + " (<>) _ _ = X", + " stimes _ _ = X" + ] + template beforeContent range executeTitle expectedContent = do + doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) + _ <- waitForDiagnostics + waitForProgressDone + actions <- getCodeActions doc range + let actions' = [x | InR x <- actions] + titles = [_title | CodeAction {_title} <- actions'] + liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles + executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' + content <- documentContents doc + liftIO $ T.unlines (expectedContent <> decls) @=? content + template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle] + +suggestImportTests :: TestTree +suggestImportTests = testGroup "suggest import actions" + [ testGroup "Dont want suggestion" + [ -- extend import + test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + -- data constructor + , test False [] "f = First" [] "import Data.Monoid (First)" + -- internal module + , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" + -- package not in scope + , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + -- don't omit the parent data type of a constructor + , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" + -- don't suggest data constructor when we only need the type + , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" + -- don't suggest all data constructors for the data type + , test False [] "f :: Bar" [] "import Bar (Bar(..))" + ] + , testGroup "want suggestion" + [ wantWait [] "f = foo" [] "import Foo (foo)" + , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" + , wantWait [] "f :: Bar" [] "import Bar (Bar)" + , wantWait [] "f = Bar" [] "import Bar (Bar(..))" + , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" + , test True [] "f = First" [] "import Data.Monoid (First(First))" + , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" + , test True [] "f = Version" [] "import Data.Version (Version(Version))" + , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" + , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" + , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = empty" [] "import Control.Applicative (empty)" + , test True [] "f = empty" [] "import Control.Applicative" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" + , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" + , test True [] "f = pack" [] "import Data.Text (pack)" + , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" + , test True [] "f = [] & id" [] "import Data.Function ((&))" + , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" + , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" + , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" + , test True + ["qualified Data.Text as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + , "qualified Data.Functor as T" + , "qualified Data.Data as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" + ] + , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + ] + where + test = test' False + wantWait = test' True True + + test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do + configureCheckProject waitForCheckProject + let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other + after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _ <- waitForDiagnostics + -- there isn't a good way to wait until the whole project is checked atm + when waitForCheckProject $ liftIO $ sleep 0.5 + let defLine = fromIntegral $ length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + if wanted + then do + action <- liftIO $ pickActionWithTitle newImp actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + else + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] + +suggestImportDisambiguationTests :: TestTree +suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" + [ testGroup "Hiding strategy works" + [ testGroup "fromList" + [ testCase "AVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use AVec for fromList, hiding other imports" + "HideFunction.expected.fromList.A.hs" + , testCase "BVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use BVec for fromList, hiding other imports" + "HideFunction.expected.fromList.B.hs" + ] + , testGroup "(++)" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use EVec for ++, hiding other imports" + "HideFunction.expected.append.E.hs" + , testCase "Hide functions without local" $ + compareTwo + "HideFunctionWithoutLocal.hs" [(8,8)] + "Use local definition for ++, hiding other imports" + "HideFunctionWithoutLocal.expected.hs" + , testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use Prelude for ++, hiding other imports" + "HideFunction.expected.append.Prelude.hs" + , testCase "Prelude and local definition, infix" $ + compareTwo + "HidePreludeLocalInfix.hs" [(2,19)] + "Use local definition for ++, hiding other imports" + "HidePreludeLocalInfix.expected.hs" + , testCase "AVec, indented" $ + compareTwo "HidePreludeIndented.hs" [(3,8)] + "Use AVec for ++, hiding other imports" + "HidePreludeIndented.expected.hs" + + ] + , testGroup "Vec (type)" + [ testCase "AVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use AVec for Vec, hiding other imports" + "HideType.expected.A.hs" + , testCase "EVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use EVec for Vec, hiding other imports" + "HideType.expected.E.hs" + ] + ] + , testGroup "Qualify strategy" + [ testCase "won't suggest full name for qualified module" $ + withHideFunction [(8,9),(10,8)] $ \_ _ actions -> do + liftIO $ + assertBool "EVec.fromList must not be suggested" $ + "Replace with qualified: EVec.fromList" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + liftIO $ + assertBool "EVec.++ must not be suggested" $ + "Replace with qualified: EVec.++" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + , testGroup "fromList" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: E.fromList" + "HideFunction.expected.qualified.fromList.E.hs" + , testCase "Hide DuplicateRecordFields" $ + compareTwo + "HideQualifyDuplicateRecordFields.hs" [(9, 9)] + "Replace with qualified: AVec.fromList" + "HideQualifyDuplicateRecordFields.expected.hs" + , testCase "Duplicate record fields should not be imported" $ do + withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $ + \_ _ actions -> do + liftIO $ + assertBool "Hidings should not be presented while DuplicateRecordFields exists" $ + all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports" + | InR CodeAction { _title = actionTitle } <- actions] + withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $ + \_ _ actions -> do + liftIO $ + assertBool "ambiguity from DuplicateRecordFields should not be imported" $ + null actions + ] + , testGroup "(++)" + [ testCase "Prelude, parensed" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: Prelude.++" + "HideFunction.expected.qualified.append.Prelude.hs" + , testCase "Prelude, infix" $ + compareTwo + "HideQualifyInfix.hs" [(4,19)] + "Replace with qualified: Prelude.++" + "HideQualifyInfix.expected.hs" + , testCase "Prelude, left section" $ + compareTwo + "HideQualifySectionLeft.hs" [(4,15)] + "Replace with qualified: Prelude.++" + "HideQualifySectionLeft.expected.hs" + , testCase "Prelude, right section" $ + compareTwo + "HideQualifySectionRight.hs" [(4,18)] + "Replace with qualified: Prelude.++" + "HideQualifySectionRight.expected.hs" + ] + ] + ] + where + compareTwo original locs cmd expected = + withTarget original locs $ \dir doc actions -> do + expected <- liftIO $ + readFileUtf8 (dir expected) + action <- liftIO $ pickActionWithTitle cmd actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction + compareHideFunctionTo = compareTwo "HideFunction.hs" + auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] + withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do + doc <- openDoc file "haskell" + waitForProgressDone + void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] + actions <- getAllCodeActions doc + k dir doc actions + withHideFunction = withTarget ("HideFunction" <.> "hs") + +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- liftIO $ pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + waitForProgressDone + cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + +insertNewDefinitionTests :: TestTree +insertNewDefinitionTests = testGroup "insert new definition actions" + [ testSession "insert new function definition" $ do + let txtB = + ["foo True = select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 0 0 0 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "define a hole" $ do + let txtB = + ["foo True = _select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 0 0 0 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines ( + ["foo True = select [True]" + , "" + ,"foo False = False" + , "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "insert new function definition - Haddock comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - normal comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + ] + + +deleteUnusedDefinitionTests :: TestTree +deleteUnusedDefinitionTests = testGroup "delete unused definition action" + [ testSession "delete unused top level binding" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "f :: Int -> Int" + , "f 1 = let a = 1" + , " in a" + , "f 2 = 2" + , "" + , "some = ()" + ]) + (4, 0) + "Delete ‘f’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + + , testSession "delete unused top level binding defined in infix form" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "myPlus :: Int -> Int -> Int" + , "a `myPlus` b = a + b" + , "" + , "some = ()" + ]) + (4, 2) + "Delete ‘myPlus’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + , testSession "delete unused binding in where clause" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , " h :: Int" + , " h = 4" + , "" + ]) + (10, 4) + "Delete ‘h’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , "" + ]) + , testSession "delete unused binding with multi-oneline signatures front" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (4, 0) + "Delete ‘a’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "b, c :: Int" + , "b = 4" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures mid" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (5, 0) + "Delete ‘b’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, c :: Int" + , "a = 3" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures end" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (6, 0) + "Delete ‘c’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b :: Int" + , "a = 3" + , "b = 4" + ]) + ] + where + testFor source pos expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] + + (action, title) <- extractCodeAction docId "Delete" pos + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix (l, c) = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix] + return (action, actionTitle) + +addTypeAnnotationsToLiteralsTest :: TestTree +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" + [ + testSession "add default type to satisfy one constraint" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = 1" + ]) + [ (DsWarning, (3, 4), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘1’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = (1 :: Integer)" + ]) + + , testSession "add default type to satisfy one constraint in nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = 3" + , " in x" + ]) + [ (DsWarning, (4, 12), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘3’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = (3 :: Integer)" + , " in x" + ]) + , testSession "add default type to satisfy one constraint in more nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = 5 in y" + , " in x" + ]) + [ (DsWarning, (4, 20), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘5’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = (5 :: Integer) in y" + , " in x" + ]) + , testSession "add default type to satisfy one constraint with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq \"debug\" traceShow \"debug\"" + ]) + [ (DsWarning, (6, 8), "Defaulting the following constraint") + , (DsWarning, (6, 16), "Defaulting the following constraint") + ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" + ]) + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow \"debug\" a" + ]) + [ (DsWarning, (6, 6), "Defaulting the following constraint") ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" + ]) + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" + ]) + [ (DsWarning, (6, 54), "Defaulting the following constraint") ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" + ]) + ] + where + testFor source diag expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", diag) ] + + let cursors = map snd3 diag + (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors) + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix (l,c) (l', c')= do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix] + return (action, actionTitle) + + +fixConstructorImportTests :: TestTree +fixConstructorImportTests = testGroup "fix import actions" + [ testSession "fix constructor import" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Constructor)" + ]) + (Range (Position 1 10) (Position 1 11)) + "Fix import of A(Constructor)" + (T.unlines + [ "module ModuleB where" + , "import ModuleA(A(Constructor))" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _diags <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +importRenameActionTests :: TestTree +importRenameActionTests = testGroup "import rename actions" + [ testSession "Data.Mape -> Data.Map" $ check "Map" + , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where + check modname = do + let content = T.unlines + [ "module Testing where" + , "import Data.Mape" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16)) + let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + executeCodeAction changeToMap + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data." <> modname + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + +fillTypedHoleTests :: TestTree +fillTypedHoleTests = let + + sourceCode :: T.Text -> T.Text -> T.Text -> T.Text + sourceCode a b c = T.unlines + [ "module Testing where" + , "" + , "globalConvert :: Int -> String" + , "globalConvert = undefined" + , "" + , "globalInt :: Int" + , "globalInt = 3" + , "" + , "bar :: Int -> Int -> String" + , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" + , " localConvert = (flip replicate) 'x'" + , "" + , "foo :: () -> Int -> String" + , "foo = undefined" + + ] + + check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree + check actionTitle + oldA oldB oldC + newA newB newC = testSession (T.unpack actionTitle) $ do + let originalCode = sourceCode oldA oldB oldC + let expectedCode = sourceCode newA newB newC + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "fill typed holes" + [ check "replace _ with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace _ with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + + , check "replace _convertme with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" + + , check "replace _b with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace _c with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + + , check "replace _c with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" + , check "replace _ with foo _" + "_" "n" "n" + "(foo _)" "n" "n" + , testSession "replace _toException with E.toException" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "import qualified Control.Exception as E" + , "ioToSome :: E.IOException -> E.SomeException" + , "ioToSome = " <> x ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) + chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "E.toException" @=? modifiedCode + , testSession "filling infix type hole uses prefix notation" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "data A = A" + , "foo :: A -> A -> A" + , "foo A A = A" + , "test :: A -> A -> A" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "`foo`" @=? modifiedCode + , testSession "postfix hole uses postfix notation of infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = " <> x <> " a1 a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "(+)" @=? modifiedCode + , testSession "filling infix type hole uses infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "+" @=? modifiedCode + ] + +addInstanceConstraintTests :: TestTree +addInstanceConstraintTests = let + missingConstraintSourceCode :: Maybe T.Text -> T.Text + missingConstraintSourceCode mConstraint = + let constraint = maybe "" (<> " => ") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Wrap a = Wrap a" + , "" + , "instance " <> constraint <> "Eq (Wrap a) where" + , " (Wrap x) == (Wrap y) = x == y" + ] + + incompleteConstraintSourceCode :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode mConstraint = + let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "instance " <> constraint <> " => Eq (Pair a b) where" + , " (Pair x y) == (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode2 mConstraint = + let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "instance " <> constraint <> " => Eq (Three a b c) where" + , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "add instance constraint" + [ check + "Add `Eq a` to the context of the instance declaration" + (missingConstraintSourceCode Nothing) + (missingConstraintSourceCode $ Just "Eq a") + , check + "Add `Eq b` to the context of the instance declaration" + (incompleteConstraintSourceCode Nothing) + (incompleteConstraintSourceCode $ Just "Eq b") + , check + "Add `Eq c` to the context of the instance declaration" + (incompleteConstraintSourceCode2 Nothing) + (incompleteConstraintSourceCode2 $ Just "Eq c") + ] + +addFunctionConstraintTests :: TestTree +addFunctionConstraintTests = let + missingConstraintSourceCode :: T.Text -> T.Text + missingConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "eq :: " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + missingConstraintWithForAllSourceCode :: T.Text -> T.Text + missingConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "eq :: forall a. " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text + incompleteConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode :: T.Text -> T.Text + incompleteConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: T.Text -> T.Text + incompleteConstraintSourceCode2 constraint = + T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" + , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text + incompleteConstraintSourceCodeWithExtraCharsInContext constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = + T.unlines + [ "module Testing where" + , "data Pair a b = Pair a b" + , "eq " + , " :: (" <> constraint <> ")" + , " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] + + in testGroup "add function constraint" + [ checkCodeAction + "no preexisting constraint" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintSourceCode "") + (missingConstraintSourceCode "Eq a => ") + , checkCodeAction + "no preexisting constraint, with forall" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintWithForAllSourceCode "") + (missingConstraintWithForAllSourceCode "Eq a => ") + , checkCodeAction + "preexisting constraint, no parenthesis" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode "Eq a") + (incompleteConstraintSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraints in parenthesis" + "Add `Eq c` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode2 "(Eq a, Eq b)") + (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") + , checkCodeAction + "preexisting constraints with forall" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintWithForAllSourceCode "Eq a") + (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraint, with extra spaces in context" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") + , checkCodeAction + "preexisting constraint, with newlines in type signature" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") + ] + +checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] + +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + headerExt :: [T.Text] -> [T.Text] + headerExt exts = + redunt : extTxt ++ ["module Testing where"] + where + redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" + extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts + + redundantConstraintsCode :: Maybe T.Text -> T.Text + redundantConstraintsCode mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> "a -> a" + , "foo = id" + ] + + redundantMixedConstraintsCode :: Maybe T.Text -> T.Text + redundantMixedConstraintsCode mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureSpaces :: Maybe T.Text -> T.Text + typeSignatureSpaces mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + redundantConstraintsForall :: Maybe T.Text -> T.Text + redundantConstraintsForall mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ headerExt ["RankNTypes"] <> + [ "foo :: forall a. " <> constraint <> "a -> a" + , "foo = id" + ] + + typeSignatureDo :: Maybe T.Text -> T.Text + typeSignatureDo mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> IO ()" + , "f n = do" + , " let foo :: " <> constraint <> "a -> IO ()" + , " foo _ = return ()" + , " r n" + ] + + typeSignatureNested :: Maybe T.Text -> T.Text + typeSignatureNested mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: " <> constraint <> "a -> ()" + , " g _ = ()" + ] + + typeSignatureNested' :: Maybe T.Text -> T.Text + typeSignatureNested' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f =" + , " let" + , " g :: Int -> ()" + , " g = h" + , " where" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in g" + ] + + typeSignatureNested'' :: Maybe T.Text -> T.Text + typeSignatureNested'' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: Int -> ()" + , " g = " + , " let" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in h" + ] + + typeSignatureLined1 = T.unlines $ header <> + [ "foo :: Eq a =>" + , " a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined2 = T.unlines $ header <> + [ "foo :: (Eq a, Show a)" + , " => a -> Bool" + , "foo _ = True" + ] + + typeSignatureOneLine = T.unlines $ header <> + [ "foo :: a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined3 = T.unlines $ header <> + [ "foo :: ( Eq a" + , " , Show a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + typeSignatureLined3' = T.unlines $ header <> + [ "foo :: ( Eq a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "remove redundant function constraints" + [ check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "Eq a") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "(Eq a, Monoid a)") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (redundantMixedConstraintsCode $ Just "Monoid a, Show a") + (redundantMixedConstraintsCode Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `g`" + (typeSignatureNested $ Just "Eq a") + (typeSignatureNested Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested' $ Just "Eq a") + (typeSignatureNested' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested'' $ Just "Eq a") + (typeSignatureNested'' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsForall $ Just "Eq a") + (redundantConstraintsForall Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (typeSignatureDo $ Just "Eq a") + (typeSignatureDo Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (typeSignatureSpaces $ Just "Monoid a, Show a") + (typeSignatureSpaces Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + typeSignatureLined1 + typeSignatureOneLine + , check + "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" + typeSignatureLined2 + typeSignatureOneLine + , check + "Remove redundant constraint `Show a` from the context of the type signature for `foo`" + typeSignatureLined3 + typeSignatureLined3' + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" + , "module Sigs where" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before def = T.unlines $ header ++ [def] + after' def sig = T.unlines $ header ++ [sig, def] + + def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ "abc = True" >:: "abc :: Bool" + , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" + , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" + , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" + , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" + , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" + , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + ] + +exportUnusedTests :: TestTree +exportUnusedTests = testGroup "export unused actions" + [ testGroup "don't want suggestion" + [ testSession "implicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wmissing-signatures #-}" + , "module A where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + Nothing -- codeaction should not be available + , testSession "not top-level" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (foo,bar) where" + , "foo = ()" + , " where bar = ()" + , "bar = ()"]) + (R 2 0 2 11) + "Export ‘bar’" + Nothing + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type is exported but not the constructor of same name" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "data Foo = Foo"]) + (R 2 0 2 8) + "Export ‘Foo’" + Nothing -- codeaction should not be available + , testSession "unused data field" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(Foo)) where" + , "data Foo = Foo {foo :: ()}"]) + (R 2 0 2 20) + "Export ‘foo’" + Nothing -- codeaction should not be available + ] + , testGroup "want suggestion" + [ testSession "empty exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , ") where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , "foo) where" + , "foo = id"]) + , testSession "single line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo) where" + , "foo = id" + , "bar = foo"]) + (R 3 0 3 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo, bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "multi line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo) where" + , "foo = id" + , "bar = foo"]) + (R 5 0 5 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo, bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "export list ends in comma" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " ) where" + , "foo = id" + , "bar = foo"]) + (R 5 0 5 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "style of multiple exports is preserved 1" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + (R 7 0 7 3) + "Export ‘baz’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + , testSession "style of multiple exports is preserved 2" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + (R 7 0 7 3) + "Export ‘baz’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar," + , " baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + , testSession "style of multiple exports is preserved and selects smallest export separator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ]) + (R 10 0 10 4) + "Export ‘quux’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " , quux" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ]) + , testSession "unused pattern synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern Foo a <- (a, _)"]) + (R 3 0 3 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern Foo) where" + , "pattern Foo a <- (a, _)"]) + , testSession "unused data type" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "data Foo = Foo"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "data Foo = Foo"]) + , testSession "unused newtype" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "newtype Foo = Foo ()"]) + (R 2 0 2 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "newtype Foo = Foo ()"]) + , testSession "unused type synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "type Foo = ()"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "type Foo = ()"]) + , testSession "unused type family" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A () where" + , "type family Foo p"]) + (R 3 0 3 15) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A (Foo) where" + , "type family Foo p"]) + , testSession "unused typeclass" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "class Foo a"]) + (R 2 0 2 8) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "class Foo a"]) + , testSession "infix" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "a `f` b = ()"]) + (R 2 0 2 11) + "Export ‘f’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (f) where" + , "a `f` b = ()"]) + , testSession "function operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "(<|) = ($)"]) + (R 2 0 2 9) + "Export ‘<|’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A ((<|)) where" + , "(<|) = ($)"]) + , testSession "type synonym operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type (:<) = ()"]) + (R 3 0 3 13) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A ((:<)) where" + , "type (:<) = ()"]) + , testSession "type family operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type family (:<)"]) + (R 4 0 4 15) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)) where" + , "type family (:<)"]) + , testSession "typeclass operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "class (:<) a"]) + (R 3 0 3 11) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "class (:<) a"]) + , testSession "newtype operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "newtype (:<) = Foo ()"]) + (R 3 0 3 20) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "newtype (:<) = Foo ()"]) + , testSession "data type operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "data (:<) = Foo ()"]) + (R 3 0 3 17) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "data (:<) = Foo ()"]) + ] + ] + where + template doc range = exportTemplate (Just range) doc + +exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () +exportTemplate mRange initialContent expectedAction expectedContents = do + doc <- createDoc "A.hs" "haskell" initialContent + _ <- waitForDiagnostics + actions <- case mRange of + Nothing -> getAllCodeActions doc + Just range -> getCodeActions doc range + case expectedContents of + Just content -> do + action <- liftIO $ pickActionWithTitle expectedAction actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ content @=? contentAfterAction + Nothing -> + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +removeExportTests :: TestTree +removeExportTests = testGroup "remove export actions" + [ testSession "single export" $ template + (T.unlines + [ "module A ( a ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "ending comma" $ template + (T.unlines + [ "module A ( a, ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "multiple exports" $ template + (T.unlines + [ "module A (a , c, b ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + "Remove ‘b’ from export" + (Just $ T.unlines + [ "module A (a , c ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + , testSession "not in scope constructor" $ template + (T.unlines + [ "module A (A (X,Y,Z,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ]) + "Remove ‘Z’ from export" + (Just $ T.unlines + [ "module A (A (X,Y,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()"]) + , testSession "multiline export" $ template + (T.unlines + [ "module A (a" + , " , b" + , " , (:*:)" + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove ‘:*:’ from export" + (Just $ T.unlines + [ "module A (a" + , " , b" + , " " + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + , testSession "qualified re-export" $ template + (T.unlines + [ "module A (M.x,a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.x’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "qualified re-export ending in '.'" $ template + (T.unlines + [ "module A ((M.@.),a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.@.’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "export module" $ template + (T.unlines + [ "module A (module B) where" + , "a :: ()" + , "a = ()"]) + "Remove ‘module B’ from export" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "duplicate module export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L,module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + "Remove ‘Module L’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports single" $ template + (T.unlines + [ "module A (x) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports two" $ template + (T.unlines + [ "module A (x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports three" $ template + (T.unlines + [ "module A (a,x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (a) where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports composite" $ template + (T.unlines + [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (b, a, A(X, Y,getV), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + ] + where + template = exportTemplate Nothing + + +codeActionHelperFunctionTests :: TestTree +codeActionHelperFunctionTests = testGroup "code action helpers" + [ + extendImportTestsRegEx + ] + +extendImportTestsRegEx :: TestTree +extendImportTestsRegEx = testGroup "regex parsing" + [ + testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing + , testCase "parse malformed import list" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" + Nothing + , testCase "parse multiple imports" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" + $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) + ] + where + template message expected = do + liftIO $ matchRegExMultipleImports message @=? expected + +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction +pickActionWithTitle title actions = do + assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) + return $ head matches + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions = findCodeActions' (==) "is not a superset of" + +findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" + +findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions' op errMsg doc range expectedTitles = do + actions <- getCodeActions doc range + let matches = sequence + [ listToMaybe + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , expectedTitle `op` actionTitle] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + ++ " " <> errMsg <> " " + ++ show expectedTitles + liftIO $ case matches of + Nothing -> assertFailure msg + Just _ -> pure () + return (fromJust matches) + +findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction +findCodeAction doc range t = head <$> findCodeActions doc range [t] + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: HasCallStack => FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +runWithExtraFiles :: HasCallStack => FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: HasCallStack => FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runSessionWithServer' refactorPlugin def def lspTestCaps dir + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +ignoreForGHC92 :: String -> TestTree -> TestTree +ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92]) + +data BrokenTarget = + BrokenSpecific OS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS OS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + + +data IssueSolution = Broken | Ignore deriving (Show) + +-- | Assert that a value is not 'Nothing', and extract the value. +assertJust :: MonadIO m => String -> Maybe a -> m a +assertJust s = \case + Nothing -> liftIO $ assertFailure s + Just x -> pure x + +-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String +listOfChar :: T.Text +listOfChar | ghcVersion >= GHC90 = "String" + | otherwise = "[Char]" + diff --git a/test/data/hiding/AVec.hs b/test/data/hiding/AVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/AVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/test/data/hiding/BVec.hs b/test/data/hiding/BVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/BVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/test/data/hiding/CVec.hs b/test/data/hiding/CVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/CVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/test/data/hiding/DVec.hs b/test/data/hiding/DVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/DVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/test/data/hiding/EVec.hs b/test/data/hiding/EVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/EVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/test/data/hiding/FVec.hs b/test/data/hiding/FVec.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/FVec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module FVec (RecA(..), RecB(..)) where + +data Vec a + +newtype RecA a = RecA { fromList :: [a] -> Vec a } + +newtype RecB a = RecB { fromList :: [a] -> Vec a } diff --git a/test/data/hiding/HideFunction.expected.append.E.hs b/test/data/hiding/HideFunction.expected.append.E.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.append.E.hs @@ -0,0 +1,12 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E +import Prelude hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.append.Prelude.hs b/test/data/hiding/HideFunction.expected.append.Prelude.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.append.Prelude.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.fromList.A.hs b/test/data/hiding/HideFunction.expected.fromList.A.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.fromList.A.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec ( (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.fromList.B.hs b/test/data/hiding/HideFunction.expected.fromList.B.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.fromList.B.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec () +import BVec (fromList, (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs b/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (Prelude.++) diff --git a/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs b/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = E.fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunction.hs b/test/data/hiding/HideFunction.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunction.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (++) diff --git a/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/test/data/hiding/HideFunctionWithoutLocal.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunctionWithoutLocal.expected.hs @@ -0,0 +1,14 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) +import Prelude hiding ((++)) + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/test/data/hiding/HideFunctionWithoutLocal.hs b/test/data/hiding/HideFunctionWithoutLocal.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunctionWithoutLocal.hs @@ -0,0 +1,13 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/test/data/hiding/HidePreludeIndented.expected.hs b/test/data/hiding/HidePreludeIndented.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeIndented.expected.hs @@ -0,0 +1,5 @@ +module HidePreludeIndented where + + import AVec + import Prelude hiding ((++)) + op = (++) diff --git a/test/data/hiding/HidePreludeIndented.hs b/test/data/hiding/HidePreludeIndented.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeIndented.hs @@ -0,0 +1,4 @@ +module HidePreludeIndented where + + import AVec + op = (++) diff --git a/test/data/hiding/HidePreludeLocalInfix.expected.hs b/test/data/hiding/HidePreludeLocalInfix.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeLocalInfix.expected.hs @@ -0,0 +1,9 @@ +module HidePreludeLocalInfix where +import Prelude hiding ((++)) + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/test/data/hiding/HidePreludeLocalInfix.hs b/test/data/hiding/HidePreludeLocalInfix.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeLocalInfix.hs @@ -0,0 +1,8 @@ +module HidePreludeLocalInfix where + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs b/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs @@ -0,0 +1,10 @@ +module HideQualifyDuplicateRecordFields where + +import AVec +import BVec +import CVec +import DVec +import EVec +import FVec + +theFun = AVec.fromList diff --git a/test/data/hiding/HideQualifyDuplicateRecordFields.hs b/test/data/hiding/HideQualifyDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifyDuplicateRecordFields.hs @@ -0,0 +1,10 @@ +module HideQualifyDuplicateRecordFields where + +import AVec +import BVec +import CVec +import DVec +import EVec +import FVec + +theFun = fromList diff --git a/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs b/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs @@ -0,0 +1,5 @@ +module HideQualifyDuplicateRecordFieldsSelf where + +import FVec + +x = fromList diff --git a/test/data/hiding/HideQualifyInfix.expected.hs b/test/data/hiding/HideQualifyInfix.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifyInfix.expected.hs @@ -0,0 +1,5 @@ +module HideQualifyInfix where + +import AVec + +infixed xs ys = xs Prelude.++ ys diff --git a/test/data/hiding/HideQualifyInfix.hs b/test/data/hiding/HideQualifyInfix.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifyInfix.hs @@ -0,0 +1,5 @@ +module HideQualifyInfix where + +import AVec + +infixed xs ys = xs ++ ys diff --git a/test/data/hiding/HideQualifySectionLeft.expected.hs b/test/data/hiding/HideQualifySectionLeft.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifySectionLeft.expected.hs @@ -0,0 +1,5 @@ +module HideQualifySectionLeft where + +import AVec + +sectLeft xs = (Prelude.++ xs) diff --git a/test/data/hiding/HideQualifySectionLeft.hs b/test/data/hiding/HideQualifySectionLeft.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifySectionLeft.hs @@ -0,0 +1,5 @@ +module HideQualifySectionLeft where + +import AVec + +sectLeft xs = (++ xs) diff --git a/test/data/hiding/HideQualifySectionRight.expected.hs b/test/data/hiding/HideQualifySectionRight.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifySectionRight.expected.hs @@ -0,0 +1,5 @@ +module HideQualifySectionRight where + +import AVec + +sectLeft xs = (xs Prelude.++) diff --git a/test/data/hiding/HideQualifySectionRight.hs b/test/data/hiding/HideQualifySectionRight.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideQualifySectionRight.hs @@ -0,0 +1,5 @@ +module HideQualifySectionRight where + +import AVec + +sectLeft xs = (xs ++) diff --git a/test/data/hiding/HideType.expected.A.hs b/test/data/hiding/HideType.expected.A.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideType.expected.A.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E hiding (Vec) + +type TheType = Vec diff --git a/test/data/hiding/HideType.expected.E.hs b/test/data/hiding/HideType.expected.E.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideType.expected.E.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec ( fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/test/data/hiding/HideType.hs b/test/data/hiding/HideType.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideType.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/test/data/hiding/hie.yaml b/test/data/hiding/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/hiding/hie.yaml @@ -0,0 +1,11 @@ +cradle: + direct: + arguments: + - -Wall + - HideFunction.hs + - AVec.hs + - BVec.hs + - CVec.hs + - DVec.hs + - EVec.hs + - FVec.hs diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/GotoHover.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ diff --git a/test/data/hover/RecordDotSyntax.hs b/test/data/hover/RecordDotSyntax.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z +#endif diff --git a/test/data/hover/hie.yaml b/test/data/hover/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/hover/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/test/data/import-placement/CommentAtTop.expected.hs b/test/data/import-placement/CommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentAtTop.hs b/test/data/import-placement/CommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentAtTopMultipleComments.expected.hs b/test/data/import-placement/CommentAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTopMultipleComments.expected.hs @@ -0,0 +1,12 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- | Another comment +data SomethingElse = SomethingElse + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentAtTopMultipleComments.hs b/test/data/import-placement/CommentAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentAtTopMultipleComments.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where + +-- | Another comment +data SomethingElse = SomethingElse + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs b/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/CommentCurlyBraceAtTop.hs b/test/data/import-placement/CommentCurlyBraceAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/CommentCurlyBraceAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/DataAtTop.expected.hs b/test/data/import-placement/DataAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/DataAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/DataAtTop.hs b/test/data/import-placement/DataAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/DataAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/ImportAtTop.expected.hs b/test/data/import-placement/ImportAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ImportAtTop.expected.hs @@ -0,0 +1,14 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Monoid + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +-- | a comment +instance SomeData All diff --git a/test/data/import-placement/ImportAtTop.hs b/test/data/import-placement/ImportAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ImportAtTop.hs @@ -0,0 +1,13 @@ +module Test +( SomeData(..) +) where + +import Data.Char + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +-- | a comment +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleAtTop.expected.hs b/test/data/import-placement/LangPragmaModuleAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleAtTop.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleAtTop.hs b/test/data/import-placement/LangPragmaModuleAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleAtTop.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs b/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleExplicitExports.hs b/test/data/import-placement/LangPragmaModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleExplicitExports.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleWithComment.expected.hs b/test/data/import-placement/LangPragmaModuleWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleWithComment.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LangPragmaModuleWithComment.hs b/test/data/import-placement/LangPragmaModuleWithComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LangPragmaModuleWithComment.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTop.expected.hs b/test/data/import-placement/LanguagePragmaAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTop.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTop.hs b/test/data/import-placement/LanguagePragmaAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTop.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs b/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmaAtTopWithComment.hs b/test/data/import-placement/LanguagePragmaAtTopWithComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmaAtTopWithComment.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs b/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/LanguagePragmasThenShebangs.hs b/test/data/import-placement/LanguagePragmasThenShebangs.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/LanguagePragmasThenShebangs.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/ModuleDeclAndImports.expected.hs b/test/data/import-placement/ModuleDeclAndImports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ModuleDeclAndImports.expected.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where +import Data.Char +import Data.Array +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/ModuleDeclAndImports.hs b/test/data/import-placement/ModuleDeclAndImports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ModuleDeclAndImports.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Char +import Data.Array + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLineCommentAtTop.expected.hs b/test/data/import-placement/MultiLineCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLineCommentAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLineCommentAtTop.hs b/test/data/import-placement/MultiLineCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLineCommentAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLinePragma.expected.hs b/test/data/import-placement/MultiLinePragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLinePragma.expected.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} +import Data.Monoid + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLinePragma.hs b/test/data/import-placement/MultiLinePragma.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLinePragma.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultipleImportsAtTop.expected.hs b/test/data/import-placement/MultipleImportsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleImportsAtTop.expected.hs @@ -0,0 +1,14 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Bool +import Data.Eq +import Data.Monoid + +-- | A comment +class Semigroup a => SomeData a + +-- | another comment +instance SomeData All diff --git a/test/data/import-placement/MultipleImportsAtTop.hs b/test/data/import-placement/MultipleImportsAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleImportsAtTop.hs @@ -0,0 +1,13 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Bool +import Data.Eq + +-- | A comment +class Semigroup a => SomeData a + +-- | another comment +instance SomeData All diff --git a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +import Data.Monoid + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NewTypeAtTop.expected.hs b/test/data/import-placement/NewTypeAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NewTypeAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NewTypeAtTop.hs b/test/data/import-placement/NewTypeAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NewTypeAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs b/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs @@ -0,0 +1,7 @@ +module Test where +import Data.Monoid + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExportCommentAtTop.hs b/test/data/import-placement/NoExplicitExportCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExportCommentAtTop.hs @@ -0,0 +1,6 @@ +module Test where + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExports.expected.hs b/test/data/import-placement/NoExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExports.expected.hs @@ -0,0 +1,8 @@ +module Test where +import Data.Monoid + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoExplicitExports.hs b/test/data/import-placement/NoExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoExplicitExports.hs @@ -0,0 +1,7 @@ +module Test where + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclaration.expected.hs b/test/data/import-placement/NoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclaration.expected.hs @@ -0,0 +1,7 @@ +import Data.Monoid +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclaration.hs b/test/data/import-placement/NoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclaration.hs @@ -0,0 +1,6 @@ +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs b/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs @@ -0,0 +1,5 @@ +import Data.Monoid +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs b/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs @@ -0,0 +1,4 @@ +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsNotAtTopWithSpaces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.hs b/test/data/import-placement/OptionsPragmaNotAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsPragmaNotAtTop.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopMultipleComments.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs b/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text +import Data.Monoid + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.hs b/test/data/import-placement/PragmaNotAtTopWithImports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithImports.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs b/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasAndShebangsNoComment.hs b/test/data/import-placement/PragmasAndShebangsNoComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasAndShebangsNoComment.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs b/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasShebangsAndModuleDecl.hs b/test/data/import-placement/PragmasShebangsAndModuleDecl.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsAndModuleDecl.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs b/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test +( SomeData(..) +) where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs b/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test +( SomeData(..) +) where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs b/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +{- | some multiline + comment + ... -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/PragmasThenShebangsMultilineComment.hs b/test/data/import-placement/PragmasThenShebangsMultilineComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmasThenShebangsMultilineComment.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +{- | some multiline + comment + ... -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/ShebangNotAtTop.expected.hs b/test/data/import-placement/ShebangNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTop.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTop.hs b/test/data/import-placement/ShebangNotAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTop.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopNoSpace.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopWithSpaces.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/TwoDashOnlyComment.expected.hs b/test/data/import-placement/TwoDashOnlyComment.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/TwoDashOnlyComment.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/TwoDashOnlyComment.hs b/test/data/import-placement/TwoDashOnlyComment.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/TwoDashOnlyComment.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/WhereDeclLowerInFile.expected.hs b/test/data/import-placement/WhereDeclLowerInFile.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFile.expected.hs @@ -0,0 +1,18 @@ +module Asdf + (f + , where') + + where +import Data.Int + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereDeclLowerInFile.hs b/test/data/import-placement/WhereDeclLowerInFile.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFile.hs @@ -0,0 +1,17 @@ +module Asdf + (f + , where') + + where + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs b/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs @@ -0,0 +1,20 @@ +module Asdf + (f + , where') +-- hello +-- world + + where +import Data.Int + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs b/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs @@ -0,0 +1,19 @@ +module Asdf + (f + , where') +-- hello +-- world + + where + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs @@ -0,0 +1,16 @@ +module Asdf + + + where +import Data.Int + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs @@ -0,0 +1,15 @@ +module Asdf + + + where + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id