From 5da15996668226e6cf99be57193ca3fff382f73e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Wed, 30 Dec 2020 02:29:47 +0900 Subject: [PATCH 01/51] Implements splice location detection --- exe/Plugins.hs | 34 +-- haskell-language-server.cabal | 11 + hie-cabal.yaml | 3 + hie-stack.yaml | 3 + plugins/hls-splice-plugin/LICENSE | 201 ++++++++++++++++++ .../hls-splice-plugin/hls-splice-plugin.cabal | 32 +++ .../src/Ide/Plugin/Splice.hs | 97 +++++++++ .../src/Ide/Plugin/Splice/Types.hs | 65 ++++++ stack-8.10.1.yaml | 1 + stack-8.10.2.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.2.yaml | 1 + stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + 15 files changed, 440 insertions(+), 13 deletions(-) create mode 100644 plugins/hls-splice-plugin/LICENSE create mode 100644 plugins/hls-splice-plugin/hls-splice-plugin.cabal create mode 100644 plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs create mode 100644 plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 83c3899daa..e5e7308a51 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Plugins where -import Ide.Types (IdePlugins) -import Ide.Plugin (pluginDescToIdePlugins) +module Plugins where +import Ide.Plugin (pluginDescToIdePlugins) -- fixed plugins -import Ide.Plugin.Example as Example -import Ide.Plugin.Example2 as Example2 -import Ide.Plugin.GhcIde as GhcIde +import Ide.Plugin.Example as Example +import Ide.Plugin.Example2 as Example2 +import Ide.Plugin.GhcIde as GhcIde +import Ide.Types (IdePlugins) -- haskell-language-server optional plugins @@ -44,6 +44,11 @@ import Ide.Plugin.ModuleName as ModuleName import Ide.Plugin.Pragmas as Pragmas #endif +#if defined(splice) +import Ide.Plugin.Splice as Splice +#endif + + -- formatters #if floskell @@ -68,14 +73,14 @@ import Ide.Plugin.Brittany as Brittany -- --------------------------------------------------------------------- --- | The plugins configured for use in this instance of the language --- server. --- These can be freely added or removed to tailor the available --- features of the server. - +{- | The plugins configured for use in this instance of the language + server. + These can be freely added or removed to tailor the available + features of the server. +-} idePlugins :: Bool -> IdePlugins idePlugins includeExamples = pluginDescToIdePlugins allPlugins - where + where allPlugins = if includeExamples then basePlugins ++ examplePlugins else basePlugins @@ -119,6 +124,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #endif #if hlint , Hlint.descriptor "hlint" +#endif +#if defined(splice) + , Splice.descriptor "splice" #endif ] examplePlugins = diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3b5b9153d6..2f355cac50 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -127,6 +127,11 @@ flag pragmas default: False manual: True +flag splice + description: Enable splice plugin + default: False + manual: True + -- formatters flag floskell @@ -212,6 +217,11 @@ common pragmas other-modules: Ide.Plugin.Pragmas cpp-options: -Dpragmas +common splice + if flag(splice) || flag(all-plugins) + build-depends: hls-splice-plugin + cpp-options: -Dsplice + -- formatters common floskell @@ -262,6 +272,7 @@ executable haskell-language-server , hlint , moduleName , pragmas + , splice , floskell , fourmolu , ormolu diff --git a/hie-cabal.yaml b/hie-cabal.yaml index f106c0df7c..b9ddcc23d0 100644 --- a/hie-cabal.yaml +++ b/hie-cabal.yaml @@ -115,6 +115,9 @@ cradle: - path: "./plugins/hls-retrie-plugin/src" component: "lib:hls-retrie-plugin" + - path: "./plugins/hls-splice-plugin/src" + component: "hls-splice-plugin:lib" + - path: "./plugins/tactics/src" component: "lib:hls-tactics-plugin" diff --git a/hie-stack.yaml b/hie-stack.yaml index 1c03904013..2986683c32 100644 --- a/hie-stack.yaml +++ b/hie-stack.yaml @@ -54,6 +54,9 @@ cradle: - path: "./plugins/hls-retrie-plugin/src" component: "hls-retrie-plugin:lib" + - path: "./plugins/hls-splice-plugin/src" + component: "hls-splice-plugin:lib" + - path: "./plugins/tactics/src" component: "hls-tactics-plugin:lib" diff --git a/plugins/hls-splice-plugin/LICENSE b/plugins/hls-splice-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-splice-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal new file mode 100644 index 0000000000..998242749f --- /dev/null +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -0,0 +1,32 @@ +cabal-version: 2.2 +name: hls-splice-plugin +version: 0.1.0.0 +synopsis: HLS Plugin Expanding +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 + , containers + , haskell-lsp + , hls-plugin-api + , ghc + , ghc-exactprint + , ghcide + , lens + , dlist + , shake + , text + , transformers + , unordered-containers + + default-language: Haskell2010 diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs new file mode 100644 index 0000000000..fd6e3013fe --- /dev/null +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Splice + ( descriptor, + ) +where + +import Control.Lens hiding (List, use) +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Writer.CPS +import Data.Aeson +import qualified Data.DList as DL +import Data.Monoid (Ap (..)) +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat hiding (getLoc) +import GhcPlugins hiding (Var, getLoc, (<>)) +import Ide.Logger (debugm) +import Ide.Plugin +import Ide.Plugin.Splice.Types +import Ide.Types +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as J + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = + (defaultPluginDescriptor plId) + { pluginCommands = commands + , pluginCodeActionProvider = Just codeAction + } + +-- +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)" + +commands :: [PluginCommand] +commands = + [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace + , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented + ] + +expandTHSplice :: + -- | Inplace? + ExpandStyle -> + CommandFunction ExpandSpliceParams +expandTHSplice _eStyle _ _ params@ExpandSpliceParams {..} = do + debugm $ "Expanding splice for " <> show params <> " (lie!)" + pure (Right Null, Nothing) + +codeAction :: CodeActionProvider +codeAction _ state plId docId _ _ = + fmap (maybe (Right $ List []) Right) $ + runMaybeT $ do + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + (getAsts . hieAst -> asts, _) <- + MaybeT . runAction "splice" state $ + useWithStale GetHieAst fp + fmap (List . DL.toList) $ execWriterT $ alaf Ap foldMap go asts + where + theUri = docId ^. J.uri + go ast = forM (flattenAst ast) $ \Node {..} -> do + let NodeInfo {..} = nodeInfo + when (Set.size nodeAnnotations == 1) $ do + -- (cons, typ) + let spCxt = case head $ Set.toList nodeAnnotations of + ("SplicePat", "Pat") -> Just Pat + ("HsSpliceE", "HsExpr") -> Just Expr + ("HsSpliceTy", "HsType") -> Just HsType + ("SpliceD", "HsDecl") -> Just HsDecl + _ -> Nothing + forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> + let range = realSrcSpanToRange nodeSpan + params = ExpandSpliceParams {uri = theUri, ..} + in CACodeAction + . CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing + . Just + <$> liftIO (mkLspCommand plId cmdId title (Just [toJSON params])) + +expandStyles :: [(ExpandStyle, T.Text, CommandId)] +expandStyles = + [ (Inplace, inplaceCmdName, expandInplaceId) + , (Commented, commentedCmdName, expandCommentedId) + ] diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs new file mode 100644 index 0000000000..ef4349630a --- /dev/null +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Splice.Types where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) +import Data.Function (on) +import qualified Data.Text as T +import Development.IDE (Range, Uri) +import GHC.Generics (Generic) +import TcRnTypes (SpliceType (Typed, Untyped)) + +newtype SpliceType_ = SpliceType_ {getSpliceType :: SpliceType} + deriving (Generic) + +instance Eq SpliceType_ where + (==) = eqSpliceType `on` getSpliceType + +instance Ord SpliceType_ where + compare = cmpSpliceType `on` getSpliceType + +instance Show SpliceType_ where + showsPrec _ (SpliceType_ Typed) = showString "Typed" + showsPrec _ (SpliceType_ Untyped) = showString "Untyped" + +instance ToJSON SpliceType_ where + toJSON (SpliceType_ Typed) = "Typed" + toJSON (SpliceType_ Untyped) = "Untyped" + +instance FromJSON SpliceType_ where + parseJSON = withText "Typed or Untyped" $ \case + "Typed" -> pure $ SpliceType_ Typed + "Untyepd" -> pure $ SpliceType_ Untyped + txt -> fail $ "Typed, or Untyped is expected, but got: " <> T.unpack txt + +eqSpliceType :: SpliceType -> SpliceType -> Bool +eqSpliceType Typed Typed = True +eqSpliceType Untyped Untyped = True +eqSpliceType Typed Untyped = False +eqSpliceType Untyped Typed = False + +cmpSpliceType :: SpliceType -> SpliceType -> Ordering +cmpSpliceType Typed Typed = EQ +cmpSpliceType Typed Untyped = LT +cmpSpliceType Untyped Untyped = EQ +cmpSpliceType Untyped Typed = GT + +-- | Parameter for the addMethods PluginCommand. +data ExpandSpliceParams = ExpandSpliceParams + { uri :: Uri + , range :: Range + , spliceContext :: SpliceContext + } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +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) diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 978dfd883a..5163cd27a0 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin +- ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 7e0b778694..c13ca38faf 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin +- ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index f70faab22a..3c871b4256 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -11,6 +11,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index c16d891e46..051230e472 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index feb54527d6..8d370d295b 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index b187c4296d..35a6d9aecf 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin +- ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index ea9f3ce40a..2fd8af60e3 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -10,6 +10,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin +- ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: From cd052b090e1baa0dd5747d02b2bab29d06142b53 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Wed, 30 Dec 2020 03:31:30 +0900 Subject: [PATCH 02/51] Corrects detection logic --- .../src/Ide/Plugin/Splice.hs | 29 +++++++++---------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index fd6e3013fe..e1c079ec3c 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -74,21 +74,20 @@ codeAction _ state plId docId _ _ = theUri = docId ^. J.uri go ast = forM (flattenAst ast) $ \Node {..} -> do let NodeInfo {..} = nodeInfo - when (Set.size nodeAnnotations == 1) $ do - -- (cons, typ) - let spCxt = case head $ Set.toList nodeAnnotations of - ("SplicePat", "Pat") -> Just Pat - ("HsSpliceE", "HsExpr") -> Just Expr - ("HsSpliceTy", "HsType") -> Just HsType - ("SpliceD", "HsDecl") -> Just HsDecl - _ -> Nothing - forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> - let range = realSrcSpanToRange nodeSpan - params = ExpandSpliceParams {uri = theUri, ..} - in CACodeAction - . CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing - . Just - <$> liftIO (mkLspCommand plId cmdId title (Just [toJSON params])) + spCxt + | ("SplicePat", "Pat") `Set.member` nodeAnnotations = + Just Pat + | ("HsSpliceE", "HsExpr") `Set.member` nodeAnnotations = Just Expr + | ("HsSpliceTy", "HsType") `Set.member` nodeAnnotations = Just HsType + | ("SpliceD", "HsDecl") `Set.member` nodeAnnotations = Just HsDecl + | otherwise = Nothing + forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> + let range = realSrcSpanToRange nodeSpan + params = ExpandSpliceParams {uri = theUri, ..} + in CACodeAction + . CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing + . Just + <$> liftIO (mkLspCommand plId cmdId title (Just [toJSON params])) expandStyles :: [(ExpandStyle, T.Text, CommandId)] expandStyles = From 52a84469fe533a33fd6755a53cf1f9ef2f3af065 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Wed, 30 Dec 2020 03:31:43 +0900 Subject: [PATCH 03/51] Changed to use (bogus) message for code action --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index e1c079ec3c..5fe1d33356 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -57,8 +57,16 @@ expandTHSplice :: -- | Inplace? ExpandStyle -> CommandFunction ExpandSpliceParams -expandTHSplice _eStyle _ _ params@ExpandSpliceParams {..} = do - debugm $ "Expanding splice for " <> show params <> " (lie!)" +expandTHSplice _eStyle lsp _ params@ExpandSpliceParams {..} = do + sendFunc lsp $ + NotShowMessage $ + NotificationMessage "2.0" WindowShowMessage $ + ShowMessageParams MtInfo $ + T.unlines + [ "## Expanding splice for: " + , "-" <> T.pack (show params) + , "(lie)" + ] pure (Right Null, Nothing) codeAction :: CodeActionProvider From 1648d19911cbc0e6f08b835d4832f7b9d13e6954 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Wed, 30 Dec 2020 04:24:09 +0900 Subject: [PATCH 04/51] Splice location --- .../src/Ide/Plugin/Splice.hs | 83 ++++++++++++++----- .../src/Ide/Plugin/Splice/Types.hs | 1 + 2 files changed, 64 insertions(+), 20 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 5fe1d33356..513fa494db 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -17,15 +17,23 @@ import Control.Monad.Trans.Writer.CPS import Data.Aeson import qualified Data.DList as DL import Data.Monoid (Ap (..)) +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getLoc) import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Logger (debugm) import Ide.Plugin import Ide.Plugin.Splice.Types + ( ExpandSpliceParams (..), + ExpandStyle (..), + SpliceContext (Expr, HsDecl, HsType, Pat), + ) import Ide.Types +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as J @@ -64,38 +72,73 @@ expandTHSplice _eStyle lsp _ params@ExpandSpliceParams {..} = do ShowMessageParams MtInfo $ T.unlines [ "## Expanding splice for: " - , "-" <> T.pack (show params) + , "-" <> T.pack (show (_eStyle, params)) , "(lie)" ] pure (Right Null, 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 -codeAction _ state plId docId _ _ = +codeAction lsp state plId docId range0 _ = fmap (maybe (Right $ List []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri - (getAsts . hieAst -> asts, _) <- + (getAsts . hieAst -> asts, posMap) <- MaybeT . runAction "splice" state $ useWithStale GetHieAst fp - fmap (List . DL.toList) $ execWriterT $ alaf Ap foldMap go asts + ran' <- + MaybeT $ + pure $ + fromCurrentRange posMap range0 + fmap (List . DL.toList) $ + execWriterT $ + getAp $ ifoldMap (fmap Ap . go ran') asts where + sloc pos fs = mkRealSrcLoc fs (line pos + 1) (cha pos + 1) + sp ran fs = mkRealSrcSpan (sloc (_start ran) fs) (sloc (_end ran) fs) + line ran = _line ran + cha ran = _character ran + theUri = docId ^. J.uri - go ast = forM (flattenAst ast) $ \Node {..} -> do - let NodeInfo {..} = nodeInfo - spCxt - | ("SplicePat", "Pat") `Set.member` nodeAnnotations = - Just Pat - | ("HsSpliceE", "HsExpr") `Set.member` nodeAnnotations = Just Expr - | ("HsSpliceTy", "HsType") `Set.member` nodeAnnotations = Just HsType - | ("SpliceD", "HsDecl") `Set.member` nodeAnnotations = Just HsDecl - | otherwise = Nothing - forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> - let range = realSrcSpanToRange nodeSpan - params = ExpandSpliceParams {uri = theUri, ..} - in CACodeAction - . CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing - . Just - <$> liftIO (mkLspCommand plId cmdId title (Just [toJSON params])) + go ran' fs ast = do + trace ("astanns: " <> show (foldMap (DL.singleton . nodeAnnotations . nodeInfo) (flattenAst ast))) $ pure () + forM_ (smallestContainingSatisfying (sp ran' fs) isSpliceNode ast) $ + \Node {..} -> do + let NodeInfo {..} = nodeInfo + spCxt + | ("SplicePat", "Pat") `Set.member` nodeAnnotations = + Just Pat + | ("HsSpliceE", "HsExpr") `Set.member` nodeAnnotations = Just Expr + | ("HsSpliceTy", "HsType") `Set.member` nodeAnnotations = Just HsType + | ("SpliceD", "HsDecl") `Set.member` nodeAnnotations = Just HsDecl + | otherwise = Nothing + forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> do + let range = realSrcSpanToRange nodeSpan + params = ExpandSpliceParams {uri = theUri, ..} + act <- + liftIO $ + mkLspCommand plId cmdId title (Just [toJSON params]) + tell $ + DL.singleton $ + CACodeAction $ + CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act) + +isSpliceNode :: HieAST Type -> Bool +isSpliceNode Node {..} = + not $ + Set.null $ + spliceAnns + `Set.intersection` nodeAnnotations nodeInfo + +spliceAnns :: Set (FastString, FastString) +spliceAnns = + Set.fromList + [ ("SplicePat", "Pat") + , ("HsSpliceE", "HsExpr") + , ("HsSpliceTy", "HsType") + , ("SpliceD", "HsDecl") + ] expandStyles :: [(ExpandStyle, T.Text, CommandId)] expandStyles = diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index ef4349630a..0f1afa73d0 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -8,6 +8,7 @@ module Ide.Plugin.Splice.Types where import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) import Data.Function (on) +import Data.Set (Set) import qualified Data.Text as T import Development.IDE (Range, Uri) import GHC.Generics (Generic) From fd39e5717ca3839f4977a1108fb49aa81b107f24 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Wed, 30 Dec 2020 16:19:17 +0900 Subject: [PATCH 05/51] Extract `Ide.TreeTransform` as an independent package --- hie-cabal.yaml | 3 ++ hie-stack.yaml | 3 ++ .../hls-exactprint-utils.cabal | 47 +++++++++++++++++++ .../src/Ide/TreeTransform.hs | 0 plugins/tactics/hls-tactics-plugin.cabal | 2 +- stack-8.10.1.yaml | 1 + stack-8.10.2.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.2.yaml | 1 + stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + 12 files changed, 61 insertions(+), 1 deletion(-) create mode 100644 hls-exactprint-utils/hls-exactprint-utils.cabal rename {plugins/tactics => hls-exactprint-utils}/src/Ide/TreeTransform.hs (100%) diff --git a/hie-cabal.yaml b/hie-cabal.yaml index b9ddcc23d0..a6c19432ad 100644 --- a/hie-cabal.yaml +++ b/hie-cabal.yaml @@ -103,6 +103,9 @@ cradle: - path: "./hls-plugin-api/src" component: "lib:hls-plugin-api" + - path: "./hls-exactprint-utils/src" + component: "lib:hls-exactprint-utils" + - path: "./plugins/hls-class-plugin/src" component: "lib:hls-class-plugin" diff --git a/hie-stack.yaml b/hie-stack.yaml index 2986683c32..8a21dc1147 100644 --- a/hie-stack.yaml +++ b/hie-stack.yaml @@ -40,6 +40,9 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib" + - path: "./hls-exactprint-utils/src" + component: "hls-exactprint-utils:lib" + # Plugins: - path: "./plugins/hls-class-plugin/src" diff --git a/hls-exactprint-utils/hls-exactprint-utils.cabal b/hls-exactprint-utils/hls-exactprint-utils.cabal new file mode 100644 index 0000000000..f4b4165b29 --- /dev/null +++ b/hls-exactprint-utils/hls-exactprint-utils.cabal @@ -0,0 +1,47 @@ +cabal-version: 2.2 +name: hls-exactprint-utils +version: 0.5.0.1 +synopsis: Common residence package of ExactPrint related tree-transformation utilities for HLS plugins (ported from tactics plugin). +description: + Please see the README on GitHub at +homepage: https://github.com/haskell/haskell-language-server/hls-exactprint-utils +bug-reports: https://github.com/haskell/haskell-language-server/issues +author: Sandy Maguire, Reed Mullanix +maintainer: sandy@sandymaguire.me +copyright: Sandy Maguire, Reed Mullanix +category: Web +build-type: Simple + +flag pedantic + description: Enable -Werror + default: False + manual: True + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +library + exposed-modules: + Ide.TreeTransform + + hs-source-dirs: src + build-depends: + base >=4.12 && <5 + , ghc + , ghc-exactprint + , ghcide + , haskell-lsp-types + , hls-plugin-api + , retrie + , syb + , text + , transformers + + + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 diff --git a/plugins/tactics/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs similarity index 100% rename from plugins/tactics/src/Ide/TreeTransform.hs rename to hls-exactprint-utils/src/Ide/TreeTransform.hs diff --git a/plugins/tactics/hls-tactics-plugin.cabal b/plugins/tactics/hls-tactics-plugin.cabal index aa1256c02c..43d72ee12d 100644 --- a/plugins/tactics/hls-tactics-plugin.cabal +++ b/plugins/tactics/hls-tactics-plugin.cabal @@ -37,7 +37,6 @@ library Ide.Plugin.Tactic.Tactics Ide.Plugin.Tactic.Types Ide.Plugin.Tactic.TestTypes - Ide.TreeTransform ghc-options: -Wno-name-shadowing -Wredundant-constraints @@ -60,6 +59,7 @@ library , ghcide >=0.1 , haskell-lsp ^>=0.22 , hls-plugin-api + , hls-exactprint-utils , lens , mtl , refinery ^>=0.3 diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 5163cd27a0..65124bce2a 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -6,6 +6,7 @@ packages: - ./ghcide/ # - ./shake-bench - ./hls-plugin-api +- ./hls-exactprint-utils - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index c13ca38faf..76570c64aa 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./ghcide/ - ./hls-plugin-api +- ./hls-exactprint-utils # - ./shake-bench - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 3c871b4256..ecd7ca1877 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -7,6 +7,7 @@ packages: - ./ghcide/ # - ./shake-bench - ./hls-plugin-api + - ./hls-exactprint-utils - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 051230e472..a2b0ac90c5 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./ghcide/ - ./hls-plugin-api + - ./hls-exactprint-utils # - ./shake-bench - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 8d370d295b..f8e9785d6d 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./ghcide/ - ./hls-plugin-api + - ./hls-exactprint-utils - ./shake-bench - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 35a6d9aecf..ffe07a8008 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -6,6 +6,7 @@ packages: - ./ghcide/ - ./shake-bench - ./hls-plugin-api +- ./hls-exactprint-utils - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 2fd8af60e3..eaa975ca73 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -6,6 +6,7 @@ packages: - ./ghcide/ - ./shake-bench - ./hls-plugin-api +- ./hls-exactprint-utils - ./plugins/hls-class-plugin - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin From f6de0ab3de63f4488ea0fa19392e29ebe4119e1b Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 02:19:57 +0900 Subject: [PATCH 06/51] It once worked, but stops... --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 246 ++++++++++++------ .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 223 ++++++++++++++-- 3 files changed, 368 insertions(+), 102 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 80b0062ff5..72a13c1c35 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,122 +1,208 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Ide.TreeTransform - ( Graft, graft, transform, useAnnotatedSource - ) where - -import BasicTypes (appPrec) -import Control.Monad -import Control.Monad.Trans.Class + ( Graft, + graft, + graftWithM, + graftWithSmallestM, + transform, + transformM, + useAnnotatedSource, + ) +where + +import BasicTypes (appPrec) +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans.Class import qualified Data.Text as T -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (parseExpr) -import Development.IDE.Types.Location -import Generics.SYB -import Ide.PluginUtils -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) -import Outputable -import Retrie.ExactPrint hiding (parseExpr) - +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.Types.Location +import Generics.SYB +import Ide.PluginUtils +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) +import Outputable +import Retrie.ExactPrint hiding (parseExpr) ------------------------------------------------------------------------------ + -- | Get the latest version of the annotated parse source. -useAnnotatedSource - :: String - -> IdeState - -> NormalizedFilePath - -> IO (Maybe (Annotated ParsedSource)) +useAnnotatedSource :: + String -> + IdeState -> + NormalizedFilePath -> + IO (Maybe (Annotated ParsedSource)) useAnnotatedSource herald state nfp = do - pm <- runAction herald state $ use GetParsedModule nfp - pure $ fmap fixAnns pm - + pm <- runAction herald state $ use GetParsedModule nfp + pure $ fmap fixAnns pm ------------------------------------------------------------------------------ --- | A transformation for grafting source trees together. Use the semigroup --- instance to combine 'Graft's, and run them via 'transform'. -newtype Graft a = Graft - { runGraft :: DynFlags -> a -> TransformT (Either String) a - } -instance Semigroup (Graft a) where - Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags +{- | 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 + } -instance Monoid (Graft a) where - mempty = Graft $ const pure +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 ParsedSource - -> Annotated ParsedSource - -> Either String 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 + 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 m ParsedSource -> + Annotated ParsedSource -> + m WorkspaceEdit +transformM 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 ------------------------------------------------------------------------------ --- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the --- given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or --- this is a no-op. -graft - :: forall a - . Data a - => SrcSpan - -> LHsExpr GhcPs - -> Graft a + +{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the + given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or + this is a no-op. +-} +graft :: + forall a. + Data a => + SrcSpan -> + LHsExpr GhcPs -> + Graft (Either String) a graft dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags $ parenthesize val - modifyAnnsT $ mappend anns - pure $ everywhere' - ( mkT $ - \case - (L src _ :: LHsExpr GhcPs) | src == dst -> val' - l -> l - ) a + (anns, val') <- annotate dflags $ parenthesize val + modifyAnnsT $ mappend anns + pure $ + everywhere' + ( mkT $ + \case + (L src _ :: LHsExpr GhcPs) | src == dst -> val' + l -> l + ) + a +------------------------------------------------------------------------------ + +graftWithM :: + forall m a. + (Fail.MonadFail m, Data a) => + SrcSpan -> + (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + Graft m a +graftWithM dst trans = Graft $ \dflags a -> do + everywhereM' + ( mkM $ + \case + val@(L src _ :: LHsExpr GhcPs) + | src == dst -> do + mval <- trans val + case mval of + Just val' -> do + (anns, val'') <- + hoistTransform (either Fail.fail pure) $ + annotate dflags $ parenthesize val' + modifyAnnsT $ mappend anns + pure val'' + Nothing -> pure val + l -> pure l + ) + a + +graftWithSmallestM :: + forall m a. + (Fail.MonadFail m, Data a) => + SrcSpan -> + (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + Graft m a +graftWithSmallestM dst trans = Graft $ \dflags a -> do + everywhereM + ( mkM $ + \case + val@(L src _ :: LHsExpr GhcPs) + | dst `isSubspanOf` src -> do + mval <- trans val + case mval of + Just val' -> do + (anns, val'') <- + hoistTransform (either Fail.fail pure) $ + annotate dflags $ parenthesize val' + modifyAnnsT $ mappend anns + pure val'' + Nothing -> pure val + l -> pure l + ) + a + +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f ------------------------------------------------------------------------------ + -- | 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 - + let ranns = relativiseApiAnns pm_parsed_source pm_annotations + in unsafeMkA pm_parsed_source ranns 0 ------------------------------------------------------------------------------ + -- | Given an 'LHSExpr', compute its exactprint annotations. annotate :: DynFlags -> LHsExpr GhcPs -> TransformT (Either String) (Anns, LHsExpr GhcPs) annotate dflags expr = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags expr - (anns, expr') <- lift $ either (Left . show) Right $ parseExpr dflags uniq rendered - let anns' = setPrecedingLines expr' 0 1 anns - pure (anns', expr') - + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags expr + (anns, expr') <- lift $ either (Left . show) Right $ parseExpr dflags uniq rendered + let anns' = setPrecedingLines expr' 0 1 anns + pure (anns', expr') ------------------------------------------------------------------------------ + -- | 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 - diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index 998242749f..a6fe780426 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -21,6 +21,7 @@ library , hls-plugin-api , ghc , ghc-exactprint + , hls-exactprint-utils , ghcide , lens , dlist diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 513fa494db..2e55967b23 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -10,32 +14,45 @@ module Ide.Plugin.Splice ) where -import Control.Lens hiding (List, use) +import Control.Exception (SomeException) +import Control.Lens (ifoldMap, (%~), (<&>), (^.)) +import Control.Lens.At import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.CPS import Data.Aeson import qualified Data.DList as DL +import Data.Maybe (fromMaybe) import Data.Monoid (Ap (..)) import Data.Set (Set) import qualified Data.Set as Set +import Data.String import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getLoc) +import Exception (gtry) +import GhcMonad import GhcPlugins hiding (Var, getLoc, (<>)) -import Ide.Logger (debugm) import Ide.Plugin import Ide.Plugin.Splice.Types ( ExpandSpliceParams (..), ExpandStyle (..), SpliceContext (Expr, HsDecl, HsType, Pat), ) +import Ide.TreeTransform import Ide.Types +import Language.Haskell.GHC.ExactPrint (Annotation (..), TransformT, getEntryDPT, modifyAnnsT, setPrecedingLines, uniqueSrcSpanT) +import qualified Language.Haskell.GHC.ExactPrint.Parsers as Exact +import Language.Haskell.GHC.ExactPrint.Types (Comment (Comment), mkAnnKey) 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 RnSplice +import TcRnMonad descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -65,27 +82,183 @@ expandTHSplice :: -- | Inplace? ExpandStyle -> CommandFunction ExpandSpliceParams -expandTHSplice _eStyle lsp _ params@ExpandSpliceParams {..} = do - sendFunc lsp $ - NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ - ShowMessageParams MtInfo $ - T.unlines - [ "## Expanding splice for: " - , "-" <> T.pack (show (_eStyle, params)) - , "(lie)" - ] - pure (Right Null, Nothing) +expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = + fmap (fromMaybe defaultResult) $ + runMaybeT $ do + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri + TcModuleResult {tmrParsed = pm, ..} <- + MaybeT $ + runAction "expandTHSplice.TypeCheck" ideState $ + use TypeCheck fp + ps <- + MaybeT $ + useAnnotatedSource + "expandTHSplice.AnnotedSource" + ideState + fp + hscEnvEq <- + lift $ + runAction "expandTHSplice.ghcSessionDeps" ideState $ + use_ GhcSessionDeps fp + let hscEnv0 = hscEnvWithImportPaths hscEnvEq + modSum = pm_mod_summary pm + hscEnv <- lift $ + evalGhcEnv hscEnv0 $ do + env <- getSession + df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts modSum + + let impPaths = fromMaybe (importPaths df) (envImportPaths hscEnvEq) + + -- Set the modified flags in the session + _lp <- setSessionDynFlags df {importPaths = impPaths} + + -- copy the package state to the interactive DynFlags + idflags <- getInteractiveDynFlags + setInteractiveDynFlags $ + idflags + { pkgState = pkgState df + , pkgDatabase = pkgDatabase df + , packageFlags = packageFlags df + , useColor = Never + , canUseColor = False + } + env' <- getSession + resl <- load LoadAllTargets + case resl of + Succeeded -> do + setContext [IIModule $ moduleName $ ms_mod modSum] + `gcatch` \(e :: SomeException) -> + reportEditor + lsp + MtWarning + ["Setting failure: ", T.pack $ show e] + getSession + Failed -> pure env' + + let dflags = hsc_dflags hscEnv + srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp + ((warns, errs), mEdits) <- liftIO $ + initTcWithGbl hscEnv tmrTypechecked srcSpan $ + case spliceContext of + Expr -> do + let g = graftWithSmallestM (RealSrcSpan srcSpan) $ \case + inp@(L _spn (HsSpliceE _ spl)) -> do + eExpr <- lift $ gtry @_ @SomeException (fst <$> rnSpliceExpr spl) + case eExpr of + Left exc -> + lift $ + Nothing + <$ reportEditor + lsp + MtError + [ "Error during expanding splice" + , "" + , T.pack (show exc) + ] + Right expr' -> + case eStyle of + Inplace -> do + Just <$> unRenamedE dflags expr' + Commented -> do + let expanded = showSDoc dflags $ ppr expr' + dPos <- getEntryDPT inp + uniq <- uniqueSrcSpanT + modifyAnnsT $ + ix (mkAnnKey inp) + %~ \ann -> + ann + { annFollowingComments = + (Comment expanded uniq Nothing, dPos) : + annFollowingComments ann + } + pure $ Just inp + _ -> pure Nothing + transformM dflags (clientCapabilities lsp) uri g ps + HsDecl -> undefined + Pat -> undefined + HsType -> undefined + + unless (null errs) $ + reportEditor + lsp + MtError + [ "Error during expanding splice:" + , T.pack $ show errs + ] + guard $ not $ null errs + unless (null warns) $ + reportEditor + lsp + MtWarning + [ "Warning during expanding splice:" + , T.pack $ show warns + ] + pure + ( Right Null + , mEdits <&> \edits -> + (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) + ) + where + defaultResult = (Right Null, Nothing) + +-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? +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 + +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 + +unRenamedE :: + Fail.MonadFail m => + DynFlags -> + HsExpr GhcRn -> + TransformT m (LHsExpr GhcPs) +unRenamedE dflags expr = do + uniq <- show <$> uniqueSrcSpanT + (anns, expr') <- + either (fail . show) pure $ + Exact.parseExpr dflags uniq $ + showSDoc dflags $ ppr expr + let _anns' = setPrecedingLines expr' 0 1 anns + -- modifyAnnsT $ mappend anns' + pure expr' -- 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 -codeAction lsp state plId docId range0 _ = +codeAction _ state plId docId range0 _ = fmap (maybe (Right $ List []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri (getAsts . hieAst -> asts, posMap) <- - MaybeT . runAction "splice" state $ + MaybeT . runAction "splice.codeAction.GitHieAst" state $ useWithStale GetHieAst fp ran' <- MaybeT $ @@ -95,15 +268,9 @@ codeAction lsp state plId docId range0 _ = execWriterT $ getAp $ ifoldMap (fmap Ap . go ran') asts where - sloc pos fs = mkRealSrcLoc fs (line pos + 1) (cha pos + 1) - sp ran fs = mkRealSrcSpan (sloc (_start ran) fs) (sloc (_end ran) fs) - line ran = _line ran - cha ran = _character ran - theUri = docId ^. J.uri go ran' fs ast = do - trace ("astanns: " <> show (foldMap (DL.singleton . nodeAnnotations . nodeInfo) (flattenAst ast))) $ pure () - forM_ (smallestContainingSatisfying (sp ran' fs) isSpliceNode ast) $ + forM_ (smallestContainingSatisfying (rangeToRealSrcSpan ran' fs) isSpliceNode ast) $ \Node {..} -> do let NodeInfo {..} = nodeInfo spCxt @@ -124,6 +291,18 @@ codeAction lsp state plId docId range0 _ = CACodeAction $ CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act) +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) + isSpliceNode :: HieAST Type -> Bool isSpliceNode Node {..} = not $ From 3cbfba9ba00ad5d96c920ee3cf6ced159eb64871 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 02:38:46 +0900 Subject: [PATCH 07/51] Now it works for inplace expansion for expressions --- .../src/Ide/Plugin/Splice.hs | 76 +++++++++---------- 1 file changed, 34 insertions(+), 42 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 2e55967b23..0da0f3a590 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -123,61 +123,53 @@ expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = , canUseColor = False } env' <- getSession + -- setTargets [thisModuleTarget] resl <- load LoadAllTargets case resl of Succeeded -> do setContext [IIModule $ moduleName $ ms_mod modSum] - `gcatch` \(e :: SomeException) -> - reportEditor - lsp - MtWarning - ["Setting failure: ", T.pack $ show e] + `gcatch` \(_ :: SomeException) -> pure () getSession Failed -> pure env' - let dflags = hsc_dflags hscEnv srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp ((warns, errs), mEdits) <- liftIO $ initTcWithGbl hscEnv tmrTypechecked srcSpan $ case spliceContext of - Expr -> do - let g = graftWithSmallestM (RealSrcSpan srcSpan) $ \case - inp@(L _spn (HsSpliceE _ spl)) -> do - eExpr <- lift $ gtry @_ @SomeException (fst <$> rnSpliceExpr spl) - case eExpr of - Left exc -> - lift $ - Nothing - <$ reportEditor - lsp - MtError - [ "Error during expanding splice" - , "" - , T.pack (show exc) - ] - Right expr' -> - case eStyle of - Inplace -> do - Just <$> unRenamedE dflags expr' - Commented -> do - let expanded = showSDoc dflags $ ppr expr' - dPos <- getEntryDPT inp - uniq <- uniqueSrcSpanT - modifyAnnsT $ - ix (mkAnnKey inp) - %~ \ann -> - ann - { annFollowingComments = - (Comment expanded uniq Nothing, dPos) : - annFollowingComments ann - } - pure $ Just inp - _ -> pure Nothing - transformM dflags (clientCapabilities lsp) uri g ps + Expr -> flip (transformM dflags (clientCapabilities lsp) uri) ps $ + graftWithSmallestM (RealSrcSpan srcSpan) $ \case + inp@(L _spn (HsSpliceE _ spl)) -> do + eExpr <- lift $ gtry @_ @SomeException (fst <$> rnSpliceExpr spl) + case (eExpr, eStyle) of + (Left exc, _) -> + lift $ + Nothing + <$ reportEditor + lsp + MtError + [ "Error during expanding splice" + , "" + , T.pack (show exc) + ] + (Right expr', Inplace) -> + Just <$> unRenamedE dflags expr' + (Right expr', Commented) -> do + let expanded = showSDoc dflags $ ppr expr' + dPos <- getEntryDPT inp + uniq <- uniqueSrcSpanT + modifyAnnsT $ + ix (mkAnnKey inp) + %~ \ann -> + ann + { annFollowingComments = + (Comment expanded uniq Nothing, dPos) : + annFollowingComments ann + } + pure $ Just inp + _ -> pure Nothing HsDecl -> undefined Pat -> undefined HsType -> undefined - unless (null errs) $ reportEditor lsp @@ -185,7 +177,7 @@ expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = [ "Error during expanding splice:" , T.pack $ show errs ] - guard $ not $ null errs + guard $ null errs unless (null warns) $ reportEditor lsp From 41b216475bfce63704a69883e916d5499d66bd1c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 03:07:40 +0900 Subject: [PATCH 08/51] generalises tree transformation to general AST element --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 53 +++++++++++++------ 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 72a13c1c35..9da5f4dcf8 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -12,6 +13,7 @@ module Ide.TreeTransform transform, transformM, useAnnotatedSource, + ASTElement(..), ) where @@ -32,7 +34,7 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) import Outputable -import Retrie.ExactPrint hiding (parseExpr) +import Retrie.ExactPrint hiding (parseExpr, parsePattern, parseType, parseDecl) ------------------------------------------------------------------------------ @@ -121,23 +123,23 @@ graft dst val = Graft $ \dflags a -> do ------------------------------------------------------------------------------ graftWithM :: - forall m a. - (Fail.MonadFail m, Data a) => + forall ast m a. + (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a graftWithM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - val@(L src _ :: LHsExpr GhcPs) + val@(L src _ :: Located ast) | src == dst -> do mval <- trans val case mval of Just val' -> do (anns, val'') <- hoistTransform (either Fail.fail pure) $ - annotate dflags $ parenthesize val' + annotate dflags $ maybeParensAST val' modifyAnnsT $ mappend anns pure val'' Nothing -> pure val @@ -146,23 +148,23 @@ graftWithM dst trans = Graft $ \dflags a -> do a graftWithSmallestM :: - forall m a. - (Fail.MonadFail m, Data a) => + forall ast m a. + (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a graftWithSmallestM dst trans = Graft $ \dflags a -> do everywhereM ( mkM $ \case - val@(L src _ :: LHsExpr GhcPs) + val@(L src _ :: Located ast) | dst `isSubspanOf` src -> do mval <- trans val case mval of Just val' -> do (anns, val'') <- hoistTransform (either Fail.fail pure) $ - annotate dflags $ parenthesize val' + annotate dflags $ maybeParensAST val' modifyAnnsT $ mappend anns pure val'' Nothing -> pure val @@ -176,8 +178,27 @@ everywhereM' f = go go :: GenericM m go = gmapM go <=< f ------------------------------------------------------------------------------- +class (Data ast, Outputable ast) => ASTElement ast where + parseAST :: Parser (Located ast) + maybeParensAST :: Located ast -> Located ast + +instance p ~ GhcPs => ASTElement (HsExpr p) where + parseAST = parseExpr + maybeParensAST = parenthesize + +instance p ~ GhcPs => ASTElement (Pat p) where + parseAST = parsePattern + maybeParensAST = parenthesizePat appPrec +instance p ~ GhcPs => ASTElement (HsType p) where + parseAST = parseType + maybeParensAST = parenthesizeHsType appPrec + +instance p ~ GhcPs => ASTElement (HsDecl p) where + parseAST = parseDecl + maybeParensAST = id + +------------------------------------------------------------------------------ -- | Dark magic I stole from retrie. No idea what it does. fixAnns :: ParsedModule -> Annotated ParsedSource fixAnns ParsedModule {..} = @@ -187,11 +208,11 @@ fixAnns ParsedModule {..} = ------------------------------------------------------------------------------ -- | Given an 'LHSExpr', compute its exactprint annotations. -annotate :: DynFlags -> LHsExpr GhcPs -> TransformT (Either String) (Anns, LHsExpr GhcPs) -annotate dflags expr = do +annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate dflags ast = do uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags expr - (anns, expr') <- lift $ either (Left . show) Right $ parseExpr dflags uniq rendered + let rendered = render dflags ast + (anns, expr') <- lift $ either (Left . show) Right $ parseAST dflags uniq rendered let anns' = setPrecedingLines expr' 0 1 anns pure (anns', expr') From a959ad0892e44861ffb095169ceeee7e69bdd23f Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:00:33 +0900 Subject: [PATCH 09/51] Done for Types and Patterns! --- .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 151 ++++++++++++------ .../src/Ide/Plugin/Splice/Types.hs | 46 +----- 3 files changed, 103 insertions(+), 95 deletions(-) diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index a6fe780426..d0ee4c9a19 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -25,6 +25,7 @@ library , ghcide , lens , dlist + , retrie , shake , text , transformers diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 0da0f3a590..b40148a2e7 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,9 +15,9 @@ module Ide.Plugin.Splice ) where +import Control.Arrow (Arrow (first)) import Control.Exception (SomeException) -import Control.Lens (ifoldMap, (%~), (<&>), (^.)) -import Control.Lens.At +import Control.Lens (ifoldMap, (<&>), (^.)) import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class @@ -24,33 +25,35 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.CPS import Data.Aeson import qualified Data.DList as DL +import qualified Data.Kind as Kinds import Data.Maybe (fromMaybe) import Data.Monoid (Ap (..)) import Data.Set (Set) import qualified Data.Set as Set -import Data.String import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getLoc) +import ErrUtils (ErrorMessages, WarningMessages) import Exception (gtry) +import GHC.Exts import GhcMonad import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Plugin import Ide.Plugin.Splice.Types ( ExpandSpliceParams (..), ExpandStyle (..), - SpliceContext (Expr, HsDecl, HsType, Pat), + SpliceContext (..), ) import Ide.TreeTransform import Ide.Types -import Language.Haskell.GHC.ExactPrint (Annotation (..), TransformT, getEntryDPT, modifyAnnsT, setPrecedingLines, uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) import qualified Language.Haskell.GHC.ExactPrint.Parsers as Exact -import Language.Haskell.GHC.ExactPrint.Types (Comment (Comment), mkAnnKey) 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 @@ -131,45 +134,8 @@ expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = `gcatch` \(_ :: SomeException) -> pure () getSession Failed -> pure env' - let dflags = hsc_dflags hscEnv - srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp - ((warns, errs), mEdits) <- liftIO $ - initTcWithGbl hscEnv tmrTypechecked srcSpan $ - case spliceContext of - Expr -> flip (transformM dflags (clientCapabilities lsp) uri) ps $ - graftWithSmallestM (RealSrcSpan srcSpan) $ \case - inp@(L _spn (HsSpliceE _ spl)) -> do - eExpr <- lift $ gtry @_ @SomeException (fst <$> rnSpliceExpr spl) - case (eExpr, eStyle) of - (Left exc, _) -> - lift $ - Nothing - <$ reportEditor - lsp - MtError - [ "Error during expanding splice" - , "" - , T.pack (show exc) - ] - (Right expr', Inplace) -> - Just <$> unRenamedE dflags expr' - (Right expr', Commented) -> do - let expanded = showSDoc dflags $ ppr expr' - dPos <- getEntryDPT inp - uniq <- uniqueSrcSpanT - modifyAnnsT $ - ix (mkAnnKey inp) - %~ \ann -> - ann - { annFollowingComments = - (Comment expanded uniq Nothing, dPos) : - annFollowingComments ann - } - pure $ Just inp - _ -> pure Nothing - HsDecl -> undefined - Pat -> undefined - HsType -> undefined + let srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp + ((warns, errs), mEdits) <- calculateEdits lsp ps hscEnv tmrTypechecked srcSpan eStyle params unless (null errs) $ reportEditor lsp @@ -193,6 +159,84 @@ expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = where defaultResult = (Right Null, Nothing) +data SomeHasSplice where + MkSomeHasSplice :: HasSplice ast => Proxy# ast -> SomeHasSplice + +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) + renameSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) + +instance HasSplice HsExpr where + matchSplice _ (HsSpliceE _ spl) = Just spl + matchSplice _ _ = Nothing + renameSplice _ = fmap (first Right) . rnSpliceExpr + +{- +instance HasSplice HsDecl where + type SpliceOf HsDecl = SpliceDecl + matchSplice _ (SpliceD _ decl) = Just decl + matchSplice _ _ = Nothing + renameSplice (SpliceDecl _ (L _ spl) flg) = + case flg of + ImplicitSplice -> + rnTopSpliceDecls spl + -} +instance HasSplice Pat where + matchSplice _ (SplicePat _ spl) = Just spl + matchSplice _ _ = Nothing + renameSplice _ = rnSplicePat + +instance HasSplice HsType where + matchSplice _ (HsSpliceTy _ spl) = Just spl + matchSplice _ _ = Nothing + renameSplice _ = fmap (first Right) . rnSpliceType + +toSomeASTElement :: SpliceContext -> SomeHasSplice +toSomeASTElement = \case + Expr -> MkSomeHasSplice @HsExpr proxy# + -- HsDecl -> MkSomeHasSplice @HsDecl proxy# + Pat -> MkSomeHasSplice @Pat proxy# + HsType -> MkSomeHasSplice @HsType proxy# + +calculateEdits :: + LspFuncs a -> + Annotated ParsedSource -> + HscEnv -> + TcGblEnv -> + RealSrcSpan -> + ExpandStyle -> + ExpandSpliceParams -> + MaybeT IO ((WarningMessages, ErrorMessages), Maybe WorkspaceEdit) +calculateEdits lsp ps hscEnv typechkd srcSpan eStyle ExpandSpliceParams {..} = + liftIO $ + initTcWithGbl hscEnv typechkd srcSpan $ + case toSomeASTElement spliceContext of + MkSomeHasSplice astP -> + flip (transformM dflags (clientCapabilities lsp) uri) ps $ + graftWithSmallestM (RealSrcSpan srcSpan) $ \case + (L _spn (matchSplice astP -> Just spl)) -> do + eExpr <- lift $ gtry @_ @SomeException (fst <$> renameSplice astP spl) + case (eExpr, eStyle) of + (Left exc, _) -> + lift $ + Nothing + <$ reportEditor + lsp + MtError + [ "Error during expanding splice" + , "" + , T.pack (show exc) + ] + (Right expr', Inplace) -> + Just <$> either (pure . L _spn) (unRenamedE dflags) expr' + (Right _expr', Commented) -> + pure Nothing + _ -> pure Nothing + where + dflags = hsc_dflags hscEnv + -- | FIXME: Is thereAny "clever" way to do this exploiting TTG? reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () reportEditor lsp msgTy msgs = @@ -228,15 +272,16 @@ setupDynFlagsForGHCiLike env dflags = do initializePlugins env dflags4 unRenamedE :: - Fail.MonadFail m => + forall ast m. + (Fail.MonadFail m, HasSplice ast) => DynFlags -> - HsExpr GhcRn -> - TransformT m (LHsExpr GhcPs) + ast GhcRn -> + TransformT m (Located (ast GhcPs)) unRenamedE dflags expr = do uniq <- show <$> uniqueSrcSpanT (anns, expr') <- either (fail . show) pure $ - Exact.parseExpr dflags uniq $ + parseAST @(ast GhcPs) dflags uniq $ showSDoc dflags $ ppr expr let _anns' = setPrecedingLines expr' 0 1 anns -- modifyAnnsT $ mappend anns' @@ -261,7 +306,7 @@ codeAction _ state plId docId range0 _ = getAp $ ifoldMap (fmap Ap . go ran') asts where theUri = docId ^. J.uri - go ran' fs ast = do + go ran' fs ast = forM_ (smallestContainingSatisfying (rangeToRealSrcSpan ran' fs) isSpliceNode ast) $ \Node {..} -> do let NodeInfo {..} = nodeInfo @@ -270,7 +315,9 @@ codeAction _ state plId docId range0 _ = Just Pat | ("HsSpliceE", "HsExpr") `Set.member` nodeAnnotations = Just Expr | ("HsSpliceTy", "HsType") `Set.member` nodeAnnotations = Just HsType + {- FIXME: HsDecl needs different treatment | ("SpliceD", "HsDecl") `Set.member` nodeAnnotations = Just HsDecl + -} | otherwise = Nothing forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> do let range = realSrcSpanToRange nodeSpan @@ -308,7 +355,7 @@ spliceAnns = [ ("SplicePat", "Pat") , ("HsSpliceE", "HsExpr") , ("HsSpliceTy", "HsType") - , ("SpliceD", "HsDecl") + -- , ("SpliceD", "HsDecl") -- FIXME: HsDecl ] expandStyles :: [(ExpandStyle, T.Text, CommandId)] diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index 0f1afa73d0..3361c87d48 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -1,53 +1,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Splice.Types where -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) -import Data.Function (on) -import Data.Set (Set) -import qualified Data.Text as T +import Data.Aeson (FromJSON, ToJSON) import Development.IDE (Range, Uri) import GHC.Generics (Generic) -import TcRnTypes (SpliceType (Typed, Untyped)) - -newtype SpliceType_ = SpliceType_ {getSpliceType :: SpliceType} - deriving (Generic) - -instance Eq SpliceType_ where - (==) = eqSpliceType `on` getSpliceType - -instance Ord SpliceType_ where - compare = cmpSpliceType `on` getSpliceType - -instance Show SpliceType_ where - showsPrec _ (SpliceType_ Typed) = showString "Typed" - showsPrec _ (SpliceType_ Untyped) = showString "Untyped" - -instance ToJSON SpliceType_ where - toJSON (SpliceType_ Typed) = "Typed" - toJSON (SpliceType_ Untyped) = "Untyped" - -instance FromJSON SpliceType_ where - parseJSON = withText "Typed or Untyped" $ \case - "Typed" -> pure $ SpliceType_ Typed - "Untyepd" -> pure $ SpliceType_ Untyped - txt -> fail $ "Typed, or Untyped is expected, but got: " <> T.unpack txt - -eqSpliceType :: SpliceType -> SpliceType -> Bool -eqSpliceType Typed Typed = True -eqSpliceType Untyped Untyped = True -eqSpliceType Typed Untyped = False -eqSpliceType Untyped Typed = False - -cmpSpliceType :: SpliceType -> SpliceType -> Ordering -cmpSpliceType Typed Typed = EQ -cmpSpliceType Typed Untyped = LT -cmpSpliceType Untyped Untyped = EQ -cmpSpliceType Untyped Typed = GT -- | Parameter for the addMethods PluginCommand. data ExpandSpliceParams = ExpandSpliceParams @@ -58,7 +17,8 @@ data ExpandSpliceParams = ExpandSpliceParams deriving (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON) -data SpliceContext = Expr | HsDecl | Pat | HsType +-- FIXME: HsDecl needs different treatment of splicing. +data SpliceContext = Expr {- HsDecl | -} | Pat | HsType deriving (Read, Show, Eq, Ord, Generic) deriving anyclass (ToJSON, FromJSON) From 313134ac30265fa7a7192612684190591c3420d4 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:01:31 +0900 Subject: [PATCH 10/51] Disabled "commented" style of expansion --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index b40148a2e7..07eba581a0 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -78,7 +78,7 @@ commentedCmdName = "expand TemplateHaskell Splice (comented-out)" commands :: [PluginCommand] commands = [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace - , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented + -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented ] expandTHSplice :: @@ -361,5 +361,5 @@ spliceAnns = expandStyles :: [(ExpandStyle, T.Text, CommandId)] expandStyles = [ (Inplace, inplaceCmdName, expandInplaceId) - , (Commented, commentedCmdName, expandCommentedId) + -- , (Commented, commentedCmdName, expandCommentedId) ] From 7d050c6fc44c2c87e34aaf2962a9b1baf9a0c616 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:02:00 +0900 Subject: [PATCH 11/51] kills redundant imports --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 07eba581a0..4c8dda532a 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -48,7 +48,6 @@ import Ide.Plugin.Splice.Types import Ide.TreeTransform import Ide.Types import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) -import qualified Language.Haskell.GHC.ExactPrint.Parsers as Exact import Language.Haskell.LSP.Core import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types From 05e4d7dd57943128cc6b1d58e571eafe836330c7 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:34:11 +0900 Subject: [PATCH 12/51] Updates cabal.project --- cabal.project | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cabal.project b/cabal.project index 2a53ab0e8d..c34d1d8a47 100644 --- a/cabal.project +++ b/cabal.project @@ -4,12 +4,14 @@ packages: ./shake-bench ./ghcide ./hls-plugin-api + ./hls-exactprint-utils ./plugins/tactics ./plugins/hls-class-plugin ./plugins/hls-eval-plugin ./plugins/hls-explicit-imports-plugin ./plugins/hls-hlint-plugin ./plugins/hls-retrie-plugin + ./plugins/hls-splice-plugin tests: true From cfca363d60b08a60b69fee1046c57c4126f30202 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:39:55 +0900 Subject: [PATCH 13/51] Nix fix --- nix/default.nix | 2 ++ shell.nix | 2 ++ 2 files changed, 4 insertions(+) diff --git a/nix/default.nix b/nix/default.nix index 17e424f118..1523e7694b 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -20,11 +20,13 @@ let shake-bench = gitignoreSource ../shake-bench; hie-compat = gitignoreSource ../hie-compat; hls-plugin-api = gitignoreSource ../hls-plugin-api; + hls-plugin-api = gitignoreSource ../hls-exactprint-utils; hls-class-plugin = gitignoreSource ../plugins/hls-class-plugin; hls-eval-plugin = gitignoreSource ../plugins/hls-eval-plugin; hls-explicit-imports-plugin = gitignoreSource ../plugins/hls-explicit-imports-plugin; hls-hlint-plugin = gitignoreSource ../plugins/hls-hlint-plugin; hls-retrie-plugin = gitignoreSource ../plugins/hls-retrie-plugin; + hls-splice-plugin = gitignoreSource ../plugins/hls-splice-plugin; hls-tactics-plugin = gitignoreSource ../plugins/tactics; }); in diff --git a/shell.nix b/shell.nix index 8c1a0f626a..f0f5ce9b88 100644 --- a/shell.nix +++ b/shell.nix @@ -29,11 +29,13 @@ let defaultCompiler = "ghc" + lib.replaceStrings ["."] [""] haskellPackages.ghc. p.shake-bench p.hie-compat p.hls-plugin-api + p.hls-exactprint-utils p.hls-class-plugin p.hls-eval-plugin p.hls-explicit-imports-plugin p.hls-hlint-plugin p.hls-retrie-plugin + p.hls-splice-plugin p.hls-tactics-plugin ]; From 520fdfd4acd5fd51e7d57c6e7a1adc6b6f57090c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:42:30 +0900 Subject: [PATCH 14/51] Nix fix, fix --- nix/default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/default.nix b/nix/default.nix index 1523e7694b..a4fc866ca7 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -20,7 +20,7 @@ let shake-bench = gitignoreSource ../shake-bench; hie-compat = gitignoreSource ../hie-compat; hls-plugin-api = gitignoreSource ../hls-plugin-api; - hls-plugin-api = gitignoreSource ../hls-exactprint-utils; + hls-exactprint-utils = gitignoreSource ../hls-exactprint-utils; hls-class-plugin = gitignoreSource ../plugins/hls-class-plugin; hls-eval-plugin = gitignoreSource ../plugins/hls-eval-plugin; hls-explicit-imports-plugin = gitignoreSource ../plugins/hls-explicit-imports-plugin; From 107519cacfc00fb8c692dbe0488b4a85d2492608 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 04:52:19 +0900 Subject: [PATCH 15/51] Throws away loading hacks entirely --- .../src/Ide/Plugin/Splice.hs | 34 ++----------------- 1 file changed, 2 insertions(+), 32 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 4c8dda532a..874c3b1144 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -102,38 +102,8 @@ expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = lift $ runAction "expandTHSplice.ghcSessionDeps" ideState $ use_ GhcSessionDeps fp - let hscEnv0 = hscEnvWithImportPaths hscEnvEq - modSum = pm_mod_summary pm - hscEnv <- lift $ - evalGhcEnv hscEnv0 $ do - env <- getSession - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts modSum - - let impPaths = fromMaybe (importPaths df) (envImportPaths hscEnvEq) - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df {importPaths = impPaths} - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - setInteractiveDynFlags $ - idflags - { pkgState = pkgState df - , pkgDatabase = pkgDatabase df - , packageFlags = packageFlags df - , useColor = Never - , canUseColor = False - } - env' <- getSession - -- setTargets [thisModuleTarget] - resl <- load LoadAllTargets - case resl of - Succeeded -> do - setContext [IIModule $ moduleName $ ms_mod modSum] - `gcatch` \(_ :: SomeException) -> pure () - getSession - Failed -> pure env' - let srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp + let hscEnv = hscEnvWithImportPaths hscEnvEq + srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp ((warns, errs), mEdits) <- calculateEdits lsp ps hscEnv tmrTypechecked srcSpan eStyle params unless (null errs) $ reportEditor From 1d4ea8f241dcd482075faed7aa16a0dbc36b35f0 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 15:40:57 +0900 Subject: [PATCH 16/51] Type adjusted for inverse dependency --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 874c3b1144..fe10273004 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -39,12 +39,12 @@ import Exception (gtry) import GHC.Exts import GhcMonad import GhcPlugins hiding (Var, getLoc, (<>)) -import Ide.Plugin import Ide.Plugin.Splice.Types ( ExpandSpliceParams (..), ExpandStyle (..), SpliceContext (..), ) +import Ide.PluginUtils (mkLspCommand) import Ide.TreeTransform import Ide.Types import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) @@ -56,7 +56,7 @@ import Retrie.ExactPrint (Annotated) import RnSplice import TcRnMonad -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands @@ -74,7 +74,7 @@ inplaceCmdName = "expand TemplateHaskell Splice (in-place)" commentedCmdName :: T.Text commentedCmdName = "expand TemplateHaskell Splice (comented-out)" -commands :: [PluginCommand] +commands :: [PluginCommand IdeState] commands = [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented @@ -83,7 +83,7 @@ commands = expandTHSplice :: -- | Inplace? ExpandStyle -> - CommandFunction ExpandSpliceParams + CommandFunction IdeState ExpandSpliceParams expandTHSplice eStyle lsp ideState params@ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do @@ -258,7 +258,7 @@ unRenamedE dflags expr = do -- 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 +codeAction :: CodeActionProvider IdeState codeAction _ state plId docId range0 _ = fmap (maybe (Right $ List []) Right) $ runMaybeT $ do From 4ca09d213d6b844654773907954259742fbe28c2 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 17:12:51 +0900 Subject: [PATCH 17/51] Resolves merge conflicts --- exe/Plugins.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 00f1c79a03..ed81373075 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +module Plugins where import Ide.Types (IdePlugins) import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Plugin (pluginDescToIdePlugins) -- fixed plugins import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 @@ -45,11 +45,10 @@ import Ide.Plugin.ModuleName as ModuleName import Ide.Plugin.Pragmas as Pragmas #endif -#if defined(splice) -import Ide.Plugin.Splice as Splice +#if splice +import Ide.Plugin.Splice as Splice #endif - -- formatters #if floskell @@ -81,7 +80,7 @@ import Ide.Plugin.Brittany as Brittany idePlugins :: Bool -> IdePlugins IdeState idePlugins includeExamples = pluginDescToIdePlugins allPlugins - where + where allPlugins = if includeExamples then basePlugins ++ examplePlugins else basePlugins @@ -126,7 +125,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if hlint , Hlint.descriptor "hlint" #endif -#if defined(splice) +#if splice , Splice.descriptor "splice" #endif ] From 1624f76f04719703543d909b5e41c16b62ca7776 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 5 Oct 2020 17:25:51 +0100 Subject: [PATCH 18/51] WIP: Support hover and goto definition for top-level splices I can't work out how to properly integrate this information into the .hie file machinery. Perhaps it would be better to upstream this. --- ghcide/src/Development/IDE/Core/Compile.hs | 38 ++++++++++++++++---- ghcide/src/Development/IDE/Core/RuleTypes.hs | 1 + 2 files changed, 32 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 86401c2c9f..63cb273492 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -71,6 +71,8 @@ import StringBuffer as SB import TcRnMonad import TcIface (typecheckIface) import TidyPgm +import Hooks +import TcSplice import Control.Exception.Safe import Control.Monad.Extra @@ -85,7 +87,7 @@ import Data.Maybe import qualified Data.Map.Strict as Map import System.FilePath import System.Directory -import System.IO.Extra +import System.IO.Extra ( fixIO, newTempFileWithin ) import Control.Exception (evaluate) import TcEnv (tcLookup) import Data.Time (UTCTime, getCurrentTime) @@ -144,21 +146,43 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id +-- | Add a Hook to the DynFlags which captures and returns the +-- typechecked splices before they are run. This information +-- is used for hover. +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, [LHsExpr GhcTc]) +captureSplices dflags k = do + splice_ref <- newIORef [] + res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) + splices <- readIORef splice_ref + return (res, splices) + where + addSpliceHook :: IORef [LHsExpr GhcTc] -> Hooks -> Hooks + addSpliceHook var h = h { runMetaHook = Just (splice_hook var) } + + splice_hook :: IORef [LHsExpr GhcTc] -> MetaRequest -> LHsExpr GhcTc -> TcM MetaResult + splice_hook var mr e = do + liftIO $ modifyIORef var (e:) + pprTraceM "expr" (ppr e) + defaultRunMeta mr e + tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } unload hsc_env_tmp keep_lbls - (tc_gbl_env, mrn_info) <- - hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } + + ((tc_gbl_env, mrn_info), splices) + <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> + do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } + hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } let rn_info = case mrn_info of Just x -> x Nothing -> error "no renamed info tcRnModule" - pure (TcModuleResult pmod rn_info tc_gbl_env False) + pure (TcModuleResult pmod rn_info tc_gbl_env splices False) mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 86bf2a75c9..7d095f0085 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -96,6 +96,7 @@ data TcModuleResult = TcModuleResult { tmrParsed :: ParsedModule , tmrRenamed :: RenamedSource , tmrTypechecked :: TcGblEnv + , tmrTopLevelSplices :: [LHsExpr GhcTc] -- ^ Typechecked top-level splices from this module , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? } instance Show TcModuleResult where From 217f69b3fe4e6490fa5fef716db8f9f34de41407 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 18:35:24 +0900 Subject: [PATCH 19/51] Modifies splice information to store both spliced expression and expanded ones as well --- ghcide/src/Development/IDE/Core/Compile.hs | 45 ++++++++++++++++---- ghcide/src/Development/IDE/Core/RuleTypes.hs | 34 ++++++++++++++- 2 files changed, 70 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 63cb273492..a767ac3fe1 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -75,6 +75,7 @@ import Hooks import TcSplice import Control.Exception.Safe +import Control.Lens hiding (List) import Control.Monad.Extra import Control.Monad.Except import Control.Monad.Trans.Except @@ -149,21 +150,49 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover. -captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, [LHsExpr GhcTc]) +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, SpliceInfo) captureSplices dflags k = do - splice_ref <- newIORef [] + splice_ref <- newIORef mempty res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) splices <- readIORef splice_ref return (res, splices) where - addSpliceHook :: IORef [LHsExpr GhcTc] -> Hooks -> Hooks + addSpliceHook :: IORef SpliceInfo -> Hooks -> Hooks addSpliceHook var h = h { runMetaHook = Just (splice_hook var) } - splice_hook :: IORef [LHsExpr GhcTc] -> MetaRequest -> LHsExpr GhcTc -> TcM MetaResult - splice_hook var mr e = do - liftIO $ modifyIORef var (e:) - pprTraceM "expr" (ppr e) - defaultRunMeta mr e + splice_hook :: IORef SpliceInfo -> MetaHook TcM + splice_hook var metaReq e = case metaReq of + (MetaE f) -> do + expr' <- metaRequestE defaultRunMeta e + liftIO $ + modifyIORef' var $ + exprSplicesL %~ ((e, expr'):) + pure $ f expr' + (MetaP f) -> do + pat' <- metaRequestP defaultRunMeta e + liftIO $ + modifyIORef' var $ + patSplicesL %~ ((e, pat'):) + pure $ f pat' + (MetaT f) -> do + type' <- metaRequestT defaultRunMeta e + liftIO $ + modifyIORef' var $ + typeSplicesL %~ ((e, type'):) + pure $ f type' + (MetaD f) -> do + decl' <- metaRequestD defaultRunMeta e + liftIO $ + modifyIORef' var $ + declSplicesL %~ ((e, decl'):) + pure $ f decl' + (MetaAW f) -> do + aw' <- metaRequestAW defaultRunMeta e + liftIO $ + modifyIORef' var $ + awSplicesL %~ ((e, aw'):) + pure $ f aw' + tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 7d095f0085..131271b1b6 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} @@ -36,10 +37,12 @@ import Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString) import Language.Haskell.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) +import Control.Lens import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Options (IdeGhcSession) import Data.Text (Text) import Data.Int (Int64) +import GHC.Serialized (Serialized) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show) @@ -90,13 +93,38 @@ newtype ImportMap = ImportMap } deriving stock Show deriving newtype NFData +data SpliceInfo = SpliceInfo + { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] + , patSplices :: [(LHsExpr GhcTc, LPat GhcPs)] + , typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)] + , declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])] + , awSplices :: [(LHsExpr GhcTc, Serialized)] + } + +instance Semigroup SpliceInfo where + SpliceInfo e p t d aw <> SpliceInfo e' p' t' d' aw' = + SpliceInfo + (e <> e') + (p <> p') + (t <> t') + (d <> d') + (aw <> aw') + +instance Monoid SpliceInfo where + mempty = SpliceInfo mempty mempty mempty mempty mempty + +instance NFData SpliceInfo where + rnf SpliceInfo{..} = + exprSplices `seq` patSplices `seq` typeSplices `seq` declSplices `seq` () + -- | Contains the typechecked module and the OrigNameCache entry for -- that module. data TcModuleResult = TcModuleResult { tmrParsed :: ParsedModule , tmrRenamed :: RenamedSource , tmrTypechecked :: TcGblEnv - , tmrTopLevelSplices :: [LHsExpr GhcTc] -- ^ Typechecked top-level splices from this module + , tmrTopLevelSplices :: SpliceInfo + -- ^ Typechecked splice information , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? } instance Show TcModuleResult where @@ -399,3 +427,7 @@ data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO instance Binary GhcSessionIO + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''SpliceInfo From 7e2d4a9d5ef2288bf2d3bf9836ff52848c8cae28 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 18:43:15 +0900 Subject: [PATCH 20/51] Avoid name collision --- ghcide/src/Development/IDE/Core/Compile.hs | 8 +- ghcide/src/Development/IDE/Core/RuleTypes.hs | 401 ++++++++++++------- 2 files changed, 253 insertions(+), 156 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index a767ac3fe1..716e765bff 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -150,17 +150,17 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover. -captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, SpliceInfo) +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) captureSplices dflags k = do splice_ref <- newIORef mempty res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) splices <- readIORef splice_ref return (res, splices) where - addSpliceHook :: IORef SpliceInfo -> Hooks -> Hooks + addSpliceHook :: IORef Splices -> Hooks -> Hooks addSpliceHook var h = h { runMetaHook = Just (splice_hook var) } - splice_hook :: IORef SpliceInfo -> MetaHook TcM + splice_hook :: IORef Splices -> MetaHook TcM splice_hook var metaReq e = case metaReq of (MetaE f) -> do expr' <- metaRequestE defaultRunMeta e @@ -200,7 +200,7 @@ tcRnModule hsc_env keep_lbls pmod = do hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } unload hsc_env_tmp keep_lbls - + ((tc_gbl_env, mrn_info), splices) <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 131271b1b6..eed95b5eae 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -1,51 +1,49 @@ +{-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingStrategies #-} --- | A Shake implementation of the compiler service, built --- using the "Shaker" abstraction layer for in-memory use. --- -module Development.IDE.Core.RuleTypes( - module Development.IDE.Core.RuleTypes - ) where +{- | A Shake implementation of the compiler service, built + using the "Shaker" abstraction layer for in-memory use. +-} +module Development.IDE.Core.RuleTypes + ( module Development.IDE.Core.RuleTypes, + ) +where -import Control.DeepSeq +import Control.DeepSeq +import Control.Lens import Data.Aeson.Types (Value) import Data.Binary -import Development.IDE.Import.DependencyInformation +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Hashable +import Data.Int (Int64) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Text (Text) +import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util +import Development.IDE.Import.DependencyInformation +import Development.IDE.Import.FindImports (ArtifactsLocation) +import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings import Development.IDE.Types.KnownTargets -import Data.Hashable -import Data.Typeable -import qualified Data.Set as S -import qualified Data.Map as M -import Development.Shake -import GHC.Generics (Generic) - -import Module (InstalledUnitId) -import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) - -import Development.IDE.Spans.Common -import Development.IDE.Spans.LocalBindings -import Development.IDE.Import.FindImports (ArtifactsLocation) -import Data.ByteString (ByteString) -import Language.Haskell.LSP.Types (NormalizedFilePath) -import TcRnMonad (TcGblEnv) -import Control.Lens -import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Options (IdeGhcSession) -import Data.Text (Text) -import Data.Int (Int64) +import Development.Shake +import GHC.Generics (Generic) import GHC.Serialized (Serialized) +import HscTypes (HomeModInfo, ModGuts, hm_iface, hm_linkable) +import Language.Haskell.LSP.Types (NormalizedFilePath) +import Module (InstalledUnitId) +import TcRnMonad (TcGblEnv) data LinkableType = ObjectLinkable | BCOLinkable - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) -- NOTATION -- Foo+ means Foo for the dependencies @@ -54,22 +52,28 @@ data LinkableType = ObjectLinkable | BCOLinkable -- | The parse tree for the file using GetFileContents type instance RuleResult GetParsedModule = ParsedModule --- | The dependency information produced by following the imports recursively. --- This rule will succeed even if there is an error, e.g., a module could not be located, --- a module could not be parsed or an import cycle. +{- | The dependency information produced by following the imports recursively. + This rule will succeed even if there is an error, e.g., a module could not be located, + a module could not be parsed or an import cycle. +-} type instance RuleResult GetDependencyInformation = DependencyInformation --- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. --- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. +{- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. + This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. +-} type instance RuleResult GetDependencies = TransitiveDependencies type instance RuleResult GetModuleGraph = DependencyInformation data GetKnownTargets = GetKnownTargets - deriving (Show, Generic, Eq, Ord) + deriving (Show, Generic, Eq, Ord) + instance Hashable GetKnownTargets -instance NFData GetKnownTargets -instance Binary GetKnownTargets + +instance NFData GetKnownTargets + +instance Binary GetKnownTargets + type instance RuleResult GetKnownTargets = KnownTargets -- | Convert to Core, requires TypeCheck* @@ -77,23 +81,32 @@ type instance RuleResult GenerateCore = ModGuts data GenerateCore = GenerateCore deriving (Eq, Show, Typeable, Generic) + instance Hashable GenerateCore -instance NFData GenerateCore -instance Binary GenerateCore + +instance NFData GenerateCore + +instance Binary GenerateCore data GetImportMap = GetImportMap deriving (Eq, Show, Typeable, Generic) + instance Hashable GetImportMap -instance NFData GetImportMap -instance Binary GetImportMap + +instance NFData GetImportMap + +instance Binary GetImportMap type instance RuleResult GetImportMap = ImportMap + newtype ImportMap = ImportMap - { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? - } deriving stock Show - deriving newtype NFData + { -- | Where are the modules imported by this file located? + importMap :: M.Map ModuleName NormalizedFilePath + } + deriving stock (Show) + deriving newtype (NFData) -data SpliceInfo = SpliceInfo +data Splices = Splices { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] , patSplices :: [(LHsExpr GhcTc, LPat GhcPs)] , typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)] @@ -101,32 +114,35 @@ data SpliceInfo = SpliceInfo , awSplices :: [(LHsExpr GhcTc, Serialized)] } -instance Semigroup SpliceInfo where - SpliceInfo e p t d aw <> SpliceInfo e' p' t' d' aw' = - SpliceInfo +instance Semigroup Splices where + Splices e p t d aw <> Splices e' p' t' d' aw' = + Splices (e <> e') (p <> p') (t <> t') (d <> d') (aw <> aw') -instance Monoid SpliceInfo where - mempty = SpliceInfo mempty mempty mempty mempty mempty +instance Monoid Splices where + mempty = Splices mempty mempty mempty mempty mempty -instance NFData SpliceInfo where - rnf SpliceInfo{..} = - exprSplices `seq` patSplices `seq` typeSplices `seq` declSplices `seq` () +instance NFData Splices where + rnf Splices {..} = + exprSplices `seq` patSplices `seq` typeSplices `seq` declSplices `seq` () --- | Contains the typechecked module and the OrigNameCache entry for --- that module. +{- | Contains the typechecked module and the OrigNameCache entry for + that module. +-} data TcModuleResult = TcModuleResult { tmrParsed :: ParsedModule , tmrRenamed :: RenamedSource , tmrTypechecked :: TcGblEnv - , tmrTopLevelSplices :: SpliceInfo - -- ^ Typechecked splice information - , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? + , -- | Typechecked splice information + tmrTopLevelSplices :: Splices + , -- | Did we defer any type errors for this module? + tmrDeferedError :: !Bool } + instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -138,19 +154,20 @@ tmrModSummary = pm_mod_summary . tmrParsed data HiFileResult = HiFileResult { hirModSummary :: !ModSummary - -- Bang patterns here are important to stop the result retaining - -- a reference to a typechecked module - , hirHomeMod :: !HomeModInfo - -- ^ Includes the Linkable iff we need object files + , -- Bang patterns here are important to stop the result retaining + -- a reference to a typechecked module + + -- | Includes the Linkable iff we need object files + hirHomeMod :: !HomeModInfo } hiFileFingerPrint :: HiFileResult -> ByteString hiFileFingerPrint hfr = ifaceBS <> linkableBS - where - ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes - linkableBS = case hm_linkable $ hirHomeMod hfr of - Nothing -> "" - Just l -> BS.pack $ show $ linkableTime l + where + ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes + linkableBS = case hm_linkable $ hirHomeMod hfr of + Nothing -> "" + Just l -> BS.pack $ show $ linkableTime l hirModIface :: HiFileResult -> ModIface hirModIface = hm_iface . hirHomeMod @@ -162,15 +179,14 @@ instance Show HiFileResult where show = show . hirModSummary -- | Save the uncompressed AST here, we compress it just before writing to disk -data HieAstResult - = HAR - { hieModule :: Module - , hieAst :: !(HieASTs Type) - , refMap :: RefMap - -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type - -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same - -- as that of `hieAst` - } +data HieAstResult = HAR + { hieModule :: Module + , hieAst :: !(HieASTs Type) + , -- | Lazy because its value only depends on the hieAst, which is bundled in this type + -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same + -- as that of `hieAst` + refMap :: RefMap + } instance NFData HieAstResult where rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf @@ -188,6 +204,7 @@ type instance RuleResult GetHieAst = HieAstResult type instance RuleResult GetBindings = Bindings data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} + instance NFData DocAndKindMap where rnf (DKMap a b) = rwhnf a `seq` rwhnf b @@ -202,24 +219,28 @@ type instance RuleResult GhcSession = HscEnvEq -- | A GHC session preloaded with all the dependencies type instance RuleResult GhcSessionDeps = HscEnvEq --- | Resolve the imports in a module to the file path of a module --- in the same package or the package id of another package. +{- | Resolve the imports in a module to the file path of a module + in the same package or the package id of another package. +-} type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId) --- | This rule is used to report import cycles. It depends on GetDependencyInformation. --- We cannot report the cycles directly from GetDependencyInformation since --- we can only report diagnostics for the current file. +{- | This rule is used to report import cycles. It depends on GetDependencyInformation. + We cannot report the cycles directly from GetDependencyInformation since + we can only report diagnostics for the current file. +-} type instance RuleResult ReportImportCycles = () --- | Read the module interface file from disk. Throws an error for VFS files. --- This is an internal rule, use 'GetModIface' instead. +{- | Read the module interface file from disk. Throws an error for VFS files. + This is an internal rule, use 'GetModIface' instead. +-} type instance RuleResult GetModIfaceFromDisk = HiFileResult -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult --- | Get a module interface details, without the Linkable --- For better early cuttoff +{- | Get a module interface details, without the Linkable + For better early cuttoff +-} type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. @@ -227,8 +248,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text) -- The Shake key type for getModificationTime queries data GetModificationTime = GetModificationTime_ - { missingFileDiagnostics :: Bool - -- ^ If false, missing file diagnostics are not reported + { -- | If false, missing file diagnostics are not reported + missingFileDiagnostics :: Bool } deriving (Show, Generic) @@ -242,11 +263,12 @@ instance Hashable GetModificationTime where -- independent from the 'missingFileDiagnostics' field hashWithSalt salt _ = salt -instance NFData GetModificationTime -instance Binary GetModificationTime +instance NFData GetModificationTime + +instance Binary GetModificationTime pattern GetModificationTime :: GetModificationTime -pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} +pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics = True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion @@ -254,167 +276,239 @@ type instance RuleResult GetModificationTime = FileVersion data FileVersion = VFSVersion !Int | ModificationTime - !Int64 -- ^ Large unit (platform dependent, do not make assumptions) - !Int64 -- ^ Small unit (platform dependent, do not make assumptions) + !Int64 + -- ^ Large unit (platform dependent, do not make assumptions) + !Int64 + -- ^ Small unit (platform dependent, do not make assumptions) deriving (Show, Generic) instance NFData FileVersion vfsVersion :: FileVersion -> Maybe Int vfsVersion (VFSVersion i) = Just i -vfsVersion ModificationTime{} = Nothing +vfsVersion ModificationTime {} = Nothing data GetFileContents = GetFileContents deriving (Eq, Show, Generic) + instance Hashable GetFileContents -instance NFData GetFileContents -instance Binary GetFileContents +instance NFData GetFileContents + +instance Binary GetFileContents data FileOfInterestStatus = OnDisk | Modified - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Typeable, Generic) + instance Hashable FileOfInterestStatus -instance NFData FileOfInterestStatus -instance Binary FileOfInterestStatus + +instance NFData FileOfInterestStatus + +instance Binary FileOfInterestStatus data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Typeable, Generic) + instance Hashable IsFileOfInterestResult -instance NFData IsFileOfInterestResult -instance Binary IsFileOfInterestResult + +instance NFData IsFileOfInterestResult + +instance Binary IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult --- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. --- without needing to parse the entire source -type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs]) +{- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. + without needing to parse the entire source +-} +type instance RuleResult GetModSummary = (ModSummary, [LImportDecl GhcPs]) --- | Generate a ModSummary with the timestamps elided, --- for more successful early cutoff -type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs]) +{- | Generate a ModSummary with the timestamps elided, + for more successful early cutoff +-} +type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary, [LImportDecl GhcPs]) data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) + instance Hashable GetParsedModule -instance NFData GetParsedModule -instance Binary GetParsedModule + +instance NFData GetParsedModule + +instance Binary GetParsedModule data GetLocatedImports = GetLocatedImports deriving (Eq, Show, Typeable, Generic) + instance Hashable GetLocatedImports -instance NFData GetLocatedImports -instance Binary GetLocatedImports + +instance NFData GetLocatedImports + +instance Binary GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Bool data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Typeable, Generic) + instance Hashable NeedsCompilation -instance NFData NeedsCompilation -instance Binary NeedsCompilation + +instance NFData NeedsCompilation + +instance Binary NeedsCompilation data GetDependencyInformation = GetDependencyInformation deriving (Eq, Show, Typeable, Generic) + instance Hashable GetDependencyInformation -instance NFData GetDependencyInformation -instance Binary GetDependencyInformation + +instance NFData GetDependencyInformation + +instance Binary GetDependencyInformation data GetModuleGraph = GetModuleGraph deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModuleGraph -instance NFData GetModuleGraph -instance Binary GetModuleGraph + +instance NFData GetModuleGraph + +instance Binary GetModuleGraph data ReportImportCycles = ReportImportCycles deriving (Eq, Show, Typeable, Generic) + instance Hashable ReportImportCycles -instance NFData ReportImportCycles -instance Binary ReportImportCycles + +instance NFData ReportImportCycles + +instance Binary ReportImportCycles data GetDependencies = GetDependencies deriving (Eq, Show, Typeable, Generic) + instance Hashable GetDependencies -instance NFData GetDependencies -instance Binary GetDependencies + +instance NFData GetDependencies + +instance Binary GetDependencies data TypeCheck = TypeCheck deriving (Eq, Show, Typeable, Generic) + instance Hashable TypeCheck -instance NFData TypeCheck -instance Binary TypeCheck + +instance NFData TypeCheck + +instance Binary TypeCheck data GetDocMap = GetDocMap deriving (Eq, Show, Typeable, Generic) + instance Hashable GetDocMap -instance NFData GetDocMap -instance Binary GetDocMap + +instance NFData GetDocMap + +instance Binary GetDocMap data GetHieAst = GetHieAst deriving (Eq, Show, Typeable, Generic) + instance Hashable GetHieAst -instance NFData GetHieAst -instance Binary GetHieAst + +instance NFData GetHieAst + +instance Binary GetHieAst data GetBindings = GetBindings deriving (Eq, Show, Typeable, Generic) + instance Hashable GetBindings -instance NFData GetBindings -instance Binary GetBindings + +instance NFData GetBindings + +instance Binary GetBindings data GhcSession = GhcSession deriving (Eq, Show, Typeable, Generic) + instance Hashable GhcSession -instance NFData GhcSession -instance Binary GhcSession + +instance NFData GhcSession + +instance Binary GhcSession data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) + instance Hashable GhcSessionDeps -instance NFData GhcSessionDeps -instance Binary GhcSessionDeps + +instance NFData GhcSessionDeps + +instance Binary GhcSessionDeps data GetModIfaceFromDisk = GetModIfaceFromDisk deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModIfaceFromDisk -instance NFData GetModIfaceFromDisk -instance Binary GetModIfaceFromDisk + +instance NFData GetModIfaceFromDisk + +instance Binary GetModIfaceFromDisk data GetModIface = GetModIface deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModIface -instance NFData GetModIface -instance Binary GetModIface + +instance NFData GetModIface + +instance Binary GetModIface data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModIfaceWithoutLinkable -instance NFData GetModIfaceWithoutLinkable -instance Binary GetModIfaceWithoutLinkable + +instance NFData GetModIfaceWithoutLinkable + +instance Binary GetModIfaceWithoutLinkable data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) + instance Hashable IsFileOfInterest -instance NFData IsFileOfInterest -instance Binary IsFileOfInterest + +instance NFData IsFileOfInterest + +instance Binary IsFileOfInterest data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModSummaryWithoutTimestamps -instance NFData GetModSummaryWithoutTimestamps -instance Binary GetModSummaryWithoutTimestamps + +instance NFData GetModSummaryWithoutTimestamps + +instance Binary GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary deriving (Eq, Show, Typeable, Generic) + instance Hashable GetModSummary -instance NFData GetModSummary -instance Binary GetModSummary + +instance NFData GetModSummary + +instance Binary GetModSummary -- | Get the vscode client settings stored in the ide state data GetClientSettings = GetClientSettings deriving (Eq, Show, Typeable, Generic) + instance Hashable GetClientSettings -instance NFData GetClientSettings -instance Binary GetClientSettings + +instance NFData GetClientSettings + +instance Binary GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) @@ -424,10 +518,13 @@ type instance RuleResult GetClientSettings = Hashed (Maybe Value) type instance RuleResult GhcSessionIO = IdeGhcSession data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) + instance Hashable GhcSessionIO -instance NFData GhcSessionIO -instance Binary GhcSessionIO + +instance NFData GhcSessionIO + +instance Binary GhcSessionIO makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) - ''SpliceInfo + ''Splices From 1dab48bd6d4103840db5b95754d837ebd3db8892 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 18:51:16 +0900 Subject: [PATCH 21/51] formatting erros --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index eed95b5eae..86f906a038 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} From 6bcb18a97005357d47190bfe3b24c4764dcfdf10 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 19:02:27 +0900 Subject: [PATCH 22/51] Safer error handling --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 78 +++++++++++++++---- 1 file changed, 61 insertions(+), 17 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 9da5f4dcf8..e9b11f841f 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -8,19 +10,28 @@ module Ide.TreeTransform ( Graft, graft, + hoistGraft, graftWithM, graftWithSmallestM, transform, transformM, useAnnotatedSource, - ASTElement(..), + annotateParsedSource, + ASTElement (..), + ExceptStringT (..), ) where import BasicTypes (appPrec) +import Control.Applicative (Alternative) 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.Functor.Classes +import Data.Functor.Contravariant import qualified Data.Text as T import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules @@ -34,7 +45,7 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) import Outputable -import Retrie.ExactPrint hiding (parseExpr, parsePattern, parseType, parseDecl) +import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) ------------------------------------------------------------------------------ @@ -44,9 +55,12 @@ useAnnotatedSource :: IdeState -> NormalizedFilePath -> IO (Maybe (Annotated ParsedSource)) -useAnnotatedSource herald state nfp = do - pm <- runAction herald state $ use GetParsedModule nfp - pure $ fmap fixAnns pm +useAnnotatedSource herald state nfp = + fmap annotateParsedSource + <$> runAction herald state (use GetParsedModule nfp) + +annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource = fixAnns ------------------------------------------------------------------------------ @@ -57,6 +71,34 @@ 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 @@ -87,14 +129,15 @@ transformM :: DynFlags -> ClientCapabilities -> Uri -> - Graft m ParsedSource -> + Graft (ExceptStringT m) ParsedSource -> Annotated ParsedSource -> - m WorkspaceEdit -transformM 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 + 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 ------------------------------------------------------------------------------ @@ -103,19 +146,19 @@ transformM dflags ccs uri f a = do this is a no-op. -} graft :: - forall a. - Data a => + forall ast a. + (Data a, ASTElement ast) => SrcSpan -> - LHsExpr GhcPs -> + Located ast -> Graft (Either String) a graft dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags $ parenthesize val + (anns, val') <- annotate dflags $ maybeParensAST val modifyAnnsT $ mappend anns pure $ everywhere' ( mkT $ \case - (L src _ :: LHsExpr GhcPs) | src == dst -> val' + (L src _ :: Located ast) | src == dst -> val' l -> l ) a @@ -199,6 +242,7 @@ instance p ~ GhcPs => ASTElement (HsDecl p) where maybeParensAST = id ------------------------------------------------------------------------------ + -- | Dark magic I stole from retrie. No idea what it does. fixAnns :: ParsedModule -> Annotated ParsedSource fixAnns ParsedModule {..} = From a915a1fa04f2cf9516f5ff804c44c86454becb9e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 19:02:58 +0900 Subject: [PATCH 23/51] Rewrote using updated ghcide `TypeCheck` results --- .../src/Ide/Plugin/Splice.hs | 193 ++++++------------ 1 file changed, 65 insertions(+), 128 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index fe10273004..646b62b651 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -15,9 +15,7 @@ module Ide.Plugin.Splice ) where -import Control.Arrow (Arrow (first)) -import Control.Exception (SomeException) -import Control.Lens (ifoldMap, (<&>), (^.)) +import Control.Lens (ifoldMap, (^.)) import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class @@ -25,8 +23,10 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.CPS import Data.Aeson import qualified Data.DList as DL +import Data.Function import qualified Data.Kind as Kinds -import Data.Maybe (fromMaybe) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Monoid (Ap (..)) import Data.Set (Set) import qualified Data.Set as Set @@ -34,17 +34,11 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getLoc) -import ErrUtils (ErrorMessages, WarningMessages) -import Exception (gtry) import GHC.Exts import GhcMonad import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Plugin.Splice.Types - ( ExpandSpliceParams (..), - ExpandStyle (..), - SpliceContext (..), - ) -import Ide.PluginUtils (mkLspCommand) +import Ide.PluginUtils (mkLspCommand, responseError) import Ide.TreeTransform import Ide.Types import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) @@ -52,8 +46,6 @@ 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 descriptor :: PluginId -> PluginDescriptor IdeState @@ -80,131 +72,100 @@ commands = -- , 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 {..} = +expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri - TcModuleResult {tmrParsed = pm, ..} <- + TcModuleResult {..} <- MaybeT $ runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp - ps <- - MaybeT $ - useAnnotatedSource - "expandTHSplice.AnnotedSource" - ideState - fp + let ps = annotateParsedSource tmrParsed + Splices {..} = tmrTopLevelSplices hscEnvEq <- lift $ runAction "expandTHSplice.ghcSessionDeps" ideState $ use_ GhcSessionDeps fp - let hscEnv = hscEnvWithImportPaths hscEnvEq - srcSpan = rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp - ((warns, errs), mEdits) <- calculateEdits lsp ps hscEnv tmrTypechecked srcSpan eStyle params - unless (null errs) $ - reportEditor - lsp - MtError - [ "Error during expanding splice:" - , T.pack $ show errs - ] - guard $ null errs - unless (null warns) $ - reportEditor - lsp - MtWarning - [ "Warning during expanding splice:" - , T.pack $ show warns - ] - pure - ( Right Null - , mEdits <&> \edits -> - (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) - ) + let dflags = hsc_dflags $ hscEnv hscEnvEq + srcSpan = + RealSrcSpan $ + rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp + exprSuperSpans = + listToMaybe $ findSuperSpansAsc srcSpan exprSplices + patSuperSpans = + listToMaybe $ findSuperSpansAsc srcSpan patSplices + typeSuperSpans = + listToMaybe $ findSuperSpansAsc srcSpan typeSplices + + graftSpliceWith :: + forall ast. + HasSplice ast => + Maybe (SrcSpan, Located (ast GhcPs)) -> + MaybeT IO (Maybe (Either String WorkspaceEdit)) + graftSpliceWith expandeds = forM expandeds $ \(loc, expanded) -> + transformM + dflags + (clientCapabilities lsp) + uri + ( graftWithSmallestM + loc + $ \case + (L _ (matchSplice @ast proxy# -> Just {})) -> pure $ Just expanded + _ -> pure Nothing + ) + ps + eedits <- + join . maybe (Left "No splcie information found") Right <$> case spliceContext of + Expr -> graftSpliceWith exprSuperSpans + Pat -> graftSpliceWith patSuperSpans + HsType -> graftSpliceWith typeSuperSpans + pure $ case eedits of + Left err -> + (Left $ responseError $ T.pack err, Nothing) + Right edits -> + ( Right Null + , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) + ) where defaultResult = (Right Null, Nothing) -data SomeHasSplice where - MkSomeHasSplice :: HasSplice ast => Proxy# ast -> SomeHasSplice +findSuperSpansAsc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] +findSuperSpansAsc srcSpan = + sortOn (SubSpan . fst) + . mapMaybe + ( \(L spn _, e) -> do + guard (srcSpan `isSubspanOf` spn) + pure (spn, e) + ) 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) - renameSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) instance HasSplice HsExpr where matchSplice _ (HsSpliceE _ spl) = Just spl matchSplice _ _ = Nothing - renameSplice _ = fmap (first Right) . rnSpliceExpr -{- -instance HasSplice HsDecl where - type SpliceOf HsDecl = SpliceDecl - matchSplice _ (SpliceD _ decl) = Just decl - matchSplice _ _ = Nothing - renameSplice (SpliceDecl _ (L _ spl) flg) = - case flg of - ImplicitSplice -> - rnTopSpliceDecls spl - -} instance HasSplice Pat where matchSplice _ (SplicePat _ spl) = Just spl matchSplice _ _ = Nothing - renameSplice _ = rnSplicePat instance HasSplice HsType where matchSplice _ (HsSpliceTy _ spl) = Just spl matchSplice _ _ = Nothing - renameSplice _ = fmap (first Right) . rnSpliceType - -toSomeASTElement :: SpliceContext -> SomeHasSplice -toSomeASTElement = \case - Expr -> MkSomeHasSplice @HsExpr proxy# - -- HsDecl -> MkSomeHasSplice @HsDecl proxy# - Pat -> MkSomeHasSplice @Pat proxy# - HsType -> MkSomeHasSplice @HsType proxy# - -calculateEdits :: - LspFuncs a -> - Annotated ParsedSource -> - HscEnv -> - TcGblEnv -> - RealSrcSpan -> - ExpandStyle -> - ExpandSpliceParams -> - MaybeT IO ((WarningMessages, ErrorMessages), Maybe WorkspaceEdit) -calculateEdits lsp ps hscEnv typechkd srcSpan eStyle ExpandSpliceParams {..} = - liftIO $ - initTcWithGbl hscEnv typechkd srcSpan $ - case toSomeASTElement spliceContext of - MkSomeHasSplice astP -> - flip (transformM dflags (clientCapabilities lsp) uri) ps $ - graftWithSmallestM (RealSrcSpan srcSpan) $ \case - (L _spn (matchSplice astP -> Just spl)) -> do - eExpr <- lift $ gtry @_ @SomeException (fst <$> renameSplice astP spl) - case (eExpr, eStyle) of - (Left exc, _) -> - lift $ - Nothing - <$ reportEditor - lsp - MtError - [ "Error during expanding splice" - , "" - , T.pack (show exc) - ] - (Right expr', Inplace) -> - Just <$> either (pure . L _spn) (unRenamedE dflags) expr' - (Right _expr', Commented) -> - pure Nothing - _ -> pure Nothing - where - dflags = hsc_dflags hscEnv -- | FIXME: Is thereAny "clever" way to do this exploiting TTG? reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () @@ -216,30 +177,6 @@ reportEditor lsp msgTy msgs = ShowMessageParams msgTy $ T.unlines msgs -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 - unRenamedE :: forall ast m. (Fail.MonadFail m, HasSplice ast) => From 794b77118d2e79129fe0b7ac61d7ed6e4c9ce70c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 19:18:39 +0900 Subject: [PATCH 24/51] Use `liftRnf rwhnf` to force spine of lists --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 86f906a038..6ec36d6f59 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -129,7 +129,9 @@ instance Monoid Splices where instance NFData Splices where rnf Splices {..} = - exprSplices `seq` patSplices `seq` typeSplices `seq` declSplices `seq` () + liftRnf rwhnf exprSplices `seq` + liftRnf rwhnf patSplices `seq` + liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` () {- | Contains the typechecked module and the OrigNameCache entry for that module. From 9cf55c4d6e96dcae0022bd20a8fb56e9afe9a867 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 19:24:46 +0900 Subject: [PATCH 25/51] Stop using `defaultRunMeta` directly to avoid override of preexisting hooks --- ghcide/src/Development/IDE/Core/Compile.hs | 36 ++++++++-------------- 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 716e765bff..dc669d732b 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -158,39 +158,29 @@ captureSplices dflags k = do return (res, splices) where addSpliceHook :: IORef Splices -> Hooks -> Hooks - addSpliceHook var h = h { runMetaHook = Just (splice_hook var) } + addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } - splice_hook :: IORef Splices -> MetaHook TcM - splice_hook var metaReq e = case metaReq of + splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM + splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of (MetaE f) -> do - expr' <- metaRequestE defaultRunMeta e - liftIO $ - modifyIORef' var $ - exprSplicesL %~ ((e, expr'):) + expr' <- metaRequestE hook e + liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :) pure $ f expr' (MetaP f) -> do - pat' <- metaRequestP defaultRunMeta e - liftIO $ - modifyIORef' var $ - patSplicesL %~ ((e, pat'):) + pat' <- metaRequestP hook e + liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :) pure $ f pat' (MetaT f) -> do - type' <- metaRequestT defaultRunMeta e - liftIO $ - modifyIORef' var $ - typeSplicesL %~ ((e, type'):) + type' <- metaRequestT hook e + liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :) pure $ f type' (MetaD f) -> do - decl' <- metaRequestD defaultRunMeta e - liftIO $ - modifyIORef' var $ - declSplicesL %~ ((e, decl'):) + decl' <- metaRequestD hook e + liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :) pure $ f decl' (MetaAW f) -> do - aw' <- metaRequestAW defaultRunMeta e - liftIO $ - modifyIORef' var $ - awSplicesL %~ ((e, aw'):) + aw' <- metaRequestAW hook e + liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :) pure $ f aw' From f7e7e65ae97095ca43adc2d7c5fc04a7d714b2e4 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 20:41:36 +0900 Subject: [PATCH 26/51] Error report --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 646b62b651..2f702846fe 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -131,10 +131,12 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = Expr -> graftSpliceWith exprSuperSpans Pat -> graftSpliceWith patSuperSpans HsType -> graftSpliceWith typeSuperSpans - pure $ case eedits of - Left err -> - (Left $ responseError $ T.pack err, Nothing) - Right edits -> + 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) ) From cd18dde9ac14f4698391d71751fce6e00c4b04c3 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 5 Oct 2020 19:08:32 +0100 Subject: [PATCH 27/51] Add splice information into HIE generation. --- ghcide/src/Development/IDE/Core/Compile.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index dc669d732b..7c28a11b36 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -92,6 +92,7 @@ import System.IO.Extra ( fixIO, newTempFileWithin ) import Control.Exception (evaluate) import TcEnv (tcLookup) import Data.Time (UTCTime, getCurrentTime) +import Bag import Linker (unload) import qualified GHC.LanguageExtensions as LangExt import PrelNames @@ -428,8 +429,13 @@ atomicFileWrite targetPath write = do generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = - handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ - Just <$> GHC.enrichHie (tcg_binds $ tmrTypechecked tcm) (tmrRenamed tcm) + handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do + -- These varBinds use unitDataConId but it could be anything as the id name is not used + -- during the hie file generation process. It's a workaround for the fact that the hie modules + -- don't export an interface which allows for additional information to be added to hie files. + let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (tmrTopLevelSplices tcm)) + real_binds = tcg_binds $ tmrTypechecked tcm + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) where dflags = hsc_dflags hscEnv From 39a1cc4588cf285713f44c4643c2b73a2d678458 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 31 Dec 2020 21:29:19 +0900 Subject: [PATCH 28/51] Resolves interace conflict --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Core/Compile.hs | 13 ++++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index ec1d42774a..75794d183a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -46,6 +46,7 @@ library data-default, deepseq, directory, + dlist, extra, fuzzy, filepath, diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 7c28a11b36..feaa183ab0 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -91,6 +91,7 @@ import System.Directory import System.IO.Extra ( fixIO, newTempFileWithin ) import Control.Exception (evaluate) import TcEnv (tcLookup) +import qualified Data.DList as DL import Data.Time (UTCTime, getCurrentTime) import Bag import Linker (unload) @@ -433,12 +434,22 @@ generateHieAsts hscEnv tcm = -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (tmrTopLevelSplices tcm)) + let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) where dflags = hsc_dflags hscEnv +spliceExpresions :: Splices -> [LHsExpr GhcTc] +spliceExpresions Splices{..} = + DL.toList $ mconcat + [ DL.fromList $ map fst exprSplices + , DL.fromList $ map fst patSplices + , DL.fromList $ map fst typeSplices + , DL.fromList $ map fst declSplices + , DL.fromList $ map fst awSplices + ] + writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] writeHieFile hscEnv mod_summary exports ast source = handleGenerationErrors dflags "extended interface write/compression" $ do From 7876914ffc9951a287a50bc396928f0e994130a1 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 5 Oct 2020 19:35:24 +0100 Subject: [PATCH 29/51] Add test --- ghcide/test/data/hover/GotoHover.hs | 5 ++++- ghcide/test/exe/Main.hs | 4 +++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/ghcide/test/data/hover/GotoHover.hs b/ghcide/test/data/hover/GotoHover.hs index 80931a613a..ae261c6bdf 100644 --- a/ghcide/test/data/hover/GotoHover.hs +++ b/ghcide/test/data/hover/GotoHover.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} {- HLINT ignore -} module GotoHover ( module GotoHover) where import Data.Text (Text, pack) @@ -56,5 +56,8 @@ outer = undefined inner where imported :: Bar imported = foo +aa2 :: Bool +aa2 = $(id [| True |]) + hole :: Int hole = _ diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d7bf6b2618..7a1d8fbbd8 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2470,10 +2470,11 @@ findDefinitionAndHoverTests = let lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 59 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] in mkFindTests -- def hover look expect @@ -2520,6 +2521,7 @@ findDefinitionAndHoverTests = let , test no skip cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , test no yes thLocL57 thLoc "TH Splice Hover" ] where yes, broken :: (TestTree -> Maybe TestTree) yes = Just -- test should run and pass From 5d46ac03d290efc2515a0170926acbb29411b980 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 00:01:33 +0900 Subject: [PATCH 30/51] Changes to use ParsedModule to detect Splice CodeLens --- ghcide/src/Development/IDE/GHC/Orphans.hs | 34 +++++ .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 132 +++++++++--------- .../src/Ide/Plugin/Splice/Types.hs | 3 +- 4 files changed, 104 insertions(+), 66 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 135bbb211f..9155ca2439 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -12,12 +12,15 @@ module Development.IDE.GHC.Orphans() where import Bag import Control.DeepSeq +import Data.Aeson import Data.Hashable import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import GHC () import GhcPlugins import qualified StringBuffer as SB +import Data.Text (Text) +import Data.String (IsString(fromString)) -- Orphan instances for types from the GHC API. @@ -94,6 +97,37 @@ instance NFData a => NFData (IdentifierDetails a) where instance NFData RealSrcSpan where rnf = rwhnf +srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag, + srcSpanEndLineTag, srcSpanEndColTag :: Text +srcSpanFileTag = "srcSpanFile" +srcSpanStartLineTag = "srcSpanStartLine" +srcSpanStartColTag = "srcSpanStartCol" +srcSpanEndLineTag = "srcSpanEndLine" +srcSpanEndColTag = "srcSpanEndCol" + +instance ToJSON RealSrcSpan where + toJSON spn = + object + [ srcSpanFileTag .= unpackFS (srcSpanFile spn) + , srcSpanStartLineTag .= srcSpanStartLine spn + , srcSpanStartColTag .= srcSpanStartCol spn + , srcSpanEndLineTag .= srcSpanEndLine spn + , srcSpanEndColTag .= srcSpanEndCol spn + ] + +instance FromJSON RealSrcSpan where + parseJSON = withObject "object" $ \obj -> do + file <- fromString <$> (obj .: srcSpanFileTag) + mkRealSrcSpan + <$> (mkRealSrcLoc file + <$> obj .: srcSpanStartLineTag + <*> obj .: srcSpanStartColTag + ) + <*> (mkRealSrcLoc file + <$> obj .: srcSpanEndLineTag + <*> obj .: srcSpanEndColTag + ) + instance NFData Type where rnf = rwhnf diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index d0ee4c9a19..7a8d4cf402 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -27,6 +27,7 @@ library , dlist , retrie , shake + , syb , text , transformers , unordered-containers diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 2f702846fe..59eac48785 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -15,6 +17,7 @@ module Ide.Plugin.Splice ) where +import Control.Applicative (Alternative ((<|>))) import Control.Lens (ifoldMap, (^.)) import Control.Monad import qualified Control.Monad.Fail as Fail @@ -24,10 +27,12 @@ import Control.Monad.Trans.Writer.CPS import Data.Aeson import qualified Data.DList as DL import Data.Function +import Data.Generics import qualified Data.Kind as Kinds import Data.List (sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Monoid (Ap (..)) +import Data.Semigroup (Last) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T @@ -47,6 +52,7 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as J import TcRnMonad +import Development.IDE.GHC.Compat (HasSrcSpan(getLoc)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -80,6 +86,9 @@ instance Eq SubSpan where instance Ord SubSpan where (<=) = coerce isSubspanOf +pprLoc :: Show (Located a) => Located a -> String +pprLoc a@(L loc _) = show (loc, a) + expandTHSplice :: -- | Inplace? ExpandStyle -> @@ -87,6 +96,7 @@ expandTHSplice :: expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do + let srcSpan = RealSrcSpan spliceSpan fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri TcModuleResult {..} <- MaybeT $ @@ -99,15 +109,12 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = runAction "expandTHSplice.ghcSessionDeps" ideState $ use_ GhcSessionDeps fp let dflags = hsc_dflags $ hscEnv hscEnvEq - srcSpan = - RealSrcSpan $ - rangeToRealSrcSpan range $ fromString $ fromNormalizedFilePath fp exprSuperSpans = - listToMaybe $ findSuperSpansAsc srcSpan exprSplices + listToMaybe $ findSubSpansDesc srcSpan exprSplices patSuperSpans = - listToMaybe $ findSuperSpansAsc srcSpan patSplices + listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = - listToMaybe $ findSuperSpansAsc srcSpan typeSplices + listToMaybe $ findSubSpansDesc srcSpan typeSplices graftSpliceWith :: forall ast. @@ -133,22 +140,25 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = HsType -> graftSpliceWith typeSuperSpans case eedits of Left err -> do - reportEditor lsp MtError + 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) - ) + Right edits -> + pure + ( Right Null + , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) + ) where defaultResult = (Right Null, Nothing) -findSuperSpansAsc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] -findSuperSpansAsc srcSpan = - sortOn (SubSpan . fst) +findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] +findSubSpansDesc srcSpan = + sortOn (Down . SubSpan . fst) . mapMaybe ( \(L spn _, e) -> do - guard (srcSpan `isSubspanOf` spn) + guard (spn `isSubspanOf` srcSpan) pure (spn, e) ) @@ -169,7 +179,6 @@ instance HasSplice HsType where matchSplice _ (HsSpliceTy _ spl) = Just spl matchSplice _ _ = Nothing --- | FIXME: Is thereAny "clever" way to do this exploiting TTG? reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () reportEditor lsp msgTy msgs = liftIO $ @@ -179,6 +188,7 @@ reportEditor lsp msgTy msgs = ShowMessageParams msgTy $ T.unlines msgs +-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? unRenamedE :: forall ast m. (Fail.MonadFail m, HasSplice ast) => @@ -198,45 +208,53 @@ unRenamedE dflags expr = do -- 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 range0 _ = +codeAction _ state plId docId ran _ = fmap (maybe (Right $ List []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri - (getAsts . hieAst -> asts, posMap) <- + ParsedModule {..} <- MaybeT . runAction "splice.codeAction.GitHieAst" state $ - useWithStale GetHieAst fp - ran' <- - MaybeT $ - pure $ - fromCurrentRange posMap range0 - fmap (List . DL.toList) $ - execWriterT $ - getAp $ ifoldMap (fmap Ap . go ran') asts + use GetParsedModule fp + let spn = + rangeToRealSrcSpan ran $ + fromString $ + fromNormalizedFilePath fp + mouterSplice = something' (detectSplice spn) pm_parsed_source + mcmds <- forM mouterSplice $ + \(spliceSpan, spliceContext) -> + forM expandStyles $ \(_style, 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 - go ran' fs ast = - forM_ (smallestContainingSatisfying (rangeToRealSrcSpan ran' fs) isSpliceNode ast) $ - \Node {..} -> do - let NodeInfo {..} = nodeInfo - spCxt - | ("SplicePat", "Pat") `Set.member` nodeAnnotations = - Just Pat - | ("HsSpliceE", "HsExpr") `Set.member` nodeAnnotations = Just Expr - | ("HsSpliceTy", "HsType") `Set.member` nodeAnnotations = Just HsType - {- FIXME: HsDecl needs different treatment - | ("SpliceD", "HsDecl") `Set.member` nodeAnnotations = Just HsDecl - -} - | otherwise = Nothing - forM_ spCxt $ \spliceContext -> forM_ expandStyles $ \(_style, title, cmdId) -> do - let range = realSrcSpanToRange nodeSpan - params = ExpandSpliceParams {uri = theUri, ..} - act <- - liftIO $ - mkLspCommand plId cmdId title (Just [toJSON params]) - tell $ - DL.singleton $ - CACodeAction $ - CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act) + detectSplice :: + RealSrcSpan -> + GenericQ (Maybe (RealSrcSpan, SpliceContext)) + detectSplice spn = + mkQ + Nothing + ( \case + (L l@(RealSrcSpan spLoc) HsSpliceE{} :: LHsExpr GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) + _ -> Nothing + ) + `extQ` \case + (L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat) + _ -> Nothing + `extQ` \case + (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) + _ -> Nothing + +-- | Like 'something', but performs in bottom-up manner. +something' :: forall a. GenericQ (Maybe a) -> GenericQ (Maybe a) +something' = everything (flip (<|>)) posToRealSrcLoc :: Position -> FastString -> RealSrcLoc posToRealSrcLoc pos fs = mkRealSrcLoc fs (line + 1) (col + 1) @@ -250,22 +268,6 @@ rangeToRealSrcSpan ran fs = (posToRealSrcLoc (_start ran) fs) (posToRealSrcLoc (_end ran) fs) -isSpliceNode :: HieAST Type -> Bool -isSpliceNode Node {..} = - not $ - Set.null $ - spliceAnns - `Set.intersection` nodeAnnotations nodeInfo - -spliceAnns :: Set (FastString, FastString) -spliceAnns = - Set.fromList - [ ("SplicePat", "Pat") - , ("HsSpliceE", "HsExpr") - , ("HsSpliceTy", "HsType") - -- , ("SpliceD", "HsDecl") -- FIXME: HsDecl - ] - expandStyles :: [(ExpandStyle, T.Text, CommandId)] expandStyles = [ (Inplace, inplaceCmdName, expandInplaceId) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index 3361c87d48..1def30cbc7 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -7,11 +7,12 @@ module Ide.Plugin.Splice.Types where import Data.Aeson (FromJSON, ToJSON) import Development.IDE (Range, Uri) import GHC.Generics (Generic) +import Development.IDE.GHC.Compat (RealSrcSpan) -- | Parameter for the addMethods PluginCommand. data ExpandSpliceParams = ExpandSpliceParams { uri :: Uri - , range :: Range + , spliceSpan :: RealSrcSpan , spliceContext :: SpliceContext } deriving (Show, Eq, Generic) From b29fb59c05e13cd103ef2ae24b061e52945c4c4b Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 00:21:43 +0900 Subject: [PATCH 31/51] formatted --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 59eac48785..ded595364b 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} @@ -18,26 +18,19 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Lens (ifoldMap, (^.)) +import Control.Lens ((^.)) import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Writer.CPS import Data.Aeson -import qualified Data.DList as DL import Data.Function import Data.Generics import qualified Data.Kind as Kinds import Data.List (sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.Monoid (Ap (..)) -import Data.Semigroup (Last) -import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getLoc) import GHC.Exts import GhcMonad @@ -52,7 +45,6 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as J import TcRnMonad -import Development.IDE.GHC.Compat (HasSrcSpan(getLoc)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -239,7 +231,7 @@ codeAction _ state plId docId ran _ = mkQ Nothing ( \case - (L l@(RealSrcSpan spLoc) HsSpliceE{} :: LHsExpr GhcPs) + (L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) _ -> Nothing ) From 8cb16ff064a5b471533e0a5911b596ec6bef3e86 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 02:30:11 +0900 Subject: [PATCH 32/51] Implements golden test --- haskell-language-server.cabal | 5 +- .../src/Ide/Plugin/Splice.hs | 26 +---- .../src/Ide/Plugin/Splice/Types.hs | 31 +++++- test/functional/Main.hs | 2 + test/functional/Splice.hs | 98 +++++++++++++++++++ test/testdata/splice/QQ.hs | 28 ++++++ test/testdata/splice/TErrorExp.hs | 6 ++ test/testdata/splice/TErrorExp.hs.expected | 6 ++ test/testdata/splice/TErrorPat.hs | 6 ++ test/testdata/splice/TErrorPat.hs.expected | 6 ++ test/testdata/splice/TQQExp.hs | 6 ++ test/testdata/splice/TQQExp.hs.expected | 6 ++ test/testdata/splice/TQQExpError.hs | 6 ++ test/testdata/splice/TQQExpError.hs.expected | 6 ++ test/testdata/splice/TQQPat.hs | 7 ++ test/testdata/splice/TQQPat.hs.expected | 7 ++ test/testdata/splice/TQQPatError.hs | 7 ++ test/testdata/splice/TQQPatError.hs.expected | 7 ++ test/testdata/splice/TQQType.hs | 9 ++ test/testdata/splice/TQQType.hs.expected | 9 ++ test/testdata/splice/TQQTypeTypeError.hs | 9 ++ .../splice/TQQTypeTypeError.hs.expected | 9 ++ test/testdata/splice/TSimpleExp.hs | 6 ++ test/testdata/splice/TSimpleExp.hs.expected | 6 ++ test/testdata/splice/TSimplePat.hs | 6 ++ test/testdata/splice/TSimplePat.hs.expected | 6 ++ test/testdata/splice/TSimpleType.hs | 6 ++ test/testdata/splice/TSimpleType.hs.expected | 6 ++ test/testdata/splice/TTypeKindError.hs | 8 ++ .../splice/TTypeKindError.hs.expected | 8 ++ test/testdata/splice/TTypeTypeError.hs | 8 ++ .../splice/TTypeTypeError.hs.expected | 8 ++ 32 files changed, 346 insertions(+), 24 deletions(-) create mode 100644 test/functional/Splice.hs create mode 100644 test/testdata/splice/QQ.hs create mode 100644 test/testdata/splice/TErrorExp.hs create mode 100644 test/testdata/splice/TErrorExp.hs.expected create mode 100644 test/testdata/splice/TErrorPat.hs create mode 100644 test/testdata/splice/TErrorPat.hs.expected create mode 100644 test/testdata/splice/TQQExp.hs create mode 100644 test/testdata/splice/TQQExp.hs.expected create mode 100644 test/testdata/splice/TQQExpError.hs create mode 100644 test/testdata/splice/TQQExpError.hs.expected create mode 100644 test/testdata/splice/TQQPat.hs create mode 100644 test/testdata/splice/TQQPat.hs.expected create mode 100644 test/testdata/splice/TQQPatError.hs create mode 100644 test/testdata/splice/TQQPatError.hs.expected create mode 100644 test/testdata/splice/TQQType.hs create mode 100644 test/testdata/splice/TQQType.hs.expected create mode 100644 test/testdata/splice/TQQTypeTypeError.hs create mode 100644 test/testdata/splice/TQQTypeTypeError.hs.expected create mode 100644 test/testdata/splice/TSimpleExp.hs create mode 100644 test/testdata/splice/TSimpleExp.hs.expected create mode 100644 test/testdata/splice/TSimplePat.hs create mode 100644 test/testdata/splice/TSimplePat.hs.expected create mode 100644 test/testdata/splice/TSimpleType.hs create mode 100644 test/testdata/splice/TSimpleType.hs.expected create mode 100644 test/testdata/splice/TTypeKindError.hs create mode 100644 test/testdata/splice/TTypeKindError.hs.expected create mode 100644 test/testdata/splice/TTypeTypeError.hs create mode 100644 test/testdata/splice/TTypeTypeError.hs.expected diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9a9882919b..f669f13dc1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -395,8 +395,9 @@ test-suite func-test , tasty-ant-xml >=1.1.6 , tasty-golden , tasty-rerun + , ghcide - hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test + hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src main-is: Main.hs other-modules: @@ -421,6 +422,8 @@ test-suite func-test Symbol TypeDefinition Tactic + Splice + Ide.Plugin.Splice.Types Ide.Plugin.Tactic.TestTypes ghc-options: diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index ded595364b..41998a1d81 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -53,17 +53,6 @@ descriptor plId = , pluginCodeActionProvider = Just codeAction } --- -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)" - commands :: [PluginCommand IdeState] commands = [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace @@ -78,9 +67,6 @@ instance Eq SubSpan where instance Ord SubSpan where (<=) = coerce isSubspanOf -pprLoc :: Show (Located a) => Located a -> String -pprLoc a@(L loc _) = show (loc, a) - expandTHSplice :: -- | Inplace? ExpandStyle -> @@ -214,7 +200,7 @@ codeAction _ state plId docId ran _ = mouterSplice = something' (detectSplice spn) pm_parsed_source mcmds <- forM mouterSplice $ \(spliceSpan, spliceContext) -> - forM expandStyles $ \(_style, title, cmdId) -> do + forM expandStyles $ \(_, (title, cmdId)) -> do let params = ExpandSpliceParams {uri = theUri, ..} act <- liftIO $ mkLspCommand plId cmdId title (Just [toJSON params]) pure $ @@ -243,6 +229,10 @@ codeAction _ state plId docId ran _ = (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) _ -> Nothing + `extQ` \case + (L l@(RealSrcSpan spLoc) SpliceD {} :: LHsDecl GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl) + _ -> Nothing -- | Like 'something', but performs in bottom-up manner. something' :: forall a. GenericQ (Maybe a) -> GenericQ (Maybe a) @@ -259,9 +249,3 @@ rangeToRealSrcSpan ran fs = mkRealSrcSpan (posToRealSrcLoc (_start ran) fs) (posToRealSrcLoc (_end ran) fs) - -expandStyles :: [(ExpandStyle, T.Text, CommandId)] -expandStyles = - [ (Inplace, inplaceCmdName, expandInplaceId) - -- , (Commented, commentedCmdName, expandCommentedId) - ] diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index 1def30cbc7..f44ba69d5a 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -1,13 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} module Ide.Plugin.Splice.Types where import Data.Aeson (FromJSON, ToJSON) -import Development.IDE (Range, Uri) +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 @@ -19,9 +22,33 @@ data ExpandSpliceParams = ExpandSpliceParams deriving anyclass (ToJSON, FromJSON) -- FIXME: HsDecl needs different treatment of splicing. -data SpliceContext = Expr {- HsDecl | -} | Pat | HsType +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)" diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 29c7c4785e..ae458d788a 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -19,6 +19,7 @@ import Progress import Reference import Rename import Symbol +import Splice import Tactic import Test.Tasty import Test.Tasty.Ingredients.Rerun @@ -58,4 +59,5 @@ main = , Symbol.tests , Tactic.tests , TypeDefinition.tests + , Splice.tests ] diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs new file mode 100644 index 0000000000..14b6ebe9a9 --- /dev/null +++ b/test/functional/Splice.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Splice (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Control.Monad.IO.Class +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text.IO as T +import Ide.Plugin.Splice.Types +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types + ( ApplyWorkspaceEditRequest, + CAResult (..), + CodeAction (..), + Position (..), + Range (..), + ) +import System.Directory +import System.FilePath +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "splice" + [ goldenTest "TSimpleExp.hs" Inplace 6 15 + , goldenTest "TSimpleExp.hs" Inplace 6 24 + , goldenTest "TErrorExp.hs" Inplace 6 15 + , goldenTest "TErrorExp.hs" Inplace 6 51 + , goldenTest "TQQExp.hs" Inplace 6 17 + , goldenTest "TQQExp.hs" Inplace 6 25 + , goldenTest "TQQExpError.hs" Inplace 6 13 + , goldenTest "TQQExpError.hs" Inplace 6 22 + , goldenTest "TSimplePat.hs" Inplace 6 3 + , goldenTest "TSimplePat.hs" Inplace 6 22 + , goldenTest "TSimplePat.hs" Inplace 6 3 + , goldenTest "TSimplePat.hs" Inplace 6 22 + , goldenTest "TErrorPat.hs" Inplace 6 3 + , goldenTest "TErrorPat.hs" Inplace 6 18 + , goldenTest "TQQPat.hs" Inplace 6 3 + , goldenTest "TQQPat.hs" Inplace 6 11 + , goldenTest "TQQPatError.hs" Inplace 6 3 + , goldenTest "TQQPatError.hs" Inplace 6 11 + , goldenTest "TSimpleType.hs" Inplace 5 12 + , goldenTest "TSimpleType.hs" Inplace 5 22 + , goldenTest "TTypeTypeError.hs" Inplace 7 12 + , goldenTest "TTypeTypeError.hs" Inplace 7 52 + , goldenTest "TQQType.hs" Inplace 8 19 + , goldenTest "TQQType.hs" Inplace 8 28 + , goldenTest "TQQTypeTypeError.hs" Inplace 8 19 + , goldenTest "TQQTypeTypeError.hs" Inplace 8 28 +{- it must fail (and hence success by expectFail), but no.. + , expectFail + $ testGroup "Type splices with kind error" + [goldenTest "TTypeKindError.hs" Inplace 7 9 + , goldenTest "TTypeKindError.hs" Inplace 7 29] + -} + ] + +goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree +goldenTest input tc line col = + testCase (input <> " (golden)") $ do + runSession hlsCommand fullCaps spliceTestPath $ do + doc <- openDoc input "haskell" + _ <- waitForDiagnostics + actions <- getCodeActions doc $ pointRange line col + Just (CACodeAction CodeAction {_command = Just c}) <- + pure $ find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + let expected_name = spliceTestPath input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ + (doesFileExist expected_name >>=) $ + flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited @?= expected + +spliceTestPath :: FilePath +spliceTestPath = "test/testdata/splice" + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> line) + (subtract 1 -> col) = + Range (Position line col) (Position line $ col + 1) + +-- | Get the title of a code action. +codeActionTitle :: CAResult -> Maybe Text +codeActionTitle CACommand {} = Nothing +codeActionTitle (CACodeAction (CodeAction title _ _ _ _)) = Just title diff --git a/test/testdata/splice/QQ.hs b/test/testdata/splice/QQ.hs new file mode 100644 index 0000000000..bf5efeb1b5 --- /dev/null +++ b/test/testdata/splice/QQ.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +module QQ (str) where + +import Language.Haskell.TH + ( mkName, + stringL, + litP, + clause, + litE, + normalB, + funD, + sigD, + litT, + strTyLit ) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) + +str :: QuasiQuoter +str = + QuasiQuoter + { quoteExp = litE . stringL + , quotePat = litP . stringL + , quoteType = litT . strTyLit + , quoteDec = \name -> + sequence + [ sigD (mkName name) [t|String|] + , funD (mkName name) [clause [] (normalB $ litE $ stringL name) []] + ] + } diff --git a/test/testdata/splice/TErrorExp.hs b/test/testdata/splice/TErrorExp.hs new file mode 100644 index 0000000000..fb696dc2dd --- /dev/null +++ b/test/testdata/splice/TErrorExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return $(tupE [litE $ integerL 42, tupE []]) diff --git a/test/testdata/splice/TErrorExp.hs.expected b/test/testdata/splice/TErrorExp.hs.expected new file mode 100644 index 0000000000..420d9834ea --- /dev/null +++ b/test/testdata/splice/TErrorExp.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return (42, ()) diff --git a/test/testdata/splice/TErrorPat.hs b/test/testdata/splice/TErrorPat.hs new file mode 100644 index 0000000000..87f3d2c9cb --- /dev/null +++ b/test/testdata/splice/TErrorPat.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorPat where +import Language.Haskell.TH ( conP ) + +f :: () -> () +f $(conP 'True []) = x diff --git a/test/testdata/splice/TErrorPat.hs.expected b/test/testdata/splice/TErrorPat.hs.expected new file mode 100644 index 0000000000..184c9bd9eb --- /dev/null +++ b/test/testdata/splice/TErrorPat.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorPat where +import Language.Haskell.TH ( conP ) + +f :: () -> () +f True = x diff --git a/test/testdata/splice/TQQExp.hs b/test/testdata/splice/TQQExp.hs new file mode 100644 index 0000000000..b600df586a --- /dev/null +++ b/test/testdata/splice/TQQExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExp where +import QQ + +main :: IO () +main = putStrLn [str|str|] diff --git a/test/testdata/splice/TQQExp.hs.expected b/test/testdata/splice/TQQExp.hs.expected new file mode 100644 index 0000000000..26f1169513 --- /dev/null +++ b/test/testdata/splice/TQQExp.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExp where +import QQ + +main :: IO () +main = putStrLn "str" diff --git a/test/testdata/splice/TQQExpError.hs b/test/testdata/splice/TQQExpError.hs new file mode 100644 index 0000000000..56897837da --- /dev/null +++ b/test/testdata/splice/TQQExpError.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExpError where +import QQ + +main :: IO () +main = pure [str|str|] diff --git a/test/testdata/splice/TQQExpError.hs.expected b/test/testdata/splice/TQQExpError.hs.expected new file mode 100644 index 0000000000..16c7678d0d --- /dev/null +++ b/test/testdata/splice/TQQExpError.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExpError where +import QQ + +main :: IO () +main = pure "str" diff --git a/test/testdata/splice/TQQPat.hs b/test/testdata/splice/TQQPat.hs new file mode 100644 index 0000000000..e1ada41287 --- /dev/null +++ b/test/testdata/splice/TQQPat.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPat where +import QQ + +f :: String -> IO () +f [str|str|] = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/test/testdata/splice/TQQPat.hs.expected b/test/testdata/splice/TQQPat.hs.expected new file mode 100644 index 0000000000..eb99524050 --- /dev/null +++ b/test/testdata/splice/TQQPat.hs.expected @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPat where +import QQ + +f :: String -> IO () +f "str" = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/test/testdata/splice/TQQPatError.hs b/test/testdata/splice/TQQPatError.hs new file mode 100644 index 0000000000..d89141a875 --- /dev/null +++ b/test/testdata/splice/TQQPatError.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPatError where +import QQ + +f :: () -> IO () +f [str|str|] = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/test/testdata/splice/TQQPatError.hs.expected b/test/testdata/splice/TQQPatError.hs.expected new file mode 100644 index 0000000000..0f928feab7 --- /dev/null +++ b/test/testdata/splice/TQQPatError.hs.expected @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPatError where +import QQ + +f :: () -> IO () +f "str" = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/test/testdata/splice/TQQType.hs b/test/testdata/splice/TQQType.hs new file mode 100644 index 0000000000..2c670793e2 --- /dev/null +++ b/test/testdata/splice/TQQType.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQType where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy [str|str|]) +main = return Proxy diff --git a/test/testdata/splice/TQQType.hs.expected b/test/testdata/splice/TQQType.hs.expected new file mode 100644 index 0000000000..f93798e01e --- /dev/null +++ b/test/testdata/splice/TQQType.hs.expected @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQType where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy "str") +main = return Proxy diff --git a/test/testdata/splice/TQQTypeTypeError.hs b/test/testdata/splice/TQQTypeTypeError.hs new file mode 100644 index 0000000000..3f644a3288 --- /dev/null +++ b/test/testdata/splice/TQQTypeTypeError.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy [str|str|]) +main = return () diff --git a/test/testdata/splice/TQQTypeTypeError.hs.expected b/test/testdata/splice/TQQTypeTypeError.hs.expected new file mode 100644 index 0000000000..70e37e7701 --- /dev/null +++ b/test/testdata/splice/TQQTypeTypeError.hs.expected @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy "str") +main = return () diff --git a/test/testdata/splice/TSimpleExp.hs b/test/testdata/splice/TSimpleExp.hs new file mode 100644 index 0000000000..7f5db568ac --- /dev/null +++ b/test/testdata/splice/TSimpleExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return $(tupE []) diff --git a/test/testdata/splice/TSimpleExp.hs.expected b/test/testdata/splice/TSimpleExp.hs.expected new file mode 100644 index 0000000000..fb8967b504 --- /dev/null +++ b/test/testdata/splice/TSimpleExp.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return () diff --git a/test/testdata/splice/TSimplePat.hs b/test/testdata/splice/TSimplePat.hs new file mode 100644 index 0000000000..ee6f1d3ed3 --- /dev/null +++ b/test/testdata/splice/TSimplePat.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimplePat where +import Language.Haskell.TH ( varP, mkName ) + +f :: x -> x +f $(varP $ mkName "x") = x diff --git a/test/testdata/splice/TSimplePat.hs.expected b/test/testdata/splice/TSimplePat.hs.expected new file mode 100644 index 0000000000..82c4891d3b --- /dev/null +++ b/test/testdata/splice/TSimplePat.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimplePat where +import Language.Haskell.TH ( varP, mkName ) + +f :: x -> x +f x = x diff --git a/test/testdata/splice/TSimpleType.hs b/test/testdata/splice/TSimpleType.hs new file mode 100644 index 0000000000..55b5c59d05 --- /dev/null +++ b/test/testdata/splice/TSimpleType.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleType where +import Language.Haskell.TH ( tupleT ) + +main :: IO $(tupleT 0) +main = return () diff --git a/test/testdata/splice/TSimpleType.hs.expected b/test/testdata/splice/TSimpleType.hs.expected new file mode 100644 index 0000000000..8975b4f926 --- /dev/null +++ b/test/testdata/splice/TSimpleType.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleType where +import Language.Haskell.TH ( tupleT ) + +main :: IO () +main = return () diff --git a/test/testdata/splice/TTypeKindError.hs b/test/testdata/splice/TTypeKindError.hs new file mode 100644 index 0000000000..58631e8464 --- /dev/null +++ b/test/testdata/splice/TTypeKindError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: $(litT (numTyLit 42)) +main = return () diff --git a/test/testdata/splice/TTypeKindError.hs.expected b/test/testdata/splice/TTypeKindError.hs.expected new file mode 100644 index 0000000000..101e12e402 --- /dev/null +++ b/test/testdata/splice/TTypeKindError.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: 42 +main = return () diff --git a/test/testdata/splice/TTypeTypeError.hs b/test/testdata/splice/TTypeTypeError.hs new file mode 100644 index 0000000000..37a8b3c931 --- /dev/null +++ b/test/testdata/splice/TTypeTypeError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy ) + +main :: IO $(conT ''Proxy `appT` litT (numTyLit 42)) +main = return () diff --git a/test/testdata/splice/TTypeTypeError.hs.expected b/test/testdata/splice/TTypeTypeError.hs.expected new file mode 100644 index 0000000000..f19e495e6d --- /dev/null +++ b/test/testdata/splice/TTypeTypeError.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy ) + +main :: IO (Proxy 42) +main = return () From 58f58ac016fe0e5fb718be0b0cd4ca11c9b6f025 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 03:22:04 +0900 Subject: [PATCH 33/51] mzero for HsDecl --- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 41998a1d81..d77885f3dd 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -93,6 +93,8 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = listToMaybe $ findSubSpansDesc srcSpan typeSplices + declSueprSpans = + listToMaybe $ findSubSpansDesc srcSpan declSplices graftSpliceWith :: forall ast. @@ -116,6 +118,7 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = Expr -> graftSpliceWith exprSuperSpans Pat -> graftSpliceWith patSuperSpans HsType -> graftSpliceWith typeSuperSpans + HsDecl -> mzero case eedits of Left err -> do reportEditor From f8b66dd16d67ca4b70f3392f7a3db0ffce20ed49 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 05:29:56 +0900 Subject: [PATCH 34/51] Decl Splice --- .../hls-exactprint-utils.cabal | 1 + hls-exactprint-utils/src/Ide/TreeTransform.hs | 39 ++++++++++++++- .../src/Ide/Plugin/Splice.hs | 49 ++++++++++--------- 3 files changed, 65 insertions(+), 24 deletions(-) diff --git a/hls-exactprint-utils/hls-exactprint-utils.cabal b/hls-exactprint-utils/hls-exactprint-utils.cabal index f4b4165b29..9149b900a8 100644 --- a/hls-exactprint-utils/hls-exactprint-utils.cabal +++ b/hls-exactprint-utils/hls-exactprint-utils.cabal @@ -28,6 +28,7 @@ library hs-source-dirs: src build-depends: base >=4.12 && <5 + , dlist , ghc , ghc-exactprint , ghcide diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index e9b11f841f..18fd5890eb 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -8,8 +8,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ide.TreeTransform - ( Graft, + ( Graft(..), graft, + graftMany, hoistGraft, graftWithM, graftWithSmallestM, @@ -46,6 +47,8 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) import Outputable import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) +import qualified Data.DList as DL +import Data.Monoid (Ap(..)) ------------------------------------------------------------------------------ @@ -197,7 +200,7 @@ graftWithSmallestM :: (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a graftWithSmallestM dst trans = Graft $ \dflags a -> do - everywhereM + everywhereM' ( mkM $ \case val@(L src _ :: Located ast) @@ -215,6 +218,38 @@ graftWithSmallestM dst trans = Graft $ \dflags a -> do ) a +graftMany :: + forall ast a. + (Data a, ASTElement ast) => + SrcSpan -> + [Located ast] -> + Graft (Either String) a +graftMany dst vals = Graft $ \dflags a -> do + everywhereM + ( mkM $ + \case + (ast@(L src _ :: Located ast) : rest) + | dst == src -> do + (anns, vals') <- + getAp $ + foldMap + ( Ap + . fmap + ( \(ann0, ast') -> + ( setPrecedingLines ast' 1 0 ann0 + , DL.singleton ast' + ) + ) + . annotate dflags + . maybeParensAST + ) + vals + modifyAnnsT $ mappend anns + pure $ DL.toList vals' ++ rest + l -> pure l + ) + a + everywhereM' :: forall m. Monad m => GenericM m -> GenericM m everywhereM' f = go where diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index d77885f3dd..88ac5a4a22 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -18,7 +18,7 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Lens ((^.)) +import Control.Lens ((<&>), (^.)) import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class @@ -93,32 +93,38 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = listToMaybe $ findSubSpansDesc srcSpan typeSplices - declSueprSpans = + declSuperSpans = listToMaybe $ findSubSpansDesc srcSpan declSplices graftSpliceWith :: forall ast. HasSplice ast => Maybe (SrcSpan, Located (ast GhcPs)) -> - MaybeT IO (Maybe (Either String WorkspaceEdit)) - graftSpliceWith expandeds = forM expandeds $ \(loc, expanded) -> - transformM - dflags - (clientCapabilities lsp) - uri - ( graftWithSmallestM - loc - $ \case - (L _ (matchSplice @ast proxy# -> Just {})) -> pure $ Just expanded - _ -> pure Nothing - ) - ps - eedits <- - join . maybe (Left "No splcie information found") Right <$> case spliceContext of - Expr -> graftSpliceWith exprSuperSpans - Pat -> graftSpliceWith patSuperSpans - HsType -> graftSpliceWith typeSuperSpans - HsDecl -> mzero + Maybe (Either String WorkspaceEdit) + graftSpliceWith expandeds = + expandeds <&> \(_, expanded) -> + transform + dflags + (clientCapabilities lsp) + uri + (graft (RealSrcSpan spliceSpan) expanded) + ps + let eedits = join . maybe (Left "No splcie information found") Right $ + case spliceContext of + Expr -> graftSpliceWith exprSuperSpans + Pat -> graftSpliceWith patSuperSpans + HsType -> graftSpliceWith typeSuperSpans + HsDecl -> + -- FIXME: It seems multiline edit results in wrong Edit + -- emited by @transform@. + -- It will eat preceding comments and spaces! + declSuperSpans <&> \(_, expanded) -> + transform + dflags + (clientCapabilities lsp) + uri + (graftMany (RealSrcSpan spliceSpan) expanded) + ps case eedits of Left err -> do reportEditor @@ -183,7 +189,6 @@ unRenamedE dflags expr = do parseAST @(ast GhcPs) dflags uniq $ showSDoc dflags $ ppr expr let _anns' = setPrecedingLines expr' 0 1 anns - -- modifyAnnsT $ mappend anns' pure expr' -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) From 210c8189e42f7dc428def9f71e30fb60cbc8d4c0 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 21:36:27 +0900 Subject: [PATCH 35/51] Workaround for Decl expansion and support type-errored macro expansion. --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 82 +++--- .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 265 +++++++++++++++--- test/functional/Splice.hs | 7 +- test/testdata/splice/TSimpleDecl.hs | 16 ++ test/testdata/splice/TSimpleDecl.hs.expected | 12 + 6 files changed, 308 insertions(+), 75 deletions(-) create mode 100644 test/testdata/splice/TSimpleDecl.hs create mode 100644 test/testdata/splice/TSimpleDecl.hs.expected diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 18fd5890eb..8192a2bcca 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -10,7 +10,8 @@ module Ide.TreeTransform ( Graft(..), graft, - graftMany, + graftDecls, + graftDeclsWithM, hoistGraft, graftWithM, graftWithSmallestM, @@ -31,6 +32,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Zip +import qualified Data.DList as DL import Data.Functor.Classes import Data.Functor.Contravariant import qualified Data.Text as T @@ -45,11 +47,9 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) -import Outputable +import Outputable (Outputable, ppr, showSDoc, trace) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) -import qualified Data.DList as DL -import Data.Monoid (Ap(..)) - +import Control.Arrow (Arrow(second)) ------------------------------------------------------------------------------ -- | Get the latest version of the annotated parse source. @@ -218,37 +218,45 @@ graftWithSmallestM dst trans = Graft $ \dflags a -> do ) a -graftMany :: - forall ast a. - (Data a, ASTElement ast) => +graftDecls :: + forall a. + (HasDecls a) => SrcSpan -> - [Located ast] -> + [LHsDecl GhcPs] -> Graft (Either String) a -graftMany dst vals = Graft $ \dflags a -> do - everywhereM - ( mkM $ - \case - (ast@(L src _ :: Located ast) : rest) - | dst == src -> do - (anns, vals') <- - getAp $ - foldMap - ( Ap - . fmap - ( \(ann0, ast') -> - ( setPrecedingLines ast' 1 0 ann0 - , DL.singleton ast' - ) - ) - . annotate dflags - . maybeParensAST - ) - vals +graftDecls dst decs0 = Graft $ \dflags a -> do + decs <- forM decs0 $ \decl -> do + (anns, decl') <- annotateDecl dflags decl + modifyAnnsT $ mappend anns + pure decl' + let go [] = DL.empty + go (L src e : rest) + | src == dst = DL.fromList decs <> DL.fromList rest + | otherwise = DL.singleton (L src e) <> go rest + modifyDeclsT (pure . 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) + | src == dst = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> do + (anns, decl') <- + hoistTransform (either Fail.fail pure) $ + annotateDecl dflags decl modifyAnnsT $ mappend anns - pure $ DL.toList vals' ++ rest - l -> pure l - ) - a + pure 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 + everywhereM' :: forall m. Monad m => GenericM m -> GenericM m everywhereM' f = go @@ -295,6 +303,14 @@ annotate dflags ast = do let anns' = setPrecedingLines expr' 0 1 anns pure (anns', expr') +-- | Given an 'LHsDecl', compute its exactprint annotations. +annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs) +annotateDecl dflags ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast + (anns, expr') <- lift $ either (Left . show) Right $ parseDecl dflags uniq rendered + let anns' = setPrecedingLines expr' 1 0 anns + pure (anns', expr') ------------------------------------------------------------------------------ -- | Print out something 'Outputable'. diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index 7a8d4cf402..41d7a0e3f2 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -17,6 +17,7 @@ library build-depends: aeson , base , containers + , foldl , haskell-lsp , hls-plugin-api , ghc diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 88ac5a4a22..1d1c48945b 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -8,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -18,10 +20,14 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Lens ((<&>), (^.)) +import Control.Arrow (Arrow (first)) +import Control.Exception (SomeException) +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 @@ -32,6 +38,7 @@ 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, (<>)) @@ -44,6 +51,8 @@ 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 descriptor :: PluginId -> PluginDescriptor IdeState @@ -71,15 +80,95 @@ expandTHSplice :: -- | Inplace? ExpandStyle -> CommandFunction IdeState ExpandSpliceParams -expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = +expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do - let srcSpan = RealSrcSpan spliceSpan fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri - TcModuleResult {..} <- - MaybeT $ - runAction "expandTHSplice.TypeCheck" ideState $ - use TypeCheck fp + 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.\n\ + \You 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 + let ps = annotateParsedSource pm + hscEnvEq <- + liftIO $ + runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ + use_ GhcSessionDeps fp + let hscEnv0 = hscEnvWithImportPaths hscEnvEq + modSum = pm_mod_summary pm + hscEnv <- lift $ + evalGhcEnv hscEnv0 $ do + env <- getSession + df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts modSum + + let impPaths = fromMaybe (importPaths df) (envImportPaths hscEnvEq) + + -- Set the modified flags in the session + _lp <- setSessionDynFlags df {importPaths = impPaths} + + -- copy the package state to the interactive DynFlags + idflags <- getInteractiveDynFlags + setInteractiveDynFlags $ + idflags + { pkgState = pkgState df + , pkgDatabase = pkgDatabase df + , packageFlags = packageFlags df + , useColor = Never + , canUseColor = False + } + setContext [IIModule $ moduleName $ ms_mod modSum] + `gcatch` \(_ :: SomeException) -> pure () + getSession + + manualCalcEdit + lsp + range + ps + hscEnv + tmrTypechecked + spliceSpan + _eStyle + params + withTypeChecked fp TcModuleResult {..} = do let ps = annotateParsedSource tmrParsed Splices {..} = tmrTopLevelSplices hscEnvEq <- @@ -109,36 +198,68 @@ expandTHSplice _eStyle lsp ideState ExpandSpliceParams {..} = uri (graft (RealSrcSpan spliceSpan) expanded) ps - let eedits = join . maybe (Left "No splcie information found") Right $ - case spliceContext of - Expr -> graftSpliceWith exprSuperSpans - Pat -> graftSpliceWith patSuperSpans - HsType -> graftSpliceWith typeSuperSpans - HsDecl -> - -- FIXME: It seems multiline edit results in wrong Edit - -- emited by @transform@. - -- It will eat preceding comments and spaces! - declSuperSpans <&> \(_, expanded) -> - transform - dflags - (clientCapabilities lsp) - uri - (graftMany (RealSrcSpan spliceSpan) expanded) - ps - 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) - ) + maybe (throwE "No splcie 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 + +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 - defaultResult = (Right Null, Nothing) + 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 = @@ -149,22 +270,37 @@ findSubSpansDesc 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 = @@ -175,6 +311,63 @@ reportEditor lsp msgTy msgs = 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. diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index 14b6ebe9a9..fbb2ac8354 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -54,12 +54,7 @@ tests = , goldenTest "TQQType.hs" Inplace 8 28 , goldenTest "TQQTypeTypeError.hs" Inplace 8 19 , goldenTest "TQQTypeTypeError.hs" Inplace 8 28 -{- it must fail (and hence success by expectFail), but no.. - , expectFail - $ testGroup "Type splices with kind error" - [goldenTest "TTypeKindError.hs" Inplace 7 9 - , goldenTest "TTypeKindError.hs" Inplace 7 29] - -} + , goldenTest "TSimpleDecl.hs" Inplace 8 1 ] goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree diff --git a/test/testdata/splice/TSimpleDecl.hs b/test/testdata/splice/TSimpleDecl.hs new file mode 100644 index 0000000000..fb0c2baba6 --- /dev/null +++ b/test/testdata/splice/TSimpleDecl.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ,sigD (mkName "bar") [t|Double|] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/test/testdata/splice/TSimpleDecl.hs.expected b/test/testdata/splice/TSimpleDecl.hs.expected new file mode 100644 index 0000000000..90c2bf1b09 --- /dev/null +++ b/test/testdata/splice/TSimpleDecl.hs.expected @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +foo :: Int +foo = 42 +-- Bar +-- ee +-- dddd From 6e57b13a1f2c32f475e302d238ebd530d5b4e14e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 21:43:55 +0900 Subject: [PATCH 36/51] Only setting up dflags correcly would suffice --- .../src/Ide/Plugin/Splice.hs | 25 ++----------------- 1 file changed, 2 insertions(+), 23 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 1d1c48945b..c97c75e627 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -135,29 +135,8 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = use_ GhcSessionDeps fp let hscEnv0 = hscEnvWithImportPaths hscEnvEq modSum = pm_mod_summary pm - hscEnv <- lift $ - evalGhcEnv hscEnv0 $ do - env <- getSession - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts modSum - - let impPaths = fromMaybe (importPaths df) (envImportPaths hscEnvEq) - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df {importPaths = impPaths} - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - setInteractiveDynFlags $ - idflags - { pkgState = pkgState df - , pkgDatabase = pkgDatabase df - , packageFlags = packageFlags df - , useColor = Never - , canUseColor = False - } - setContext [IIModule $ moduleName $ ms_mod modSum] - `gcatch` \(_ :: SomeException) -> pure () - getSession + df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + let hscEnv = hscEnv0 { hsc_dflags = df' } manualCalcEdit lsp From 9f8a868df2ec8b58b21284e395b3de88a8982845 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 21:44:20 +0900 Subject: [PATCH 37/51] Removes lines accidentally added --- test/testdata/splice/TSimpleDecl.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/testdata/splice/TSimpleDecl.hs b/test/testdata/splice/TSimpleDecl.hs index fb0c2baba6..027d4f83dd 100644 --- a/test/testdata/splice/TSimpleDecl.hs +++ b/test/testdata/splice/TSimpleDecl.hs @@ -8,7 +8,6 @@ import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) $(sequence [sigD (mkName "foo") [t|Int|] ,funD (mkName "foo") [clause [] (normalB [|42|]) []] - ,sigD (mkName "bar") [t|Double|] ] ) -- Bar From 45a1388cf010106031419447cff9a357532761e3 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 1 Jan 2021 23:30:04 +0900 Subject: [PATCH 38/51] Regression tests for Declaration splice and kind-error ones --- test/functional/Splice.hs | 40 +++++++++++++++++++ test/testdata/splice/TDeclKindError.hs | 15 +++++++ test/testdata/splice/TDeclKindError.hs.error | 16 ++++++++ .../splice/TDeclKindError.hs.expected | 13 ++++++ test/testdata/splice/TQQDecl.hs | 5 +++ test/testdata/splice/TQQDecl.hs.expected | 6 +++ test/testdata/splice/TTypeKindError.hs | 2 +- test/testdata/splice/TTypeKindError.hs.error | 8 ++++ .../splice/TTypeKindError.hs.expected | 2 +- 9 files changed, 105 insertions(+), 2 deletions(-) create mode 100644 test/testdata/splice/TDeclKindError.hs create mode 100644 test/testdata/splice/TDeclKindError.hs.error create mode 100644 test/testdata/splice/TDeclKindError.hs.expected create mode 100644 test/testdata/splice/TQQDecl.hs create mode 100644 test/testdata/splice/TQQDecl.hs.expected create mode 100644 test/testdata/splice/TTypeKindError.hs.error diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index fbb2ac8354..5b2ca01697 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -8,6 +9,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.List (find) import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Splice.Types import Language.Haskell.LSP.Test @@ -17,9 +19,12 @@ import Language.Haskell.LSP.Types CodeAction (..), Position (..), Range (..), + TextDocumentContentChangeEvent (..), + TextEdit (..), ) import System.Directory import System.FilePath +import System.Time.Extra (sleep) import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit @@ -55,6 +60,9 @@ tests = , goldenTest "TQQTypeTypeError.hs" Inplace 8 19 , goldenTest "TQQTypeTypeError.hs" Inplace 8 28 , goldenTest "TSimpleDecl.hs" Inplace 8 1 + , goldenTest "TQQDecl.hs" Inplace 5 1 + , goldenTestWithEdit "TTypeKindError.hs" Inplace 7 9 + , goldenTestWithEdit "TDeclKindError.hs" Inplace 8 1 ] goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree @@ -78,6 +86,38 @@ goldenTest input tc line col = expected <- liftIO $ T.readFile expected_name liftIO $ edited @?= expected +goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree +goldenTestWithEdit input tc line col = + testCase (input <> " (golden)") $ do + runSession hlsCommand fullCaps spliceTestPath $ do + doc <- openDoc input "haskell" + orig <- documentContents doc + let lns = T.lines orig + theRange = + Range + { _start = Position 0 0 + , _end = Position (length lns + 1) 1 + } + liftIO $ sleep 1 + alt <- liftIO $ T.readFile (spliceTestPath input <.> "error") + void $ applyEdit doc $ TextEdit theRange alt + changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] + void waitForDiagnostics + actions <- getCodeActions doc $ pointRange line col + Just (CACodeAction CodeAction {_command = Just c}) <- + pure $ find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + let expected_name = spliceTestPath input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ + (doesFileExist expected_name >>=) $ + flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited @?= expected + spliceTestPath :: FilePath spliceTestPath = "test/testdata/splice" diff --git a/test/testdata/splice/TDeclKindError.hs b/test/testdata/splice/TDeclKindError.hs new file mode 100644 index 0000000000..027d4f83dd --- /dev/null +++ b/test/testdata/splice/TDeclKindError.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/test/testdata/splice/TDeclKindError.hs.error b/test/testdata/splice/TDeclKindError.hs.error new file mode 100644 index 0000000000..e21e057ed1 --- /dev/null +++ b/test/testdata/splice/TDeclKindError.hs.error @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ,sigD (mkName "bar") [t|Int|] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/test/testdata/splice/TDeclKindError.hs.expected b/test/testdata/splice/TDeclKindError.hs.expected new file mode 100644 index 0000000000..b1f0250b41 --- /dev/null +++ b/test/testdata/splice/TDeclKindError.hs.expected @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +foo :: Int +foo = 42 +bar :: Int +-- Bar +-- ee +-- dddd diff --git a/test/testdata/splice/TQQDecl.hs b/test/testdata/splice/TQQDecl.hs new file mode 100644 index 0000000000..90a05ce7d3 --- /dev/null +++ b/test/testdata/splice/TQQDecl.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQDecl where +import QQ (str) + +[str|foo|] diff --git a/test/testdata/splice/TQQDecl.hs.expected b/test/testdata/splice/TQQDecl.hs.expected new file mode 100644 index 0000000000..781f23e12d --- /dev/null +++ b/test/testdata/splice/TQQDecl.hs.expected @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQDecl where +import QQ (str) + +foo :: String +foo = "foo" diff --git a/test/testdata/splice/TTypeKindError.hs b/test/testdata/splice/TTypeKindError.hs index 58631e8464..c14dc0e68c 100644 --- a/test/testdata/splice/TTypeKindError.hs +++ b/test/testdata/splice/TTypeKindError.hs @@ -4,5 +4,5 @@ module TTypeKindError where import Language.Haskell.TH ( numTyLit, litT ) import Data.Proxy ( Proxy ) -main :: $(litT (numTyLit 42)) +main :: IO () main = return () diff --git a/test/testdata/splice/TTypeKindError.hs.error b/test/testdata/splice/TTypeKindError.hs.error new file mode 100644 index 0000000000..58631e8464 --- /dev/null +++ b/test/testdata/splice/TTypeKindError.hs.error @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: $(litT (numTyLit 42)) +main = return () diff --git a/test/testdata/splice/TTypeKindError.hs.expected b/test/testdata/splice/TTypeKindError.hs.expected index 101e12e402..ef04a42611 100644 --- a/test/testdata/splice/TTypeKindError.hs.expected +++ b/test/testdata/splice/TTypeKindError.hs.expected @@ -4,5 +4,5 @@ module TTypeKindError where import Language.Haskell.TH ( numTyLit, litT ) import Data.Proxy ( Proxy ) -main :: 42 +main :: (42) main = return () From 056f76971f6149f645d2cc9d108978c244ed868d Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 2 Jan 2021 01:35:38 +0900 Subject: [PATCH 39/51] Workaround for GHC 8.8 --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 92 +++++++++++++++---- .../src/Ide/Plugin/Splice.hs | 27 +++--- 2 files changed, 85 insertions(+), 34 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 8192a2bcca..6f932c0127 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} module Ide.TreeTransform ( Graft(..), @@ -47,9 +52,10 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, showSDoc, trace) +import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) -import Control.Arrow (Arrow(second)) +import qualified "ghc" SrcLoc + ------------------------------------------------------------------------------ -- | Get the latest version of the annotated parse source. @@ -152,7 +158,7 @@ graft :: forall ast a. (Data a, ASTElement ast) => SrcSpan -> - Located ast -> + ToL ast GhcPs -> Graft (Either String) a graft dst val = Graft $ \dflags a -> do (anns, val') <- annotate dflags $ maybeParensAST val @@ -161,7 +167,7 @@ graft dst val = Graft $ \dflags a -> do everywhere' ( mkT $ \case - (L src _ :: Located ast) | src == dst -> val' + (src :: ToL ast GhcPs) | location src == dst -> val' l -> l ) a @@ -172,14 +178,14 @@ graftWithM :: forall ast m a. (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (Located ast -> TransformT m (Maybe (Located ast))) -> + (ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) -> Graft m a graftWithM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - val@(L src _ :: Located ast) - | src == dst -> do + (val :: ToL ast GhcPs) + | getLoc val == dst -> do mval <- trans val case mval of Just val' -> do @@ -197,14 +203,14 @@ graftWithSmallestM :: forall ast m a. (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (Located ast -> TransformT m (Maybe (Located ast))) -> + (ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) -> Graft m a graftWithSmallestM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - val@(L src _ :: Located ast) - | dst `isSubspanOf` src -> do + (val :: ToL ast GhcPs) + | dst `isSubspanOf` getLoc val -> do mval <- trans val case mval of Just val' -> do @@ -264,23 +270,64 @@ everywhereM' f = go go :: GenericM m go = gmapM go <=< f -class (Data ast, Outputable ast) => ASTElement ast where - parseAST :: Parser (Located ast) - maybeParensAST :: Located ast -> Located ast - -instance p ~ GhcPs => ASTElement (HsExpr p) where +class + ( Data (ast GhcPs), Outputable (ast GhcPs), + HasSrcSpan (ToL ast GhcPs), Data (ToL ast GhcPs), + Outputable (ToL ast GhcPs) + ) + => ASTElement ast where + -- | This is to absorb the implementation difference of 'LPat', + -- which is equal to Located Pat in 8.6 and 8.10, but + -- is isomorphic to Pat in 8.8. + type ToL ast p = (r :: *) | r -> ast + type ToL ast p = Located (ast p) + withL :: SrcSpan -> ast GhcPs -> ToL ast GhcPs + default withL + :: ToL ast GhcPs ~ Located (ast GhcPs) + => SrcSpan -> ast GhcPs -> ToL ast GhcPs + withL = L + toLocated :: ToL ast GhcPs -> Located (ast GhcPs) + default toLocated + :: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> Located (ast GhcPs) + toLocated = id + unLocated :: ToL ast GhcPs -> ast GhcPs + default unLocated + :: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> ast GhcPs + unLocated = unLoc + location :: ToL ast GhcPs -> SrcSpan + location = SrcLoc.getLoc . toLocated + + parseAST :: Parser (ToL ast GhcPs) + maybeParensAST :: ToL ast GhcPs -> ToL ast GhcPs + +instance ASTElement HsExpr where + type ToL HsExpr p = LHsExpr p parseAST = parseExpr maybeParensAST = parenthesize -instance p ~ GhcPs => ASTElement (Pat p) where +instance ASTElement Pat where + type ToL Pat p = LPat p +#if __GLASGOW_HASKELL__ == 808 + toLocated p@(XPat (L loc _))= L loc p + toLocated p = L noSrcSpan p + unLocated = id + withL = flip const +#else + toLocated = id + unLocated = unLoc +#endif + parseAST = parsePattern maybeParensAST = parenthesizePat appPrec -instance p ~ GhcPs => ASTElement (HsType p) where + +instance ASTElement HsType where + type ToL HsType p = LHsType p parseAST = parseType maybeParensAST = parenthesizeHsType appPrec -instance p ~ GhcPs => ASTElement (HsDecl p) where +instance ASTElement HsDecl where + type ToL HsDecl p = LHsDecl p parseAST = parseDecl maybeParensAST = id @@ -295,12 +342,17 @@ fixAnns ParsedModule {..} = ------------------------------------------------------------------------------ -- | Given an 'LHSExpr', compute its exactprint annotations. -annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate + :: forall ast. ASTElement ast + => DynFlags -> ToL ast GhcPs + -> TransformT (Either String) (Anns, ToL ast GhcPs) annotate dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast (anns, expr') <- lift $ either (Left . show) Right $ parseAST dflags uniq rendered - let anns' = setPrecedingLines expr' 0 1 anns + let anns' = setPrecedingLines + (toLocated expr' :: Located (ast GhcPs)) + 0 1 anns pure (anns', expr') -- | Given an 'LHsDecl', compute its exactprint annotations. diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index c97c75e627..e6765b107c 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -21,7 +21,6 @@ where import Control.Applicative (Alternative ((<|>))) import Control.Arrow (Arrow (first)) -import Control.Exception (SomeException) import qualified Control.Foldl as L import Control.Lens (ix, view, (%~), (<&>), (^.)) import Control.Monad @@ -167,7 +166,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = graftSpliceWith :: forall ast. HasSplice ast => - Maybe (SrcSpan, Located (ast GhcPs)) -> + Maybe (SrcSpan, ToL ast GhcPs) -> Maybe (Either String WorkspaceEdit) graftSpliceWith expandeds = expandeds <&> \(_, expanded) -> @@ -180,7 +179,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = maybe (throwE "No splcie information found") (either throwE pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans - Pat -> graftSpliceWith patSuperSpans + Pat -> graftSpliceWith @Pat patSuperSpans HsType -> graftSpliceWith typeSuperSpans HsDecl -> declSuperSpans <&> \(_, expanded) -> @@ -253,7 +252,7 @@ data SpliceClass where OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass IsHsDecl :: SpliceClass -class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where +class (Outputable (ast GhcRn), ASTElement ast) => HasSplice ast where type SpliceOf ast :: Kinds.Type -> Kinds.Type type SpliceOf ast = HsSplice matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) @@ -322,7 +321,7 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. OneToOneAST astP -> flip (transformM dflags (clientCapabilities lsp) uri) ps $ graftWithM (RealSrcSpan srcSpan) $ \case - (L _spn (matchSplice astP -> Just spl)) -> do + (toLocated -> L _spn (matchSplice astP -> Just spl)) -> do eExpr <- either (fail . show) pure =<< lift @@ -330,7 +329,7 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. gtry @_ @SomeException $ (fst <$> expandSplice astP spl) ) - Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr + Just <$> either (pure . withL _spn) (unRenamedE dflags) eExpr _ -> pure Nothing pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl @@ -353,14 +352,14 @@ unRenamedE :: (Fail.MonadFail m, HasSplice ast) => DynFlags -> ast GhcRn -> - TransformT m (Located (ast GhcPs)) + TransformT m (ToL ast GhcPs) unRenamedE dflags expr = do uniq <- show <$> uniqueSrcSpanT - (anns, expr') <- + (anns, expr' :: ToL ast GhcPs) <- either (fail . show) pure $ - parseAST @(ast GhcPs) dflags uniq $ + parseAST @ast dflags uniq $ showSDoc dflags $ ppr expr - let _anns' = setPrecedingLines expr' 0 1 anns + let _anns' = setPrecedingLines (toLocated expr') 0 1 anns pure expr' -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) @@ -397,20 +396,20 @@ codeAction _ state plId docId ran _ = mkQ Nothing ( \case - (L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs) + ((toLocated @HsExpr -> L l@(RealSrcSpan spLoc) HsSpliceE {}) :: LHsExpr GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) _ -> Nothing ) `extQ` \case - (L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs) + ((toLocated @Pat -> L l@(RealSrcSpan spLoc) SplicePat {}) :: LPat GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat) _ -> Nothing `extQ` \case - (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) + ((toLocated @HsType -> L l@(RealSrcSpan spLoc) HsSpliceTy {}) :: LHsType GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) _ -> Nothing `extQ` \case - (L l@(RealSrcSpan spLoc) SpliceD {} :: LHsDecl GhcPs) + ((toLocated @HsDecl -> L l@(RealSrcSpan spLoc) SpliceD {}) :: LHsDecl GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl) _ -> Nothing From 8fa549dd61be0afc21e4e3417e64460cd0a43e80 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 2 Jan 2021 02:57:50 +0900 Subject: [PATCH 40/51] Revert "Workaround for GHC 8.8" This reverts commit 056f76971f6149f645d2cc9d108978c244ed868d. --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 92 ++++--------------- .../src/Ide/Plugin/Splice.hs | 27 +++--- 2 files changed, 34 insertions(+), 85 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 6f932c0127..8192a2bcca 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilyDependencies #-} module Ide.TreeTransform ( Graft(..), @@ -52,10 +47,9 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, showSDoc) +import Outputable (Outputable, ppr, showSDoc, trace) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) -import qualified "ghc" SrcLoc - +import Control.Arrow (Arrow(second)) ------------------------------------------------------------------------------ -- | Get the latest version of the annotated parse source. @@ -158,7 +152,7 @@ graft :: forall ast a. (Data a, ASTElement ast) => SrcSpan -> - ToL ast GhcPs -> + Located ast -> Graft (Either String) a graft dst val = Graft $ \dflags a -> do (anns, val') <- annotate dflags $ maybeParensAST val @@ -167,7 +161,7 @@ graft dst val = Graft $ \dflags a -> do everywhere' ( mkT $ \case - (src :: ToL ast GhcPs) | location src == dst -> val' + (L src _ :: Located ast) | src == dst -> val' l -> l ) a @@ -178,14 +172,14 @@ graftWithM :: forall ast m a. (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) -> + (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a graftWithM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - (val :: ToL ast GhcPs) - | getLoc val == dst -> do + val@(L src _ :: Located ast) + | src == dst -> do mval <- trans val case mval of Just val' -> do @@ -203,14 +197,14 @@ graftWithSmallestM :: forall ast m a. (Fail.MonadFail m, Data a, ASTElement ast) => SrcSpan -> - (ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) -> + (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a graftWithSmallestM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - (val :: ToL ast GhcPs) - | dst `isSubspanOf` getLoc val -> do + val@(L src _ :: Located ast) + | dst `isSubspanOf` src -> do mval <- trans val case mval of Just val' -> do @@ -270,64 +264,23 @@ everywhereM' f = go go :: GenericM m go = gmapM go <=< f -class - ( Data (ast GhcPs), Outputable (ast GhcPs), - HasSrcSpan (ToL ast GhcPs), Data (ToL ast GhcPs), - Outputable (ToL ast GhcPs) - ) - => ASTElement ast where - -- | This is to absorb the implementation difference of 'LPat', - -- which is equal to Located Pat in 8.6 and 8.10, but - -- is isomorphic to Pat in 8.8. - type ToL ast p = (r :: *) | r -> ast - type ToL ast p = Located (ast p) - withL :: SrcSpan -> ast GhcPs -> ToL ast GhcPs - default withL - :: ToL ast GhcPs ~ Located (ast GhcPs) - => SrcSpan -> ast GhcPs -> ToL ast GhcPs - withL = L - toLocated :: ToL ast GhcPs -> Located (ast GhcPs) - default toLocated - :: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> Located (ast GhcPs) - toLocated = id - unLocated :: ToL ast GhcPs -> ast GhcPs - default unLocated - :: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> ast GhcPs - unLocated = unLoc - location :: ToL ast GhcPs -> SrcSpan - location = SrcLoc.getLoc . toLocated - - parseAST :: Parser (ToL ast GhcPs) - maybeParensAST :: ToL ast GhcPs -> ToL ast GhcPs - -instance ASTElement HsExpr where - type ToL HsExpr p = LHsExpr p +class (Data ast, Outputable ast) => ASTElement ast where + parseAST :: Parser (Located ast) + maybeParensAST :: Located ast -> Located ast + +instance p ~ GhcPs => ASTElement (HsExpr p) where parseAST = parseExpr maybeParensAST = parenthesize -instance ASTElement Pat where - type ToL Pat p = LPat p -#if __GLASGOW_HASKELL__ == 808 - toLocated p@(XPat (L loc _))= L loc p - toLocated p = L noSrcSpan p - unLocated = id - withL = flip const -#else - toLocated = id - unLocated = unLoc -#endif - +instance p ~ GhcPs => ASTElement (Pat p) where parseAST = parsePattern maybeParensAST = parenthesizePat appPrec - -instance ASTElement HsType where - type ToL HsType p = LHsType p +instance p ~ GhcPs => ASTElement (HsType p) where parseAST = parseType maybeParensAST = parenthesizeHsType appPrec -instance ASTElement HsDecl where - type ToL HsDecl p = LHsDecl p +instance p ~ GhcPs => ASTElement (HsDecl p) where parseAST = parseDecl maybeParensAST = id @@ -342,17 +295,12 @@ fixAnns ParsedModule {..} = ------------------------------------------------------------------------------ -- | Given an 'LHSExpr', compute its exactprint annotations. -annotate - :: forall ast. ASTElement ast - => DynFlags -> ToL ast GhcPs - -> TransformT (Either String) (Anns, ToL ast GhcPs) +annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) annotate dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast (anns, expr') <- lift $ either (Left . show) Right $ parseAST dflags uniq rendered - let anns' = setPrecedingLines - (toLocated expr' :: Located (ast GhcPs)) - 0 1 anns + let anns' = setPrecedingLines expr' 0 1 anns pure (anns', expr') -- | Given an 'LHsDecl', compute its exactprint annotations. diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index e6765b107c..c97c75e627 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -21,6 +21,7 @@ where import Control.Applicative (Alternative ((<|>))) import Control.Arrow (Arrow (first)) +import Control.Exception (SomeException) import qualified Control.Foldl as L import Control.Lens (ix, view, (%~), (<&>), (^.)) import Control.Monad @@ -166,7 +167,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = graftSpliceWith :: forall ast. HasSplice ast => - Maybe (SrcSpan, ToL ast GhcPs) -> + Maybe (SrcSpan, Located (ast GhcPs)) -> Maybe (Either String WorkspaceEdit) graftSpliceWith expandeds = expandeds <&> \(_, expanded) -> @@ -179,7 +180,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = maybe (throwE "No splcie information found") (either throwE pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans - Pat -> graftSpliceWith @Pat patSuperSpans + Pat -> graftSpliceWith patSuperSpans HsType -> graftSpliceWith typeSuperSpans HsDecl -> declSuperSpans <&> \(_, expanded) -> @@ -252,7 +253,7 @@ data SpliceClass where OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass IsHsDecl :: SpliceClass -class (Outputable (ast GhcRn), ASTElement ast) => HasSplice ast where +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) @@ -321,7 +322,7 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. OneToOneAST astP -> flip (transformM dflags (clientCapabilities lsp) uri) ps $ graftWithM (RealSrcSpan srcSpan) $ \case - (toLocated -> L _spn (matchSplice astP -> Just spl)) -> do + (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- either (fail . show) pure =<< lift @@ -329,7 +330,7 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. gtry @_ @SomeException $ (fst <$> expandSplice astP spl) ) - Just <$> either (pure . withL _spn) (unRenamedE dflags) eExpr + Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr _ -> pure Nothing pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl @@ -352,14 +353,14 @@ unRenamedE :: (Fail.MonadFail m, HasSplice ast) => DynFlags -> ast GhcRn -> - TransformT m (ToL ast GhcPs) + TransformT m (Located (ast GhcPs)) unRenamedE dflags expr = do uniq <- show <$> uniqueSrcSpanT - (anns, expr' :: ToL ast GhcPs) <- + (anns, expr') <- either (fail . show) pure $ - parseAST @ast dflags uniq $ + parseAST @(ast GhcPs) dflags uniq $ showSDoc dflags $ ppr expr - let _anns' = setPrecedingLines (toLocated expr') 0 1 anns + let _anns' = setPrecedingLines expr' 0 1 anns pure expr' -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) @@ -396,20 +397,20 @@ codeAction _ state plId docId ran _ = mkQ Nothing ( \case - ((toLocated @HsExpr -> L l@(RealSrcSpan spLoc) HsSpliceE {}) :: LHsExpr GhcPs) + (L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) _ -> Nothing ) `extQ` \case - ((toLocated @Pat -> L l@(RealSrcSpan spLoc) SplicePat {}) :: LPat GhcPs) + (L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat) _ -> Nothing `extQ` \case - ((toLocated @HsType -> L l@(RealSrcSpan spLoc) HsSpliceTy {}) :: LHsType GhcPs) + (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) _ -> Nothing `extQ` \case - ((toLocated @HsDecl -> L l@(RealSrcSpan spLoc) SpliceD {}) :: LHsDecl GhcPs) + (L l@(RealSrcSpan spLoc) SpliceD {} :: LHsDecl GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl) _ -> Nothing From d3e01855bc6c2057d0b4417b41d1808aa15c5895 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 2 Jan 2021 03:15:41 +0900 Subject: [PATCH 41/51] Unsupport pattern splices GHC 8.8 --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 6 +- .../src/Ide/Plugin/Splice.hs | 40 +++++++-- test/functional/Splice.hs | 86 +++++++++++-------- 3 files changed, 86 insertions(+), 46 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 8192a2bcca..653c8d549c 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -47,9 +48,8 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, showSDoc, trace) +import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) -import Control.Arrow (Arrow(second)) ------------------------------------------------------------------------------ -- | Get the latest version of the annotated parse source. @@ -272,9 +272,11 @@ instance p ~ GhcPs => ASTElement (HsExpr p) where parseAST = parseExpr maybeParensAST = parenthesize +#if __GLASGOW_HASKELL__ != 808 instance p ~ GhcPs => ASTElement (Pat p) where parseAST = parsePattern maybeParensAST = parenthesizePat appPrec +#endif instance p ~ GhcPs => ASTElement (HsType p) where parseAST = parseType diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index c97c75e627..3add5ab1a2 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -21,7 +22,6 @@ where import Control.Applicative (Alternative ((<|>))) import Control.Arrow (Arrow (first)) -import Control.Exception (SomeException) import qualified Control.Foldl as L import Control.Lens (ix, view, (%~), (<&>), (^.)) import Control.Monad @@ -83,6 +83,16 @@ expandTHSplice :: expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do +#if __GLASGOW_HASKELL__ == 808 + case spliceContext of + Pat -> do + reportEditor lsp MtInfo + [ "On GHC 8.8, pattern splice expansion is not supported, due to the API change (see issue #759)." + , "Please use GHC 8.6 or GHC 8.10+, or you can send a PR :-)" + ] + mzero + _ -> pure () +#endif fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri eedits <- ( lift . runExceptT . withTypeChecked fp @@ -112,10 +122,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp (TcModuleResult {..}, _) <- maybe - (throwE "Splice expansion: Type-checking information not found in cache.\n\ - \You can once delete or replace the macro with placeholder, \ - \convince the type checker and then revert to original \ - \(errornous) macro and expand splice again." + (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 @@ -157,7 +164,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = let dflags = hsc_dflags $ hscEnv hscEnvEq exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices - patSuperSpans = + _patSuperSpans = listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = listToMaybe $ findSubSpansDesc srcSpan typeSplices @@ -177,10 +184,17 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = uri (graft (RealSrcSpan spliceSpan) expanded) ps - maybe (throwE "No splcie information found") (either throwE pure) $ + maybe (throwE "No splice information found") (either throwE pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans - Pat -> graftSpliceWith patSuperSpans + Pat -> +#if __GLASGOW_HASKELL__ == 808 + pure $ + Left "In GHC 8.8, pattern splice expansion is not supported due to the change of GHC API internal. You can use it in 8.6 and 8.10." +#else + graftSpliceWith _patSuperSpans + +#endif HsType -> graftSpliceWith typeSuperSpans HsDecl -> declSuperSpans <&> \(_, expanded) -> @@ -264,10 +278,13 @@ instance HasSplice HsExpr where matchSplice _ _ = Nothing expandSplice _ = fmap (first Right) . rnSpliceExpr +#if __GLASGOW_HASKELL__ != 808 instance HasSplice Pat where matchSplice _ (SplicePat _ spl) = Just spl matchSplice _ _ = Nothing expandSplice _ = rnSplicePat +#endif + instance HasSplice HsType where matchSplice _ (HsSpliceTy _ spl) = Just spl @@ -278,7 +295,11 @@ classifyAST :: SpliceContext -> SpliceClass classifyAST = \case Expr -> OneToOneAST @HsExpr proxy# HsDecl -> IsHsDecl +#if __GLASGOW_HASKELL__ == 808 + Pat -> error "GHC 8.8" +#else Pat -> OneToOneAST @Pat proxy# +#endif HsType -> OneToOneAST @HsType proxy# reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () @@ -401,10 +422,13 @@ codeAction _ state plId docId ran _ = | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) _ -> Nothing ) +#if __GLASGOW_HASKELL__ == 808 +#else `extQ` \case (L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat) _ -> Nothing +#endif `extQ` \case (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index 5b2ca01697..dce881e4eb 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} module Splice (tests) where @@ -29,6 +30,11 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit +#if __GLASGOW_HASKELL__ == 808 +import Test.Tasty.ExpectedFailure +#endif + + tests :: TestTree tests = testGroup @@ -41,16 +47,22 @@ tests = , goldenTest "TQQExp.hs" Inplace 6 25 , goldenTest "TQQExpError.hs" Inplace 6 13 , goldenTest "TQQExpError.hs" Inplace 6 22 - , goldenTest "TSimplePat.hs" Inplace 6 3 - , goldenTest "TSimplePat.hs" Inplace 6 22 - , goldenTest "TSimplePat.hs" Inplace 6 3 - , goldenTest "TSimplePat.hs" Inplace 6 22 - , goldenTest "TErrorPat.hs" Inplace 6 3 - , goldenTest "TErrorPat.hs" Inplace 6 18 - , goldenTest "TQQPat.hs" Inplace 6 3 - , goldenTest "TQQPat.hs" Inplace 6 11 - , goldenTest "TQQPatError.hs" Inplace 6 3 - , goldenTest "TQQPatError.hs" Inplace 6 11 + , +#if __GLASGOW_HASKELL__ == 808 + expectFailBecause "Pattern splice expansions are unsupported on GHC 8.8, due to LPat = Pat problem" $ +#endif + testGroup "Pattern Splices" + [ goldenTest "TSimplePat.hs" Inplace 6 3 + , goldenTest "TSimplePat.hs" Inplace 6 22 + , goldenTest "TSimplePat.hs" Inplace 6 3 + , goldenTest "TSimplePat.hs" Inplace 6 22 + , goldenTest "TErrorPat.hs" Inplace 6 3 + , goldenTest "TErrorPat.hs" Inplace 6 18 + , goldenTest "TQQPat.hs" Inplace 6 3 + , goldenTest "TQQPat.hs" Inplace 6 11 + , goldenTest "TQQPatError.hs" Inplace 6 3 + , goldenTest "TQQPatError.hs" Inplace 6 11 + ] , goldenTest "TSimpleType.hs" Inplace 5 12 , goldenTest "TSimpleType.hs" Inplace 5 22 , goldenTest "TTypeTypeError.hs" Inplace 7 12 @@ -72,19 +84,20 @@ goldenTest input tc line col = doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) <- - pure $ find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions - executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message - edited <- documentContents doc - let expected_name = spliceTestPath input <.> "expected" - -- Write golden tests if they don't already exist - liftIO $ - (doesFileExist expected_name >>=) $ - flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited @?= expected + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of + Just (CACodeAction CodeAction {_command = Just c}) -> do + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + let expected_name = spliceTestPath input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ + (doesFileExist expected_name >>=) $ + flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited @?= expected + _ -> liftIO $ assertFailure "No CodeAction detected" goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTestWithEdit input tc line col = @@ -104,19 +117,20 @@ goldenTestWithEdit input tc line col = changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] void waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) <- - pure $ find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions - executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message - edited <- documentContents doc - let expected_name = spliceTestPath input <.> "expected" - -- Write golden tests if they don't already exist - liftIO $ - (doesFileExist expected_name >>=) $ - flip unless $ do - T.writeFile expected_name edited - expected <- liftIO $ T.readFile expected_name - liftIO $ edited @?= expected + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of + Just (CACodeAction CodeAction {_command = Just c}) -> do + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + let expected_name = spliceTestPath input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ + (doesFileExist expected_name >>=) $ + flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited @?= expected + _ -> liftIO $ assertFailure "No CodeAction detected" spliceTestPath :: FilePath spliceTestPath = "test/testdata/splice" From e62b03e37e7e634d08eb346813481080df1bf23e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 2 Jan 2021 03:28:51 +0900 Subject: [PATCH 42/51] Corrects line position in GoToHover --- ghcide/test/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index a86293225a..f0e1b516db 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2417,7 +2417,7 @@ findDefinitionAndHoverTests = let , testGroup "hover" $ mapMaybe snd tests , checkFileCompiles sourceFilePath $ expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ] + [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ] , testGroup "type-definition" typeDefinitionTests ] typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" From 10b7ce4746659fd330709f192aad396e0f551804 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 3 Jan 2021 15:30:36 +0900 Subject: [PATCH 43/51] Increases wait time --- test/functional/Splice.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index dce881e4eb..985a075fec 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -111,7 +111,7 @@ goldenTestWithEdit input tc line col = { _start = Position 0 0 , _end = Position (length lns + 1) 1 } - liftIO $ sleep 1 + liftIO $ sleep 3 alt <- liftIO $ T.readFile (spliceTestPath input <.> "error") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] From 0b02765b0ed9b9bac6dd73f611b57fc3de586c1e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 3 Jan 2021 16:20:14 +0900 Subject: [PATCH 44/51] Includes only related changes only --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 379 +++++++------------ 1 file changed, 141 insertions(+), 238 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 6ec36d6f59..39f61b5fed 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -6,45 +5,47 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} -{- | A Shake implementation of the compiler service, built - using the "Shaker" abstraction layer for in-memory use. --} -module Development.IDE.Core.RuleTypes - ( module Development.IDE.Core.RuleTypes, - ) -where +-- | A Shake implementation of the compiler service, built +-- using the "Shaker" abstraction layer for in-memory use. +-- +module Development.IDE.Core.RuleTypes( + module Development.IDE.Core.RuleTypes + ) where -import Control.DeepSeq +import Control.DeepSeq import Control.Lens import Data.Aeson.Types (Value) import Data.Binary -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Hashable -import Data.Int (Int64) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Text (Text) -import Data.Typeable +import Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util -import Development.IDE.Import.DependencyInformation -import Development.IDE.Import.FindImports (ArtifactsLocation) -import Development.IDE.Spans.Common -import Development.IDE.Spans.LocalBindings import Development.IDE.Types.KnownTargets -import Development.IDE.Types.Options (IdeGhcSession) -import Development.Shake -import GHC.Generics (Generic) -import GHC.Serialized (Serialized) -import HscTypes (HomeModInfo, ModGuts, hm_iface, hm_linkable) -import Language.Haskell.LSP.Types (NormalizedFilePath) +import Data.Hashable +import Data.Typeable +import qualified Data.Set as S +import qualified Data.Map as M +import Development.Shake +import GHC.Generics (Generic) + import Module (InstalledUnitId) +import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) + +import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings +import Development.IDE.Import.FindImports (ArtifactsLocation) +import Data.ByteString (ByteString) +import Language.Haskell.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) +import qualified Data.ByteString.Char8 as BS +import Development.IDE.Types.Options (IdeGhcSession) +import Data.Text (Text) +import Data.Int (Int64) +import GHC.Serialized (Serialized) data LinkableType = ObjectLinkable | BCOLinkable - deriving (Eq, Ord, Show) + deriving (Eq,Ord,Show) -- NOTATION -- Foo+ means Foo for the dependencies @@ -53,28 +54,22 @@ data LinkableType = ObjectLinkable | BCOLinkable -- | The parse tree for the file using GetFileContents type instance RuleResult GetParsedModule = ParsedModule -{- | The dependency information produced by following the imports recursively. - This rule will succeed even if there is an error, e.g., a module could not be located, - a module could not be parsed or an import cycle. --} +-- | The dependency information produced by following the imports recursively. +-- This rule will succeed even if there is an error, e.g., a module could not be located, +-- a module could not be parsed or an import cycle. type instance RuleResult GetDependencyInformation = DependencyInformation -{- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. - This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. --} +-- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. +-- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. type instance RuleResult GetDependencies = TransitiveDependencies type instance RuleResult GetModuleGraph = DependencyInformation data GetKnownTargets = GetKnownTargets - deriving (Show, Generic, Eq, Ord) - + deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets - -instance NFData GetKnownTargets - -instance Binary GetKnownTargets - +instance NFData GetKnownTargets +instance Binary GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets -- | Convert to Core, requires TypeCheck* @@ -82,30 +77,21 @@ type instance RuleResult GenerateCore = ModGuts data GenerateCore = GenerateCore deriving (Eq, Show, Typeable, Generic) - instance Hashable GenerateCore - -instance NFData GenerateCore - -instance Binary GenerateCore +instance NFData GenerateCore +instance Binary GenerateCore data GetImportMap = GetImportMap deriving (Eq, Show, Typeable, Generic) - instance Hashable GetImportMap - -instance NFData GetImportMap - -instance Binary GetImportMap +instance NFData GetImportMap +instance Binary GetImportMap type instance RuleResult GetImportMap = ImportMap - newtype ImportMap = ImportMap - { -- | Where are the modules imported by this file located? - importMap :: M.Map ModuleName NormalizedFilePath - } - deriving stock (Show) - deriving newtype (NFData) + { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? + } deriving stock Show + deriving newtype NFData data Splices = Splices { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] @@ -133,19 +119,17 @@ instance NFData Splices where liftRnf rwhnf patSplices `seq` liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` () -{- | Contains the typechecked module and the OrigNameCache entry for - that module. --} +-- | Contains the typechecked module and the OrigNameCache entry for +-- that module. data TcModuleResult = TcModuleResult { tmrParsed :: ParsedModule , tmrRenamed :: RenamedSource , tmrTypechecked :: TcGblEnv - , -- | Typechecked splice information - tmrTopLevelSplices :: Splices - , -- | Did we defer any type errors for this module? - tmrDeferedError :: !Bool + , tmrTopLevelSplices :: Splices + -- ^ Typechecked splice information + , tmrDeferedError :: !Bool + -- ^ Did we defer any type errors for this module? } - instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -157,20 +141,19 @@ tmrModSummary = pm_mod_summary . tmrParsed data HiFileResult = HiFileResult { hirModSummary :: !ModSummary - , -- Bang patterns here are important to stop the result retaining - -- a reference to a typechecked module - - -- | Includes the Linkable iff we need object files - hirHomeMod :: !HomeModInfo + -- Bang patterns here are important to stop the result retaining + -- a reference to a typechecked module + , hirHomeMod :: !HomeModInfo + -- ^ Includes the Linkable iff we need object files } hiFileFingerPrint :: HiFileResult -> ByteString hiFileFingerPrint hfr = ifaceBS <> linkableBS - where - ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes - linkableBS = case hm_linkable $ hirHomeMod hfr of - Nothing -> "" - Just l -> BS.pack $ show $ linkableTime l + where + ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes + linkableBS = case hm_linkable $ hirHomeMod hfr of + Nothing -> "" + Just l -> BS.pack $ show $ linkableTime l hirModIface :: HiFileResult -> ModIface hirModIface = hm_iface . hirHomeMod @@ -182,14 +165,15 @@ instance Show HiFileResult where show = show . hirModSummary -- | Save the uncompressed AST here, we compress it just before writing to disk -data HieAstResult = HAR - { hieModule :: Module - , hieAst :: !(HieASTs Type) - , -- | Lazy because its value only depends on the hieAst, which is bundled in this type - -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same - -- as that of `hieAst` - refMap :: RefMap - } +data HieAstResult + = HAR + { hieModule :: Module + , hieAst :: !(HieASTs Type) + , refMap :: RefMap + -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type + -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same + -- as that of `hieAst` + } instance NFData HieAstResult where rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf @@ -207,7 +191,6 @@ type instance RuleResult GetHieAst = HieAstResult type instance RuleResult GetBindings = Bindings data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} - instance NFData DocAndKindMap where rnf (DKMap a b) = rwhnf a `seq` rwhnf b @@ -222,28 +205,24 @@ type instance RuleResult GhcSession = HscEnvEq -- | A GHC session preloaded with all the dependencies type instance RuleResult GhcSessionDeps = HscEnvEq -{- | Resolve the imports in a module to the file path of a module - in the same package or the package id of another package. --} +-- | Resolve the imports in a module to the file path of a module +-- in the same package or the package id of another package. type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId) -{- | This rule is used to report import cycles. It depends on GetDependencyInformation. - We cannot report the cycles directly from GetDependencyInformation since - we can only report diagnostics for the current file. --} +-- | This rule is used to report import cycles. It depends on GetDependencyInformation. +-- We cannot report the cycles directly from GetDependencyInformation since +-- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () -{- | Read the module interface file from disk. Throws an error for VFS files. - This is an internal rule, use 'GetModIface' instead. --} +-- | Read the module interface file from disk. Throws an error for VFS files. +-- This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDisk = HiFileResult -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult -{- | Get a module interface details, without the Linkable - For better early cuttoff --} +-- | Get a module interface details, without the Linkable +-- For better early cuttoff type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. @@ -251,8 +230,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text) -- The Shake key type for getModificationTime queries data GetModificationTime = GetModificationTime_ - { -- | If false, missing file diagnostics are not reported - missingFileDiagnostics :: Bool + { missingFileDiagnostics :: Bool + -- ^ If false, missing file diagnostics are not reported } deriving (Show, Generic) @@ -266,12 +245,11 @@ instance Hashable GetModificationTime where -- independent from the 'missingFileDiagnostics' field hashWithSalt salt _ = salt -instance NFData GetModificationTime - -instance Binary GetModificationTime +instance NFData GetModificationTime +instance Binary GetModificationTime pattern GetModificationTime :: GetModificationTime -pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics = True} +pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion @@ -279,239 +257,167 @@ type instance RuleResult GetModificationTime = FileVersion data FileVersion = VFSVersion !Int | ModificationTime - !Int64 - -- ^ Large unit (platform dependent, do not make assumptions) - !Int64 - -- ^ Small unit (platform dependent, do not make assumptions) + !Int64 -- ^ Large unit (platform dependent, do not make assumptions) + !Int64 -- ^ Small unit (platform dependent, do not make assumptions) deriving (Show, Generic) instance NFData FileVersion vfsVersion :: FileVersion -> Maybe Int vfsVersion (VFSVersion i) = Just i -vfsVersion ModificationTime {} = Nothing +vfsVersion ModificationTime{} = Nothing data GetFileContents = GetFileContents deriving (Eq, Show, Generic) - instance Hashable GetFileContents +instance NFData GetFileContents +instance Binary GetFileContents -instance NFData GetFileContents - -instance Binary GetFileContents data FileOfInterestStatus = OnDisk | Modified - deriving (Eq, Show, Typeable, Generic) - + deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus - -instance NFData FileOfInterestStatus - -instance Binary FileOfInterestStatus +instance NFData FileOfInterestStatus +instance Binary FileOfInterestStatus data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) - + deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterestResult - -instance NFData IsFileOfInterestResult - -instance Binary IsFileOfInterestResult +instance NFData IsFileOfInterestResult +instance Binary IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult -{- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. - without needing to parse the entire source --} -type instance RuleResult GetModSummary = (ModSummary, [LImportDecl GhcPs]) +-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. +-- without needing to parse the entire source +type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs]) -{- | Generate a ModSummary with the timestamps elided, - for more successful early cutoff --} -type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary, [LImportDecl GhcPs]) +-- | Generate a ModSummary with the timestamps elided, +-- for more successful early cutoff +type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs]) data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) - instance Hashable GetParsedModule - -instance NFData GetParsedModule - -instance Binary GetParsedModule +instance NFData GetParsedModule +instance Binary GetParsedModule data GetLocatedImports = GetLocatedImports deriving (Eq, Show, Typeable, Generic) - instance Hashable GetLocatedImports - -instance NFData GetLocatedImports - -instance Binary GetLocatedImports +instance NFData GetLocatedImports +instance Binary GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Bool data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Typeable, Generic) - instance Hashable NeedsCompilation - -instance NFData NeedsCompilation - -instance Binary NeedsCompilation +instance NFData NeedsCompilation +instance Binary NeedsCompilation data GetDependencyInformation = GetDependencyInformation deriving (Eq, Show, Typeable, Generic) - instance Hashable GetDependencyInformation - -instance NFData GetDependencyInformation - -instance Binary GetDependencyInformation +instance NFData GetDependencyInformation +instance Binary GetDependencyInformation data GetModuleGraph = GetModuleGraph deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModuleGraph - -instance NFData GetModuleGraph - -instance Binary GetModuleGraph +instance NFData GetModuleGraph +instance Binary GetModuleGraph data ReportImportCycles = ReportImportCycles deriving (Eq, Show, Typeable, Generic) - instance Hashable ReportImportCycles - -instance NFData ReportImportCycles - -instance Binary ReportImportCycles +instance NFData ReportImportCycles +instance Binary ReportImportCycles data GetDependencies = GetDependencies deriving (Eq, Show, Typeable, Generic) - instance Hashable GetDependencies - -instance NFData GetDependencies - -instance Binary GetDependencies +instance NFData GetDependencies +instance Binary GetDependencies data TypeCheck = TypeCheck deriving (Eq, Show, Typeable, Generic) - instance Hashable TypeCheck - -instance NFData TypeCheck - -instance Binary TypeCheck +instance NFData TypeCheck +instance Binary TypeCheck data GetDocMap = GetDocMap deriving (Eq, Show, Typeable, Generic) - instance Hashable GetDocMap - -instance NFData GetDocMap - -instance Binary GetDocMap +instance NFData GetDocMap +instance Binary GetDocMap data GetHieAst = GetHieAst deriving (Eq, Show, Typeable, Generic) - instance Hashable GetHieAst - -instance NFData GetHieAst - -instance Binary GetHieAst +instance NFData GetHieAst +instance Binary GetHieAst data GetBindings = GetBindings deriving (Eq, Show, Typeable, Generic) - instance Hashable GetBindings - -instance NFData GetBindings - -instance Binary GetBindings +instance NFData GetBindings +instance Binary GetBindings data GhcSession = GhcSession deriving (Eq, Show, Typeable, Generic) - instance Hashable GhcSession - -instance NFData GhcSession - -instance Binary GhcSession +instance NFData GhcSession +instance Binary GhcSession data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) - instance Hashable GhcSessionDeps - -instance NFData GhcSessionDeps - -instance Binary GhcSessionDeps +instance NFData GhcSessionDeps +instance Binary GhcSessionDeps data GetModIfaceFromDisk = GetModIfaceFromDisk deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModIfaceFromDisk - -instance NFData GetModIfaceFromDisk - -instance Binary GetModIfaceFromDisk +instance NFData GetModIfaceFromDisk +instance Binary GetModIfaceFromDisk data GetModIface = GetModIface deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModIface - -instance NFData GetModIface - -instance Binary GetModIface +instance NFData GetModIface +instance Binary GetModIface data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModIfaceWithoutLinkable - -instance NFData GetModIfaceWithoutLinkable - -instance Binary GetModIfaceWithoutLinkable +instance NFData GetModIfaceWithoutLinkable +instance Binary GetModIfaceWithoutLinkable data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) - instance Hashable IsFileOfInterest - -instance NFData IsFileOfInterest - -instance Binary IsFileOfInterest +instance NFData IsFileOfInterest +instance Binary IsFileOfInterest data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModSummaryWithoutTimestamps - -instance NFData GetModSummaryWithoutTimestamps - -instance Binary GetModSummaryWithoutTimestamps +instance NFData GetModSummaryWithoutTimestamps +instance Binary GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary deriving (Eq, Show, Typeable, Generic) - instance Hashable GetModSummary - -instance NFData GetModSummary - -instance Binary GetModSummary +instance NFData GetModSummary +instance Binary GetModSummary -- | Get the vscode client settings stored in the ide state data GetClientSettings = GetClientSettings deriving (Eq, Show, Typeable, Generic) - instance Hashable GetClientSettings - -instance NFData GetClientSettings - -instance Binary GetClientSettings +instance NFData GetClientSettings +instance Binary GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) @@ -521,12 +427,9 @@ type instance RuleResult GetClientSettings = Hashed (Maybe Value) type instance RuleResult GhcSessionIO = IdeGhcSession data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) - instance Hashable GhcSessionIO - -instance NFData GhcSessionIO - -instance Binary GhcSessionIO +instance NFData GhcSessionIO +instance Binary GhcSessionIO makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) From f2efe7cc1d0a10e84eec00a684253559ad2bde44 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 3 Jan 2021 17:57:42 +0900 Subject: [PATCH 45/51] Optimises `something'` --- .../src/Ide/Plugin/Splice.hs | 65 ++++++++++++++----- 1 file changed, 47 insertions(+), 18 deletions(-) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 3add5ab1a2..dcd362b65b 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -54,6 +55,7 @@ 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 = @@ -384,6 +386,14 @@ unRenamedE dflags expr = do 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 @@ -413,34 +423,53 @@ codeAction _ state plId docId ran _ = theUri = docId ^. J.uri detectSplice :: RealSrcSpan -> - GenericQ (Maybe (RealSrcSpan, SpliceContext)) + GenericQ (SearchResult (RealSrcSpan, SpliceContext)) detectSplice spn = mkQ - Nothing + Continue ( \case - (L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr) - _ -> Nothing + (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case expr of + HsSpliceE {} -> Here (spLoc, Expr) + _ -> Continue + _ -> Stop ) #if __GLASGOW_HASKELL__ == 808 #else `extQ` \case - (L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat) - _ -> Nothing + (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case pat of + SplicePat{} -> Here (spLoc, Pat) + _ -> Continue + _ -> Stop #endif `extQ` \case - (L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType) - _ -> Nothing + (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) SpliceD {} :: LHsDecl GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl) - _ -> Nothing - --- | Like 'something', but performs in bottom-up manner. -something' :: forall a. GenericQ (Maybe a) -> GenericQ (Maybe a) -something' = everything (flip (<|>)) + (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) From f71b51d575fd73fffc996fd50f4a700b7c7f3b64 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 3 Jan 2021 20:22:03 +0900 Subject: [PATCH 46/51] Adds hie.yaml --- test/testdata/splice/.gitignore | 1 + test/testdata/splice/hie.yaml | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 test/testdata/splice/.gitignore create mode 100644 test/testdata/splice/hie.yaml diff --git a/test/testdata/splice/.gitignore b/test/testdata/splice/.gitignore new file mode 100644 index 0000000000..229336d2f3 --- /dev/null +++ b/test/testdata/splice/.gitignore @@ -0,0 +1 @@ +!hie.yaml diff --git a/test/testdata/splice/hie.yaml b/test/testdata/splice/hie.yaml new file mode 100644 index 0000000000..fee6e3451a --- /dev/null +++ b/test/testdata/splice/hie.yaml @@ -0,0 +1,20 @@ +cradle: + direct: + arguments: + - QQ.hs + - TQQExpError.hs + - TSimpleExp.hs + - TDeclKindError.hs + - TQQPat.hs + - TSimplePat.hs + - TErrorExp.hs + - TQQPatError.hs + - TSimpleType.hs + - TErrorPat.hs + - TQQType.hs + - TTypeKindError.hs + - TQQDecl.hs + - TQQTypeTypeError.hs + - TTypeTypeError.hs + - TQQExp.hs + - TSimpleDecl.hs From 96a14b1d0054ef37e3ecd09ed1755c4c6b581404 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 4 Jan 2021 01:27:38 +0900 Subject: [PATCH 47/51] circie ci: Modifies stack-8.10.3.yaml --- stack-8.10.3.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 25e791c006..8375d928e8 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -5,12 +5,14 @@ packages: - ./hie-compat - ./ghcide/ - ./hls-plugin-api + - ./hls-exactprint-utils # - ./shake-bench - ./plugins/hls-class-plugin - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin - ./plugins/tactics ghc-options: From 1c4242117e1bb0a6c6790138b3677efd11357122 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 4 Jan 2021 10:38:23 +0900 Subject: [PATCH 48/51] Forgot to update dflags in auto-expansion with default strategy --- .../src/Ide/Plugin/Splice.hs | 38 ++++++++++--------- test/functional/Splice.hs | 1 + test/testdata/splice/TTypeAppExp.hs | 7 ++++ test/testdata/splice/hie.yaml | 1 + 4 files changed, 30 insertions(+), 17 deletions(-) create mode 100644 test/testdata/splice/TTypeAppExp.hs diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index dcd362b65b..8dc0149d3b 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -137,15 +137,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = liftIO $ runAction "expandTHSplice.fallback.GetParsedModule" ideState $ use_ GetParsedModule fp - let ps = annotateParsedSource pm - hscEnvEq <- - liftIO $ - runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ - use_ GhcSessionDeps fp - let hscEnv0 = hscEnvWithImportPaths hscEnvEq - modSum = pm_mod_summary pm - df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum - let hscEnv = hscEnv0 { hsc_dflags = df' } + (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm manualCalcEdit lsp @@ -157,14 +149,9 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = _eStyle params withTypeChecked fp TcModuleResult {..} = do - let ps = annotateParsedSource tmrParsed - Splices {..} = tmrTopLevelSplices - hscEnvEq <- - lift $ - runAction "expandTHSplice.ghcSessionDeps" ideState $ - use_ GhcSessionDeps fp - let dflags = hsc_dflags $ hscEnv hscEnvEq - exprSuperSpans = + (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + let Splices {..} = tmrTopLevelSplices + let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices _patSuperSpans = listToMaybe $ findSubSpansDesc srcSpan patSplices @@ -210,6 +197,23 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = -- 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 = diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index 985a075fec..f86386d048 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -41,6 +41,7 @@ tests = "splice" [ goldenTest "TSimpleExp.hs" Inplace 6 15 , goldenTest "TSimpleExp.hs" Inplace 6 24 + , goldenTest "TTypeAppExp.hs" Inplace 7 5 , goldenTest "TErrorExp.hs" Inplace 6 15 , goldenTest "TErrorExp.hs" Inplace 6 51 , goldenTest "TQQExp.hs" Inplace 6 17 diff --git a/test/testdata/splice/TTypeAppExp.hs b/test/testdata/splice/TTypeAppExp.hs new file mode 100644 index 0000000000..0cc071a08d --- /dev/null +++ b/test/testdata/splice/TTypeAppExp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module TTypeAppExp where +import Data.Proxy + +f :: Proxy Int +f = $([|Proxy @Int|]) diff --git a/test/testdata/splice/hie.yaml b/test/testdata/splice/hie.yaml index fee6e3451a..39bd673f43 100644 --- a/test/testdata/splice/hie.yaml +++ b/test/testdata/splice/hie.yaml @@ -4,6 +4,7 @@ cradle: - QQ.hs - TQQExpError.hs - TSimpleExp.hs + - TTypeAppExp.hs - TDeclKindError.hs - TQQPat.hs - TSimplePat.hs From 981fb408a6d24dfa83f87330becdcf558bc6cfc1 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 4 Jan 2021 10:39:05 +0900 Subject: [PATCH 49/51] Forgot to add golden file --- test/testdata/splice/TTypeAppExp.hs.expected | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test/testdata/splice/TTypeAppExp.hs.expected diff --git a/test/testdata/splice/TTypeAppExp.hs.expected b/test/testdata/splice/TTypeAppExp.hs.expected new file mode 100644 index 0000000000..0dc0e40f2a --- /dev/null +++ b/test/testdata/splice/TTypeAppExp.hs.expected @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module TTypeAppExp where +import Data.Proxy + +f :: Proxy Int +f = (Proxy @Int) From 11913449bc3cde6b26276f186dd1649ae4586818 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 4 Jan 2021 23:53:45 +0900 Subject: [PATCH 50/51] A dummy commit to run CI From 3032c3264df9854c8c4e32db8d431c00e97c40db Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Tue, 5 Jan 2021 19:02:41 +0900 Subject: [PATCH 51/51] Workaround for GHC 8.8 pattern splices --- hls-exactprint-utils/src/Ide/TreeTransform.hs | 10 +++++- .../src/Ide/Plugin/Splice.hs | 33 +++++-------------- test/functional/Splice.hs | 11 +------ 3 files changed, 19 insertions(+), 35 deletions(-) diff --git a/hls-exactprint-utils/src/Ide/TreeTransform.hs b/hls-exactprint-utils/src/Ide/TreeTransform.hs index 653c8d549c..9d442744bc 100644 --- a/hls-exactprint-utils/src/Ide/TreeTransform.hs +++ b/hls-exactprint-utils/src/Ide/TreeTransform.hs @@ -50,6 +50,11 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) +#if __GLASGOW_HASKELL__ == 808 +import Control.Arrow +#endif + + ------------------------------------------------------------------------------ -- | Get the latest version of the annotated parse source. @@ -272,8 +277,11 @@ instance p ~ GhcPs => ASTElement (HsExpr p) where parseAST = parseExpr maybeParensAST = parenthesize -#if __GLASGOW_HASKELL__ != 808 instance p ~ GhcPs => ASTElement (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 diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 8dc0149d3b..c77ac1dc88 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -22,7 +22,7 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (Arrow (first)) +import Control.Arrow import qualified Control.Foldl as L import Control.Lens (ix, view, (%~), (<&>), (^.)) import Control.Monad @@ -85,16 +85,7 @@ expandTHSplice :: expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = fmap (fromMaybe defaultResult) $ runMaybeT $ do -#if __GLASGOW_HASKELL__ == 808 - case spliceContext of - Pat -> do - reportEditor lsp MtInfo - [ "On GHC 8.8, pattern splice expansion is not supported, due to the API change (see issue #759)." - , "Please use GHC 8.6 or GHC 8.10+, or you can send a PR :-)" - ] - mzero - _ -> pure () -#endif + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri eedits <- ( lift . runExceptT . withTypeChecked fp @@ -154,6 +145,9 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices _patSuperSpans = +#if __GLASGOW_HASKELL__ == 808 + fmap (second dL) $ +#endif listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = listToMaybe $ findSubSpansDesc srcSpan typeSplices @@ -177,13 +171,9 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = case spliceContext of Expr -> graftSpliceWith exprSuperSpans Pat -> -#if __GLASGOW_HASKELL__ == 808 - pure $ - Left "In GHC 8.8, pattern splice expansion is not supported due to the change of GHC API internal. You can use it in 8.6 and 8.10." -#else + graftSpliceWith _patSuperSpans -#endif HsType -> graftSpliceWith typeSuperSpans HsDecl -> declSuperSpans <&> \(_, expanded) -> @@ -284,12 +274,10 @@ instance HasSplice HsExpr where matchSplice _ _ = Nothing expandSplice _ = fmap (first Right) . rnSpliceExpr -#if __GLASGOW_HASKELL__ != 808 instance HasSplice Pat where matchSplice _ (SplicePat _ spl) = Just spl matchSplice _ _ = Nothing expandSplice _ = rnSplicePat -#endif instance HasSplice HsType where @@ -301,11 +289,7 @@ classifyAST :: SpliceContext -> SpliceClass classifyAST = \case Expr -> OneToOneAST @HsExpr proxy# HsDecl -> IsHsDecl -#if __GLASGOW_HASKELL__ == 808 - Pat -> error "GHC 8.8" -#else Pat -> OneToOneAST @Pat proxy# -#endif HsType -> OneToOneAST @HsType proxy# reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () @@ -439,16 +423,17 @@ codeAction _ state plId docId ran _ = _ -> Continue _ -> Stop ) + `extQ` \case #if __GLASGOW_HASKELL__ == 808 + (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) #else - `extQ` \case (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) +#endif | RealSrcSpan spn `isSubspanOf` l -> case pat of SplicePat{} -> Here (spLoc, Pat) _ -> Continue _ -> Stop -#endif `extQ` \case (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) | RealSrcSpan spn `isSubspanOf` l -> diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index f86386d048..e5fdca0468 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -30,11 +30,6 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit -#if __GLASGOW_HASKELL__ == 808 -import Test.Tasty.ExpectedFailure -#endif - - tests :: TestTree tests = testGroup @@ -48,11 +43,7 @@ tests = , goldenTest "TQQExp.hs" Inplace 6 25 , goldenTest "TQQExpError.hs" Inplace 6 13 , goldenTest "TQQExpError.hs" Inplace 6 22 - , -#if __GLASGOW_HASKELL__ == 808 - expectFailBecause "Pattern splice expansions are unsupported on GHC 8.8, due to LPat = Pat problem" $ -#endif - testGroup "Pattern Splices" + , testGroup "Pattern Splices" [ goldenTest "TSimplePat.hs" Inplace 6 3 , goldenTest "TSimplePat.hs" Inplace 6 22 , goldenTest "TSimplePat.hs" Inplace 6 3