hls-splice-plugin 0.3.0.0 → 1.0.0.0
raw patch · 4 files changed
+754/−764 lines, 4 filesdep +extradep +lspdep +unliftio-coredep −haskell-lspdep ~ghcidedep ~hls-plugin-apinew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: extra, lsp, unliftio-core
Dependencies removed: haskell-lsp
Dependency ranges changed: ghcide, hls-plugin-api
API changes (from Hackage documentation)
Files
- LICENSE +201/−201
- hls-splice-plugin.cabal +39/−36
- src/Ide/Plugin/Splice.hs +460/−473
- src/Ide/Plugin/Splice/Types.hs +54/−54
LICENSE view
@@ -1,201 +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.+ 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.
hls-splice-plugin.cabal view
@@ -1,36 +1,39 @@-cabal-version: 2.2-name: hls-splice-plugin-version: 0.3.0.0-synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes-description: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes.-license: Apache-2.0-license-file: LICENSE-author: Hiromi ISHII-maintainer: konn.jinro_at_gmail.com-category: Development-build-type: Simple--library- exposed-modules: Ide.Plugin.Splice- ghc-options: -Wall- other-modules: Ide.Plugin.Splice.Types- hs-source-dirs: src- build-depends: aeson- , base >=4.12 && <5- , containers- , foldl- , haskell-lsp- , hls-plugin-api- , ghc- , ghc-exactprint- , ghcide >= 0.7.3.0- , lens- , dlist- , retrie- , shake- , syb- , text- , transformers- , unordered-containers-- default-language: Haskell2010+cabal-version: 2.2 +name: hls-splice-plugin +version: 1.0.0.0 +synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes +description: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes. +license: Apache-2.0 +license-file: LICENSE +author: https://github.com/haskell/haskell-language-server/contributors +maintainer: https://github.com/haskell/haskell-language-server/contributors +category: Development +build-type: Simple + +library + exposed-modules: Ide.Plugin.Splice + ghc-options: -Wall -Wno-unticked-promoted-constructors + other-modules: Ide.Plugin.Splice.Types + hs-source-dirs: src + build-depends: aeson + , base >=4.12 && <5 + , containers + , extra + , foldl + , lsp + , hls-plugin-api ^>= 1.0.0.0 + , ghc + , ghc-exactprint + , ghcide ^>= 1.0.0.0 + , lens + , dlist + , retrie + , shake + , syb + , text + , transformers + , unordered-containers + , unliftio-core + + default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators
src/Ide/Plugin/Splice.hs view
@@ -1,473 +1,460 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module Ide.Plugin.Splice- ( descriptor,- )-where--import Control.Applicative (Alternative ((<|>)))-import Control.Arrow-import qualified Control.Foldl as L-import Control.Lens (ix, view, (%~), (<&>), (^.))-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Data.Aeson-import Data.Function-import Data.Generics-import qualified Data.Kind as Kinds-import Data.List (sortOn)-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)-import qualified Data.Text as T-import Development.IDE-import Development.IDE.GHC.Compat hiding (getLoc)-import Exception-import GHC.Exts-import GhcMonad-import GhcPlugins hiding (Var, getLoc, (<>))-import Ide.Plugin.Splice.Types-import Ide.PluginUtils (mkLspCommand, responseError)-import Development.IDE.GHC.ExactPrint-import Ide.Types-import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT)-import Language.Haskell.LSP.Core-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Types.Lens as J-import Retrie.ExactPrint (Annotated)-import RnSplice-import TcRnMonad-import Data.Foldable (Foldable(foldl'))--descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId =- (defaultPluginDescriptor plId)- { pluginCommands = commands- , pluginCodeActionProvider = Just codeAction- }--commands :: [PluginCommand IdeState]-commands =- [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace- -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented- ]--newtype SubSpan = SubSpan {runSubSpan :: SrcSpan}--instance Eq SubSpan where- (==) = (==) `on` runSubSpan--instance Ord SubSpan where- (<=) = coerce isSubspanOf--expandTHSplice ::- -- | Inplace?- ExpandStyle ->- CommandFunction IdeState ExpandSpliceParams-expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} =- fmap (fromMaybe defaultResult) $- runMaybeT $ do-- fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri- eedits <-- ( lift . runExceptT . withTypeChecked fp- =<< MaybeT- (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp)- )- <|> lift (runExceptT $ expandManually fp)-- case eedits of- Left err -> do- reportEditor- lsp- MtError- ["Error during expanding splice: " <> T.pack err]- pure (Left $ responseError $ T.pack err, Nothing)- Right edits ->- pure- ( Right Null- , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits)- )- where- range = realSrcSpanToRange spliceSpan- srcSpan = RealSrcSpan spliceSpan- defaultResult = (Right Null, Nothing)- expandManually fp = do- mresl <-- liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp- (TcModuleResult {..}, _) <-- maybe- (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (errornous) macro and expand splice again."- )- pure mresl- reportEditor- lsp- MtWarning- [ "Expansion in type-chcking phase failed;"- , "trying to expand manually, but note taht it is less rigorous."- ]- pm <-- liftIO $- runAction "expandTHSplice.fallback.GetParsedModule" ideState $- use_ GetParsedModule fp- (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm-- manualCalcEdit- lsp- range- ps- hscEnv- tmrTypechecked- spliceSpan- _eStyle- params- withTypeChecked fp TcModuleResult {..} = do- (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed- let Splices {..} = tmrTopLevelSplices- let exprSuperSpans =- listToMaybe $ findSubSpansDesc srcSpan exprSplices- _patSuperSpans =-#if __GLASGOW_HASKELL__ == 808- fmap (second dL) $-#endif- listToMaybe $ findSubSpansDesc srcSpan patSplices- typeSuperSpans =- listToMaybe $ findSubSpansDesc srcSpan typeSplices- declSuperSpans =- listToMaybe $ findSubSpansDesc srcSpan declSplices-- graftSpliceWith ::- forall ast.- HasSplice ast =>- Maybe (SrcSpan, Located (ast GhcPs)) ->- Maybe (Either String WorkspaceEdit)- graftSpliceWith expandeds =- expandeds <&> \(_, expanded) ->- transform- dflags- (clientCapabilities lsp)- uri- (graft (RealSrcSpan spliceSpan) expanded)- ps- maybe (throwE "No splice information found") (either throwE pure) $- case spliceContext of- Expr -> graftSpliceWith exprSuperSpans- Pat ->-- graftSpliceWith _patSuperSpans-- HsType -> graftSpliceWith typeSuperSpans- HsDecl ->- declSuperSpans <&> \(_, expanded) ->- transform- dflags- (clientCapabilities lsp)- uri- (graftDecls (RealSrcSpan spliceSpan) expanded)- ps- <&>- -- FIXME: Why ghc-exactprint sweeps preceeding comments?- adjustToRange uri range--setupHscEnv- :: IdeState- -> NormalizedFilePath- -> ParsedModule- -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags)-setupHscEnv ideState fp pm = do- hscEnvEq <-- liftIO $- runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $- use_ GhcSessionDeps fp- let ps = annotateParsedSource pm- hscEnv0 = hscEnvWithImportPaths hscEnvEq- modSum = pm_mod_summary pm- df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum- let hscEnv = hscEnv0 { hsc_dflags = df' }- pure (ps, hscEnv, df')--setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags-setupDynFlagsForGHCiLike env dflags = do- let dflags3 =- dflags- { hscTarget = HscInterpreted- , ghcMode = CompManager- , ghcLink = LinkInMemory- }- platform = targetPlatform dflags3- dflags3a = updateWays $ dflags3 {ways = interpWays}- dflags3b =- foldl gopt_set dflags3a $- concatMap (wayGeneralFlags platform) interpWays- dflags3c =- foldl gopt_unset dflags3b $- concatMap (wayUnsetGeneralFlags platform) interpWays- dflags4 =- dflags3c- `gopt_set` Opt_ImplicitImportQualified- `gopt_set` Opt_IgnoreOptimChanges- `gopt_set` Opt_IgnoreHpcChanges- `gopt_unset` Opt_DiagnosticsShowCaret- initializePlugins env dflags4--adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit-adjustToRange uri ran (WorkspaceEdit mhult mlt) =- WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt)- where- adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit- adjustTextEdits eds =- let Just minStart =- L.fold- (L.premap (view J.range) L.minimum)- eds- in adjustLine minStart <$> eds- adjustWS = ix uri %~ adjustTextEdits- adjustDoc es- | es ^. J.textDocument . J.uri == uri =- es & J.edits %~ adjustTextEdits- | otherwise = es-- adjustLine :: Range -> TextEdit -> TextEdit- adjustLine bad =- J.range %~ \r ->- if r == bad then ran else bad--findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]-findSubSpansDesc srcSpan =- sortOn (Down . SubSpan . fst)- . mapMaybe- ( \(L spn _, e) -> do- guard (spn `isSubspanOf` srcSpan)- pure (spn, e)- )--data SpliceClass where- OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass- IsHsDecl :: SpliceClass--class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where- type SpliceOf ast :: Kinds.Type -> Kinds.Type- type SpliceOf ast = HsSplice- matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)- expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars)--instance HasSplice HsExpr where- matchSplice _ (HsSpliceE _ spl) = Just spl- matchSplice _ _ = Nothing- expandSplice _ = fmap (first Right) . rnSpliceExpr--instance HasSplice Pat where- matchSplice _ (SplicePat _ spl) = Just spl- matchSplice _ _ = Nothing- expandSplice _ = rnSplicePat---instance HasSplice HsType where- matchSplice _ (HsSpliceTy _ spl) = Just spl- matchSplice _ _ = Nothing- expandSplice _ = fmap (first Right) . rnSpliceType--classifyAST :: SpliceContext -> SpliceClass-classifyAST = \case- Expr -> OneToOneAST @HsExpr proxy#- HsDecl -> IsHsDecl- Pat -> OneToOneAST @Pat proxy#- HsType -> OneToOneAST @HsType proxy#--reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m ()-reportEditor lsp msgTy msgs =- liftIO $- sendFunc lsp $- NotShowMessage $- NotificationMessage "2.0" WindowShowMessage $- ShowMessageParams msgTy $- T.unlines msgs--manualCalcEdit ::- LspFuncs a ->- Range ->- Annotated ParsedSource ->- HscEnv ->- TcGblEnv ->- RealSrcSpan ->- ExpandStyle ->- ExpandSpliceParams ->- ExceptT String IO WorkspaceEdit-manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do- (warns, resl) <-- ExceptT $ do- ((warns, errs), eresl) <-- initTcWithGbl hscEnv typechkd srcSpan $- case classifyAST spliceContext of- IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $- flip (transformM dflags (clientCapabilities lsp) uri) ps $- graftDeclsWithM (RealSrcSpan srcSpan) $ \case- (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do- eExpr <-- either (fail . show) pure- =<< lift- ( lift $- gtry @_ @SomeException $- (fst <$> rnTopSpliceDecls spl)- )- pure $ Just eExpr- _ -> pure Nothing- OneToOneAST astP ->- flip (transformM dflags (clientCapabilities lsp) uri) ps $- graftWithM (RealSrcSpan srcSpan) $ \case- (L _spn (matchSplice astP -> Just spl)) -> do- eExpr <-- either (fail . show) pure- =<< lift- ( lift $- gtry @_ @SomeException $- (fst <$> expandSplice astP spl)- )- Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr- _ -> pure Nothing- pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl-- unless- (null warns)- $ reportEditor- lsp- MtWarning- [ "Warning during expanding: "- , ""- , T.pack (show warns)- ]- pure resl- where- dflags = hsc_dflags hscEnv---- | FIXME: Is thereAny "clever" way to do this exploiting TTG?-unRenamedE ::- forall ast m.- (Fail.MonadFail m, HasSplice ast) =>- DynFlags ->- ast GhcRn ->- TransformT m (Located (ast GhcPs))-unRenamedE dflags expr = do- uniq <- show <$> uniqueSrcSpanT- (anns, expr') <-- either (fail . show) pure $- parseAST @(ast GhcPs) dflags uniq $- showSDoc dflags $ ppr expr- let _anns' = setPrecedingLines expr' 0 1 anns- pure expr'--data SearchResult r =- Continue | Stop | Here r- deriving (Read, Show, Eq, Ord, Data, Typeable)--fromSearchResult :: SearchResult a -> Maybe a-fromSearchResult (Here r) = Just r-fromSearchResult _ = Nothing---- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)--- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs?-codeAction :: CodeActionProvider IdeState-codeAction _ state plId docId ran _ =- fmap (maybe (Right $ List []) Right) $- runMaybeT $ do- fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri- ParsedModule {..} <-- MaybeT . runAction "splice.codeAction.GitHieAst" state $- use GetParsedModule fp- let spn =- rangeToRealSrcSpan ran $- fromString $- fromNormalizedFilePath fp- mouterSplice = something' (detectSplice spn) pm_parsed_source- mcmds <- forM mouterSplice $- \(spliceSpan, spliceContext) ->- forM expandStyles $ \(_, (title, cmdId)) -> do- let params = ExpandSpliceParams {uri = theUri, ..}- act <- liftIO $ mkLspCommand plId cmdId title (Just [toJSON params])- pure $- CACodeAction $- CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act)-- pure $ maybe mempty List mcmds- where- theUri = docId ^. J.uri- detectSplice ::- RealSrcSpan ->- GenericQ (SearchResult (RealSrcSpan, SpliceContext))- detectSplice spn =- mkQ- Continue- ( \case- (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs)- | RealSrcSpan spn `isSubspanOf` l ->- case expr of- HsSpliceE {} -> Here (spLoc, Expr)- _ -> Continue- _ -> Stop- )- `extQ` \case-#if __GLASGOW_HASKELL__ == 808- (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs))-#else- (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs)-#endif- | RealSrcSpan spn `isSubspanOf` l ->- case pat of- SplicePat{} -> Here (spLoc, Pat)- _ -> Continue- _ -> Stop- `extQ` \case- (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs)- | RealSrcSpan spn `isSubspanOf` l ->- case ty of- HsSpliceTy {} -> Here (spLoc, HsType)- _ -> Continue- _ -> Stop- `extQ` \case- (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs)- | RealSrcSpan spn `isSubspanOf` l ->- case decl of- SpliceD {} -> Here (spLoc, HsDecl)- _ -> Continue- _ -> Stop---- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received,--- and picks inenrmost result.-something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a)-something' f = go- where- go :: GenericQ (Maybe a)- go x =- case f x of- Stop -> Nothing- resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x)--posToRealSrcLoc :: Position -> FastString -> RealSrcLoc-posToRealSrcLoc pos fs = mkRealSrcLoc fs (line + 1) (col + 1)- where- line = _line pos- col = _character pos--rangeToRealSrcSpan :: Range -> FastString -> RealSrcSpan-rangeToRealSrcSpan ran fs =- mkRealSrcSpan- (posToRealSrcLoc (_start ran) fs)- (posToRealSrcLoc (_end ran) fs)+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Splice + ( descriptor, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow +import qualified Control.Foldl as L +import Control.Lens (ix, view, (%~), (<&>), (^.)) +import Control.Monad +import Control.Monad.Extra (eitherM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Function +import Data.Generics +import qualified Data.Kind as Kinds +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat hiding (getLoc) +import Exception +import GHC.Exts +import GhcMonad +import GhcPlugins hiding (Var, getLoc, (<>)) +import Ide.Plugin.Splice.Types +import Development.IDE.GHC.ExactPrint +import Ide.Types +import Language.Haskell.GHC.ExactPrint (setPrecedingLines, uniqueSrcSpanT) +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as J +import RnSplice +import TcRnMonad +import Data.Foldable (Foldable(foldl')) +import Control.Monad.IO.Unlift + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginCommands = commands + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + } + +commands :: [PluginCommand IdeState] +commands = + [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace + -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented + ] + +newtype SubSpan = SubSpan {runSubSpan :: SrcSpan} + +instance Eq SubSpan where + (==) = (==) `on` runSubSpan + +instance Ord SubSpan where + (<=) = coerce isSubspanOf + +expandTHSplice :: + -- | Inplace? + ExpandStyle -> + CommandFunction IdeState ExpandSpliceParams +expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do + clientCapabilities <- getClientCapabilities + rio <- askRunInIO + let reportEditor :: ReportEditor + reportEditor msgTy msgs = liftIO $ rio $ sendNotification SWindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + expandManually fp = do + mresl <- + liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp + (TcModuleResult {..}, _) <- + maybe + (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (errornous) macro and expand splice again." + ) + pure mresl + reportEditor + MtWarning + [ "Expansion in type-chcking phase failed;" + , "trying to expand manually, but note taht it is less rigorous." + ] + pm <- + liftIO $ + runAction "expandTHSplice.fallback.GetParsedModule" ideState $ + use_ GetParsedModule fp + (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm + + manualCalcEdit + clientCapabilities + reportEditor + range + ps + hscEnv + tmrTypechecked + spliceSpan + _eStyle + params + + withTypeChecked fp TcModuleResult {..} = do + (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + let Splices {..} = tmrTopLevelSplices + let exprSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan exprSplices + _patSuperSpans = +#if __GLASGOW_HASKELL__ == 808 + fmap (second dL) $ +#endif + listToMaybe $ findSubSpansDesc srcSpan patSplices + typeSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan typeSplices + declSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan declSplices + + graftSpliceWith :: + forall ast. + HasSplice ast => + Maybe (SrcSpan, Located (ast GhcPs)) -> + Maybe (Either String WorkspaceEdit) + graftSpliceWith expandeds = + expandeds <&> \(_, expanded) -> + transform + dflags + clientCapabilities + uri + (graft (RealSrcSpan spliceSpan) expanded) + ps + maybe (throwE "No splice information found") (either throwE pure) $ + case spliceContext of + Expr -> graftSpliceWith exprSuperSpans + Pat -> + + graftSpliceWith _patSuperSpans + + HsType -> graftSpliceWith typeSuperSpans + HsDecl -> + declSuperSpans <&> \(_, expanded) -> + transform + dflags + clientCapabilities + uri + (graftDecls (RealSrcSpan spliceSpan) expanded) + ps + <&> + -- FIXME: Why ghc-exactprint sweeps preceeding comments? + adjustToRange uri range + + res <- liftIO $ runMaybeT $ do + + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri + eedits <- + ( lift . runExceptT . withTypeChecked fp + =<< MaybeT + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + ) + <|> lift (runExceptT $ expandManually fp) + + case eedits of + Left err -> do + reportEditor + MtError + ["Error during expanding splice: " <> T.pack err] + pure (Left $ responseError $ T.pack err) + Right edits -> + pure (Right edits) + case res of + Nothing -> pure $ Right Null + Just (Left err) -> pure $ Left err + Just (Right edit) -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ Right Null + + where + range = realSrcSpanToRange spliceSpan + srcSpan = RealSrcSpan spliceSpan + + +setupHscEnv + :: IdeState + -> NormalizedFilePath + -> ParsedModule + -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags) +setupHscEnv ideState fp pm = do + hscEnvEq <- + liftIO $ + runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ + use_ GhcSessionDeps fp + let ps = annotateParsedSource pm + hscEnv0 = hscEnvWithImportPaths hscEnvEq + modSum = pm_mod_summary pm + df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + let hscEnv = hscEnv0 { hsc_dflags = df' } + pure (ps, hscEnv, df') + +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike env dflags = do + let dflags3 = + dflags + { hscTarget = HscInterpreted + , ghcMode = CompManager + , ghcLink = LinkInMemory + } + platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 {ways = interpWays} + dflags3b = + foldl gopt_set dflags3a $ + concatMap (wayGeneralFlags platform) interpWays + dflags3c = + foldl gopt_unset dflags3b $ + concatMap (wayUnsetGeneralFlags platform) interpWays + dflags4 = + dflags3c + `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + `gopt_unset` Opt_DiagnosticsShowCaret + initializePlugins env dflags4 + +adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit +adjustToRange uri ran (WorkspaceEdit mhult mlt) = + WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) + where + adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit + adjustTextEdits eds = + let Just minStart = + L.fold + (L.premap (view J.range) L.minimum) + eds + in adjustLine minStart <$> eds + adjustWS = ix uri %~ adjustTextEdits + adjustDoc :: DocumentChange -> DocumentChange + adjustDoc (InR es) = InR es + adjustDoc (InL es) + | es ^. J.textDocument . J.uri == uri = + InL $ es & J.edits %~ adjustTextEdits + | otherwise = InL es + + adjustLine :: Range -> TextEdit -> TextEdit + adjustLine bad = + J.range %~ \r -> + if r == bad then ran else bad + +findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] +findSubSpansDesc srcSpan = + sortOn (Down . SubSpan . fst) + . mapMaybe + ( \(L spn _, e) -> do + guard (spn `isSubspanOf` srcSpan) + pure (spn, e) + ) + +data SpliceClass where + OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass + IsHsDecl :: SpliceClass + +class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where + type SpliceOf ast :: Kinds.Type -> Kinds.Type + type SpliceOf ast = HsSplice + matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) + expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) + +instance HasSplice HsExpr where + matchSplice _ (HsSpliceE _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = fmap (first Right) . rnSpliceExpr + +instance HasSplice Pat where + matchSplice _ (SplicePat _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = rnSplicePat + + +instance HasSplice HsType where + matchSplice _ (HsSpliceTy _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = fmap (first Right) . rnSpliceType + +classifyAST :: SpliceContext -> SpliceClass +classifyAST = \case + Expr -> OneToOneAST @HsExpr proxy# + HsDecl -> IsHsDecl + Pat -> OneToOneAST @Pat proxy# + HsType -> OneToOneAST @HsType proxy# + +type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m () + +manualCalcEdit :: + ClientCapabilities -> + ReportEditor -> + Range -> + Annotated ParsedSource -> + HscEnv -> + TcGblEnv -> + RealSrcSpan -> + ExpandStyle -> + ExpandSpliceParams -> + ExceptT String IO WorkspaceEdit +manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do + (warns, resl) <- + ExceptT $ do + ((warns, errs), eresl) <- + initTcWithGbl hscEnv typechkd srcSpan $ + case classifyAST spliceContext of + IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ + flip (transformM dflags clientCapabilities uri) ps $ + graftDeclsWithM (RealSrcSpan srcSpan) $ \case + (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do + eExpr <- + eitherM (fail . show) pure + $ lift + ( lift $ + gtry @_ @SomeException $ + (fst <$> rnTopSpliceDecls spl) + ) + pure $ Just eExpr + _ -> pure Nothing + OneToOneAST astP -> + flip (transformM dflags clientCapabilities uri) ps $ + graftWithM (RealSrcSpan srcSpan) $ \case + (L _spn (matchSplice astP -> Just spl)) -> do + eExpr <- + eitherM (fail . show) pure + $ lift + ( lift $ + gtry @_ @SomeException $ + (fst <$> expandSplice astP spl) + ) + Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr + _ -> pure Nothing + pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl + + unless + (null warns) + $ reportEditor + MtWarning + [ "Warning during expanding: " + , "" + , T.pack (show warns) + ] + pure resl + where + dflags = hsc_dflags hscEnv + +-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? +unRenamedE :: + forall ast m. + (Fail.MonadFail m, HasSplice ast) => + DynFlags -> + ast GhcRn -> + TransformT m (Located (ast GhcPs)) +unRenamedE dflags expr = do + uniq <- show <$> uniqueSrcSpanT + (anns, expr') <- + either (fail . show) pure $ + parseAST @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr + let _anns' = setPrecedingLines expr' 0 1 anns + pure expr' + +data SearchResult r = + Continue | Stop | Here r + deriving (Read, Show, Eq, Ord, Data, Typeable) + +fromSearchResult :: SearchResult a -> Maybe a +fromSearchResult (Here r) = Just r +fromSearchResult _ = Nothing + +-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) +-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? +codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ + fmap (maybe (Right $ List []) Right) $ + runMaybeT $ do + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + ParsedModule {..} <- + MaybeT . runAction "splice.codeAction.GitHieAst" state $ + use GetParsedModule fp + let spn = rangeToRealSrcSpan fp ran + mouterSplice = something' (detectSplice spn) pm_parsed_source + mcmds <- forM mouterSplice $ + \(spliceSpan, spliceContext) -> + forM expandStyles $ \(_, (title, cmdId)) -> do + let params = ExpandSpliceParams {uri = theUri, ..} + act = mkLspCommand plId cmdId title (Just [toJSON params]) + pure $ + InR $ + CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) + + pure $ maybe mempty List mcmds + where + theUri = docId ^. J.uri + detectSplice :: + RealSrcSpan -> + GenericQ (SearchResult (RealSrcSpan, SpliceContext)) + detectSplice spn = + mkQ + Continue + ( \case + (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case expr of + HsSpliceE {} -> Here (spLoc, Expr) + _ -> Continue + _ -> Stop + ) + `extQ` \case +#if __GLASGOW_HASKELL__ == 808 + (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) +#else + (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) +#endif + | RealSrcSpan spn `isSubspanOf` l -> + case pat of + SplicePat{} -> Here (spLoc, Pat) + _ -> Continue + _ -> Stop + `extQ` \case + (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case ty of + HsSpliceTy {} -> Here (spLoc, HsType) + _ -> Continue + _ -> Stop + `extQ` \case + (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case decl of + SpliceD {} -> Here (spLoc, HsDecl) + _ -> Continue + _ -> Stop + +-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received, +-- and picks inenrmost result. +something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a) +something' f = go + where + go :: GenericQ (Maybe a) + go x = + case f x of + Stop -> Nothing + resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x)
src/Ide/Plugin/Splice/Types.hs view
@@ -1,54 +1,54 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}--module Ide.Plugin.Splice.Types where--import Data.Aeson (FromJSON, ToJSON)-import Development.IDE (Uri)-import GHC.Generics (Generic)-import Development.IDE.GHC.Compat (RealSrcSpan)-import qualified Data.Text as T-import Ide.Types ( CommandId )---- | Parameter for the addMethods PluginCommand.-data ExpandSpliceParams = ExpandSpliceParams- { uri :: Uri- , spliceSpan :: RealSrcSpan- , spliceContext :: SpliceContext- }- deriving (Show, Eq, Generic)- deriving anyclass (ToJSON, FromJSON)---- FIXME: HsDecl needs different treatment of splicing.-data SpliceContext = Expr | HsDecl | Pat | HsType- deriving (Read, Show, Eq, Ord, Generic)- deriving anyclass (ToJSON, FromJSON)--data ExpandStyle = Inplace | Commented- deriving (Read, Show, Eq, Ord, Generic)--expandStyles :: [(ExpandStyle, (T.Text, CommandId))]-expandStyles =- [ (Inplace, (inplaceCmdName, expandInplaceId))- -- , (Commented, commentedCmdName, expandCommentedId)- ]--toExpandCmdTitle :: ExpandStyle -> T.Text-toExpandCmdTitle Inplace = inplaceCmdName-toExpandCmdTitle Commented = commentedCmdName--toCommandId :: ExpandStyle -> CommandId-toCommandId Inplace = expandInplaceId-toCommandId Commented = expandCommentedId--expandInplaceId, expandCommentedId :: CommandId-expandInplaceId = "expandTHSpliceInplace"-expandCommentedId = "expandTHSpliceCommented"--inplaceCmdName :: T.Text-inplaceCmdName = "expand TemplateHaskell Splice (in-place)"--commentedCmdName :: T.Text-commentedCmdName = "expand TemplateHaskell Splice (comented-out)"+{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module Ide.Plugin.Splice.Types where + +import Data.Aeson (FromJSON, ToJSON) +import Development.IDE (Uri) +import GHC.Generics (Generic) +import Development.IDE.GHC.Compat (RealSrcSpan) +import qualified Data.Text as T +import Ide.Types ( CommandId ) + +-- | Parameter for the addMethods PluginCommand. +data ExpandSpliceParams = ExpandSpliceParams + { uri :: Uri + , spliceSpan :: RealSrcSpan + , spliceContext :: SpliceContext + } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- FIXME: HsDecl needs different treatment of splicing. +data SpliceContext = Expr | HsDecl | Pat | HsType + deriving (Read, Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data ExpandStyle = Inplace | Commented + deriving (Read, Show, Eq, Ord, Generic) + +expandStyles :: [(ExpandStyle, (T.Text, CommandId))] +expandStyles = + [ (Inplace, (inplaceCmdName, expandInplaceId)) + -- , (Commented, commentedCmdName, expandCommentedId) + ] + +toExpandCmdTitle :: ExpandStyle -> T.Text +toExpandCmdTitle Inplace = inplaceCmdName +toExpandCmdTitle Commented = commentedCmdName + +toCommandId :: ExpandStyle -> CommandId +toCommandId Inplace = expandInplaceId +toCommandId Commented = expandCommentedId + +expandInplaceId, expandCommentedId :: CommandId +expandInplaceId = "expandTHSpliceInplace" +expandCommentedId = "expandTHSpliceCommented" + +inplaceCmdName :: T.Text +inplaceCmdName = "expand TemplateHaskell Splice (in-place)" + +commentedCmdName :: T.Text +commentedCmdName = "expand TemplateHaskell Splice (comented-out)"