hls-retrie-plugin (empty) → 0.1.0.0
raw patch · 4 files changed
+806/−0 lines, 4 filesdep +aesondep +basedep +containers
Dependencies added: aeson, base, containers, deepseq, directory, extra, ghc, ghcide, hashable, haskell-lsp, haskell-lsp-types, hls-plugin-api, retrie, safe-exceptions, shake, text, transformers, unordered-containers
Files
- LICENSE +201/−0
- hls-retrie-plugin.cabal +38/−0
- include/ghc-api-version.h +10/−0
- src/Ide/Plugin/Retrie.hs +557/−0
+ LICENSE view
@@ -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.
+ hls-retrie-plugin.cabal view
@@ -0,0 +1,38 @@+cabal-version: 2.2+name: hls-retrie-plugin+version: 0.1.0.0+synopsis: Retrie integration plugin for Haskell Language Server+license: Apache-2.0+license-file: LICENSE+author: Pepe Iborra+maintainer: pepeiborra@gmail.com+category: Development+build-type: Simple+extra-source-files:+ LICENSE+ include/ghc-api-version.h++library+ exposed-modules: Ide.Plugin.Retrie+ hs-source-dirs: src+ build-depends: aeson+ , base >=4.12 && <5+ , containers+ , deepseq+ , directory+ , extra+ , haskell-lsp+ , haskell-lsp-types+ , hls-plugin-api+ , ghc+ , ghcide+ , hashable+ , retrie >=0.1.1.0+ , safe-exceptions+ , shake+ , text+ , transformers+ , unordered-containers++ default-language: Haskell2010+ include-dirs: include
+ include/ghc-api-version.h view
@@ -0,0 +1,10 @@+#ifndef GHC_API_VERSION_H+#define GHC_API_VERSION_H++#ifdef GHC_LIB+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)+#else+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)+#endif++#endif
+ src/Ide/Plugin/Retrie.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS -Wno-orphans #-}+#include "ghc-api-version.h"++module Ide.Plugin.Retrie (descriptor) where++import Control.Concurrent.Extra (readVar)+import Control.Exception.Safe (Exception (..), SomeException,+ catch, throwIO, try)+import Control.Monad (forM, unless)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Except (ExceptT (..), runExceptT,+ throwE)+import Data.Aeson (genericParseJSON, FromJSON(..), ToJSON (..), Value (Null))+import Data.Bifunctor (Bifunctor (first), second)+import Data.Coerce+import Data.Either (partitionEithers)+import Data.Hashable (unhashed)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as Set+import Data.IORef.Extra (atomicModifyIORef'_, newIORef,+ readIORef)+import Data.List.Extra (find, nubOrdOn)+import Data.String (IsString (fromString))+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Typeable (Typeable)+import Development.IDE+import Development.IDE.Core.Shake (toKnownFiles, ShakeExtras(knownTargetsVar))+import Development.IDE.GHC.Compat (GenLocated (L), GhcRn,+ HsBindLR (FunBind),+ HsGroup (..),+ HsValBindsLR (..), HscEnv, IdP,+ LRuleDecls,+ ModSummary (ModSummary, ms_hspp_buf, ms_mod),+ NHsValBindsLR (..),+ ParsedModule (..),+ RuleDecl (HsRule),+ RuleDecls (HsRules),+ SrcSpan (..),+ TyClDecl (SynDecl),+ TyClGroup (..), fun_id,+ mi_fixities, moduleNameString,+ parseModule, rds_rules,+ srcSpanFile)+import GHC.Generics (Generic)+import GhcPlugins (Outputable,+ SourceText (NoSourceText),+ hm_iface, isQual, isQual_maybe,+ nameModule_maybe, nameRdrName,+ occNameFS, occNameString,+ rdrNameOcc, unpackFS)+import Ide.PluginUtils+import Ide.Types+import Language.Haskell.LSP.Core (LspFuncs (..), ProgressCancellable (Cancellable))+import Language.Haskell.LSP.Messages (FromServerMessage (NotShowMessage))+import Language.Haskell.LSP.Types as J+import Retrie.CPP (CPP (NoCPP), parseCPP)+import Retrie.ExactPrint (fix, relativiseApiAnns,+ transformA, unsafeMkA)+import Retrie.Fixity (mkFixityEnv)+import qualified Retrie.GHC as GHC+import Retrie.Monad (addImports, apply,+ getGroundTerms, runRetrie)+import Retrie.Options (defaultOptions, getTargetFiles)+import qualified Retrie.Options as Retrie+import Retrie.Replace (Change (..), Replacement (..))+import Retrie.Rewrites+import Retrie.SYB (listify)+import Retrie.Util (Verbosity (Loud))+import StringBuffer (stringToStringBuffer)+import System.Directory (makeAbsolute)+import Control.Monad.Trans.Maybe+import Development.IDE.Core.PositionMapping+import qualified Data.Aeson as Aeson++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId =+ (defaultPluginDescriptor plId)+ { pluginCodeActionProvider = Just provider,+ pluginCommands = [retrieCommand]+ }++retrieCommandName :: T.Text+retrieCommandName = "retrieCommand"++retrieCommand :: PluginCommand IdeState+retrieCommand =+ PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd++-- | Parameters for the runRetrie PluginCommand.+data RunRetrieParams = RunRetrieParams+ { description :: T.Text,+ rewrites :: [RewriteSpec],+ originatingFile :: NormalizedUriJSON,+ restrictToOriginatingFile :: Bool+ }+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype NormalizedUriJSON = NormalizedUriJSON NormalizedUri+ deriving (Eq, Show)++instance FromJSON NormalizedUriJSON where+ parseJSON = fmap NormalizedUriJSON . genericParseJSON Aeson.defaultOptions++instance ToJSON NormalizedUriJSON where+ toJSON (NormalizedUriJSON x) = Aeson.genericToJSON Aeson.defaultOptions x++runRetrieCmd ::+ LspFuncs a ->+ IdeState ->+ RunRetrieParams ->+ IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+runRetrieCmd lsp state RunRetrieParams{originatingFile = NormalizedUriJSON nuri, ..} =+ withIndefiniteProgress lsp description Cancellable $ do+ res <- runMaybeT $ do+ nfp <- MaybeT $ return $ uriToNormalizedFilePath nuri+ (session, _) <- MaybeT $+ runAction "Retrie.GhcSessionDeps" state $+ useWithStale GhcSessionDeps $+ nfp+ (ms, binds, _, _, _) <- MaybeT $ runAction "Retrie.getBinds" state $ getBinds nfp+ let importRewrites = concatMap (extractImports ms binds) rewrites+ (errors, edits) <- lift $+ callRetrie+ state+ (hscEnv session)+ (map Right rewrites <> map Left importRewrites)+ nfp+ restrictToOriginatingFile+ unless (null errors) $+ lift $ sendFunc lsp $+ NotShowMessage $+ NotificationMessage "2.0" WindowShowMessage $+ ShowMessageParams MtWarning $+ T.unlines $+ "## Found errors during rewrite:" :+ ["-" <> T.pack (show e) | e <- errors]+ return (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits)+ return+ (Right Null, res)++extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]+extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing)+ | Just FunBind {fun_matches}+ <- find (\case FunBind{fun_id = L _ n} -> prettyPrint n == thing ; _ -> False) topLevelBinds+ , names <- listify p fun_matches+ =+ [ AddImport {..}+ | name <- names,+ Just ideclNameString <-+ [moduleNameString . GHC.moduleName <$> nameModule_maybe name],+ let ideclSource = False,+ let r = nameRdrName name,+ let ideclQualifiedBool = isQual r,+ let ideclAsString = moduleNameString . fst <$> isQual_maybe r,+ let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r)+ ]+ where+ p name = nameModule_maybe name /= Just ms_mod+-- TODO handle imports for all rewrites+extractImports _ _ _ = []++-------------------------------------------------------------------------------++provider :: CodeActionProvider IdeState+provider _a state plId (TextDocumentIdentifier uri) range ca = response $ do+ let (J.CodeActionContext _diags _monly) = ca+ nuri = toNormalizedUri uri+ nuriJson = NormalizedUriJSON nuri+ nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri++ (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)+ <- handleMaybeM "typecheck" $ runAction "retrie" state $ getBinds nfp++ pos <- handleMaybe "pos" $ _start <$> fromCurrentRange posMapping range+ let rewrites =+ concatMap (suggestBindRewrites nuriJson pos ms_mod) topLevelBinds+ ++ concatMap (suggestRuleRewrites nuriJson pos ms_mod) hs_ruleds+ ++ [ r+ | TyClGroup {group_tyclds} <- hs_tyclds,+ L l g <- group_tyclds,+ r <- suggestTypeRewrites nuriJson ms_mod g,+ pos `isInsideSrcSpan` l++ ]++ commands <- lift $+ forM rewrites $ \(title, kind, params) -> do+ c <- mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params])+ return $ CodeAction title (Just kind) Nothing Nothing (Just c)++ return $ J.List [CACodeAction c | c <- commands]++getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]))+getBinds nfp = runMaybeT $ do+ (tm, posMapping) <- MaybeT $ useWithStale TypeCheck nfp+ -- we use the typechecked source instead of the parsed source+ -- to be able to extract module names from the Ids,+ -- so that we can include adding the required imports in the retrie command+ let rn = tmrRenamed tm+ ( HsGroup+ { hs_valds =+ XValBindsLR+ (NValBinds binds _sigs :: NHsValBindsLR GHC.GhcRn),+ hs_ruleds,+ hs_tyclds+ },+ _,+ _,+ _+ ) = rn++ topLevelBinds =+ [ decl+ | (_, bagBinds) <- binds,+ L _ decl <- GHC.bagToList bagBinds+ ]+ return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)++suggestBindRewrites ::+ NormalizedUriJSON ->+ Position ->+ GHC.Module ->+ HsBindLR GhcRn GhcRn ->+ [(T.Text, CodeActionKind, RunRetrieParams)]+suggestBindRewrites originatingFile pos ms_mod (FunBind {fun_id = L l' rdrName})+ | pos `isInsideSrcSpan` l' =+ let pprName = prettyPrint rdrName+ pprNameText = T.pack pprName+ unfoldRewrite restrictToOriginatingFile =+ let rewrites = [Unfold (qualify ms_mod pprName)]+ description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile+ in (description, CodeActionRefactorInline, RunRetrieParams {..})+ foldRewrite restrictToOriginatingFile =+ let rewrites = [Fold (qualify ms_mod pprName)]+ description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile+ in (description, CodeActionRefactorExtract, RunRetrieParams {..})+ in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]+ where+suggestBindRewrites _ _ _ _ = []++describeRestriction :: IsString p => Bool -> p+describeRestriction restrictToOriginatingFile =+ if restrictToOriginatingFile then " in current file" else ""++suggestTypeRewrites ::+ (Outputable (IdP pass)) =>+ NormalizedUriJSON ->+ GHC.Module ->+ TyClDecl pass ->+ [(T.Text, CodeActionKind, RunRetrieParams)]+suggestTypeRewrites originatingFile ms_mod (SynDecl {tcdLName = L _ rdrName}) =+ let pprName = prettyPrint rdrName+ pprNameText = T.pack pprName+ unfoldRewrite restrictToOriginatingFile =+ let rewrites = [TypeForward (qualify ms_mod pprName)]+ description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile+ in (description, CodeActionRefactorInline, RunRetrieParams {..})+ foldRewrite restrictToOriginatingFile =+ let rewrites = [TypeBackward (qualify ms_mod pprName)]+ description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile+ in (description, CodeActionRefactorExtract, RunRetrieParams {..})+ in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]+suggestTypeRewrites _ _ _ = []++suggestRuleRewrites ::+ NormalizedUriJSON ->+ Position ->+ GHC.Module ->+ LRuleDecls pass ->+ [(T.Text, CodeActionKind, RunRetrieParams)]+suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) =+ concat+ [ [ forwardRewrite ruleName True+ , forwardRewrite ruleName False+ , backwardsRewrite ruleName True+ , backwardsRewrite ruleName False+ ]+ | L l r <- rds_rules,+ pos `isInsideSrcSpan` l,+#if MIN_GHC_API_VERSION(8,8,0)+ let HsRule {rd_name = L _ (_, rn)} = r,+#else+ let HsRule _ (L _ (_,rn)) _ _ _ _ = r,+#endif+ let ruleName = unpackFS rn+ ]+ where+ forwardRewrite ruleName restrictToOriginatingFile =+ let rewrites = [RuleForward (qualify ms_mod ruleName)]+ description = "Apply rule " <> T.pack ruleName <> " forward" <>+ describeRestriction restrictToOriginatingFile++ in ( description,+ CodeActionRefactor,+ RunRetrieParams {..}+ )+ backwardsRewrite ruleName restrictToOriginatingFile =+ let rewrites = [RuleBackward (qualify ms_mod ruleName)]+ description = "Apply rule " <> T.pack ruleName <> " backwards" <>+ describeRestriction restrictToOriginatingFile+ in ( description,+ CodeActionRefactor,+ RunRetrieParams {..}+ )++suggestRuleRewrites _ _ _ _ = []++qualify :: GHC.Module -> String -> String+qualify ms_mod x = prettyPrint ms_mod <> "." <> x++-------------------------------------------------------------------------------+-- Retrie driving code++data CallRetrieError+ = CallRetrieInternalError String NormalizedFilePath+ | NoParse NormalizedFilePath+ | GHCParseError NormalizedFilePath String+ | NoTypeCheck NormalizedFilePath+ deriving (Eq, Typeable)++instance Show CallRetrieError where+ show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f+ show (NoParse f) = "Cannot parse: " <> fromNormalizedFilePath f+ show (GHCParseError f m) = "Cannot parse " <> fromNormalizedFilePath f <> " : " <> m+ show (NoTypeCheck f) = "File does not typecheck: " <> fromNormalizedFilePath f++instance Exception CallRetrieError++callRetrie ::+ IdeState ->+ HscEnv ->+ [Either ImportSpec RewriteSpec] ->+ NormalizedFilePath ->+ Bool ->+ IO ([CallRetrieError], WorkspaceEdit)+callRetrie state session rewrites origin restrictToOriginatingFile = do+ knownFiles <- toKnownFiles . unhashed <$> readVar (knownTargetsVar $ shakeExtras state)+ print knownFiles+ let reuseParsedModule f = do+ pm <-+ useOrFail "GetParsedModule" NoParse GetParsedModule f+ (fixities, pm) <- fixFixities f (fixAnns pm)+ return (fixities, pm)+ getCPPmodule t = do+ nt <- toNormalizedFilePath' <$> makeAbsolute t+ let getParsedModule f contents = do+ (modSummary, _) <-+ useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt+ let ms' =+ modSummary+ { ms_hspp_buf =+ Just (stringToStringBuffer contents)+ }+ logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t+ parsed <-+ evalGhcEnv session (parseModule ms')+ `catch` \e -> throwIO (GHCParseError nt (show @SomeException e))+ (fixities, parsed) <- fixFixities f (fixAnns parsed)+ return (fixities, parsed)++ contents <- do+ (_, mbContentsVFS) <-+ runAction "Retrie.GetFileContents" state $ getFileContents nt+ case mbContentsVFS of+ Just contents -> return contents+ Nothing -> T.readFile (fromNormalizedFilePath nt)+ if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents)+ then do+ fixitiesRef <- newIORef mempty+ let parseModule x = do+ (fix, res) <- getParsedModule nt x+ atomicModifyIORef'_ fixitiesRef (fix <>)+ return res+ res <- parseCPP parseModule contents+ fixities <- readIORef fixitiesRef+ return (fixities, res)+ else do+ (fixities, pm) <- reuseParsedModule nt+ return (fixities, NoCPP pm)++ -- TODO cover all workspaceFolders+ target = "."++ retrieOptions :: Retrie.Options+ retrieOptions = (defaultOptions target)+ {Retrie.verbosity = Loud+ ,Retrie.targetFiles = map fromNormalizedFilePath $+ if restrictToOriginatingFile+ then [origin]+ else Set.toList knownFiles+ }++ (theImports, theRewrites) = partitionEithers rewrites++ annotatedImports =+ unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0++ (originFixities, originParsedModule) <- reuseParsedModule origin+ retrie <-+ (\specs -> apply specs >> addImports annotatedImports)+ <$> parseRewriteSpecs+ (\_f -> return $ NoCPP originParsedModule)+ originFixities+ theRewrites++ targets <- getTargetFiles retrieOptions (getGroundTerms retrie)++ results <- forM targets $ \t -> runExceptT $ do+ (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule t+ -- TODO add the imports to the resulting edits+ (_user, ast, change@(Change _replacements _imports)) <-+ lift $ runRetrie fixityEnv retrie cpp+ case ast of+ _ ->+ return $ asTextEdits change++ let (errors :: [CallRetrieError], replacements) = partitionEithers results+ editParams :: WorkspaceEdit+ editParams =+ WorkspaceEdit (Just $ asEditMap replacements) Nothing++ return (errors, editParams)+ where+ useOrFail ::+ IdeRule r v =>+ String ->+ (NormalizedFilePath -> CallRetrieError) ->+ r ->+ NormalizedFilePath ->+ IO (RuleResult r)+ useOrFail lbl mkException rule f =+ useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return+ fixityEnvFromModIface modIface =+ mkFixityEnv+ [ (fs, (fs, fixity))+ | (n, fixity) <- mi_fixities modIface,+ let fs = occNameFS n+ ]+ fixFixities f pm = do+ HiFileResult {hirHomeMod} <-+ useOrFail "GetModIface" NoTypeCheck GetModIface f+ let fixities = fixityEnvFromModIface $ hm_iface hirHomeMod+ res <- transformA pm (fix fixities)+ return (fixities, res)+ fixAnns ParsedModule {..} =+ let ranns = relativiseApiAnns pm_parsed_source pm_annotations+ in unsafeMkA pm_parsed_source ranns 0++asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap+asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure))++asTextEdits :: Change -> [(Uri, TextEdit)]+asTextEdits NoChange = []+asTextEdits (Change reps _imports) =+ [ (filePathToUri spanLoc, edit)+ | Replacement {..} <- nubOrdOn replLocation reps,+ (RealSrcSpan rspan) <- [replLocation],+ let spanLoc = unpackFS $ srcSpanFile rspan,+ let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement)+ ]++-------------------------------------------------------------------------------+-- Rule wrappers++_useRuleBlocking,+ _useRuleStale,+ useRule ::+ (IdeRule k v) =>+ String ->+ IdeState ->+ k ->+ NormalizedFilePath ->+ IO (Maybe (RuleResult k))+_useRuleBlocking label state rule f = runAction label state (use rule f)+_useRuleStale label state rule f =+ fmap fst+ <$> runIdeAction label (shakeExtras state) (useWithStaleFast rule f)++-- | Chosen approach for calling ghcide Shake rules+useRule label = _useRuleStale ("Retrie." <> label)++-------------------------------------------------------------------------------+-- Error handling combinators++handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b+handleMaybe msg = maybe (throwE msg) return++handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b+handleMaybeM msg act = maybe (throwE msg) return =<< lift act++response :: ExceptT String IO a -> IO (Either ResponseError a)+response =+ fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))+ . runExceptT++-------------------------------------------------------------------------------+-- Serialization wrappers and instances++deriving instance Eq RewriteSpec++deriving instance Show RewriteSpec++deriving instance Generic RewriteSpec++deriving instance FromJSON RewriteSpec++deriving instance ToJSON RewriteSpec++data QualName = QualName {qual, name :: String}+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++data IE name+ = IEVar name+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++data ImportSpec = AddImport+ { ideclNameString :: String,+ ideclSource :: Bool,+ ideclQualifiedBool :: Bool,+ ideclAsString :: Maybe String,+ ideclThing :: Maybe (IE String)+ }+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs+toImportDecl AddImport {..} = GHC.ImportDecl {..}+ where+ toMod = GHC.noLoc . GHC.mkModuleName+ ideclName = toMod ideclNameString+ ideclPkgQual = Nothing+ ideclSafe = False+ ideclImplicit = False+ ideclHiding = Nothing+ ideclSourceSrc = NoSourceText+ ideclExt = GHC.noExtField+ ideclAs = toMod <$> ideclAsString+#if MIN_GHC_API_VERSION(8,10,0)+ ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified+#else+ ideclQualified = ideclQualifiedBool+#endif