hls-retrie-plugin 1.0.3.0 → 1.0.4.0

raw patch · 3 files changed

+516/−139 lines, 3 filesdep +filepathdep +hls-refactor-plugindep +hls-retrie-plugindep ~basedep ~ghcidedep ~hls-plugin-apiPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: filepath, hls-refactor-plugin, hls-retrie-plugin, hls-test-utils

Dependency ranges changed: base, ghcide, hls-plugin-api

API changes (from Hackage documentation)

Files

• hls-retrie-plugin.cabal +21/−2
• src/Ide/Plugin/Retrie.hs +398/−137
• test/Main.hs +97/−0

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               hls-retrie-plugin-version:            1.0.3.0+version:            1.0.4.0 synopsis:           Retrie integration plugin for Haskell Language Server description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -28,9 +28,10 @@     , directory     , extra     , ghc-    , ghcide                ^>=1.9+    , ghcide                ^>=1.10     , hashable     , hls-plugin-api        ^>=1.6+    , hls-refactor-plugin     , lsp     , lsp-types     , retrie                >=0.1.1.0@@ -46,3 +47,21 @@     TypeOperators    ghc-options:        -Wno-unticked-promoted-constructors++test-suite tests+  buildable: True+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   test+  main-is:          Main.hs+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson+    , base+    , containers+    , filepath+    , hls-plugin-api+    , hls-refactor-plugin+    , hls-retrie-plugin+    , hls-test-utils             ^>=1.5+    , text

@@ -1,87 +1,117 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE PatternSynonyms     #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}  {-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE TupleSections         #-}  module Ide.Plugin.Retrie (descriptor) where  import           Control.Concurrent.STM               (readTVarIO) import           Control.Exception.Safe               (Exception (..),-                                                       SomeException, catch,-                                                       throwIO, try)-import           Control.Monad                        (forM, unless)+                                                       SomeException, assert,+                                                       catch, throwIO, try)+import           Control.Monad                        (forM, unless, when) import           Control.Monad.IO.Class               (MonadIO (liftIO)) import           Control.Monad.Trans.Class            (MonadTrans (lift)) import           Control.Monad.Trans.Except           (ExceptT (ExceptT),-                                                       runExceptT)+                                                       runExceptT, throwE) import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Writer.Strict import           Data.Aeson                           (FromJSON (..),                                                        ToJSON (..),                                                        Value (Null)) import           Data.Bifunctor                       (second) import qualified Data.ByteString                      as BS import           Data.Coerce+import           Data.Data import           Data.Either                          (partitionEithers)-import           Data.Hashable                        (unhashed)+import           Data.Hashable                        (Hashable (hash),+                                                       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.Maybe                           (catMaybes, fromJust,+                                                       listToMaybe) import           Data.String                          (IsString) import qualified Data.Text                            as T import qualified Data.Text.Encoding                   as T import           Data.Typeable                        (Typeable)+import           Debug.Trace import           Development.IDE                      hiding (pluginHandlers) import           Development.IDE.Core.PositionMapping-import           Development.IDE.Core.Shake           (ShakeExtras (knownTargetsVar),-                                                       toKnownFiles)-import           Development.IDE.GHC.Compat           (GenLocated (L), GhcPs,+import           Development.IDE.Core.Shake           (ShakeExtras (ShakeExtras, knownTargetsVar),+                                                       clientCapabilities,+                                                       getShakeExtras,+                                                       hiedbWriter,+                                                       toKnownFiles, withHieDb)+import           Development.IDE.GHC.Compat           (GRHSs (GRHSs),+                                                       GenLocated (L), GhcPs,                                                        GhcRn, GhcTc,                                                        HsBindLR (FunBind),+                                                       HsExpr (HsApp, OpApp),                                                        HsGroup (..),                                                        HsValBindsLR (..),-                                                       HscEnv, IdP, LRuleDecls,+                                                       HscEnv, IdP,+                                                       ImportDecl (..), LHsExpr,+                                                       LRuleDecls, Match,+                                                       ModIface,                                                        ModSummary (ModSummary, ms_hspp_buf, ms_mod),-                                                       Outputable,+                                                       Name, Outputable,                                                        ParsedModule (..),+                                                       RealSrcLoc,                                                        RuleDecl (HsRule),                                                        RuleDecls (HsRules),                                                        SourceText (..),                                                        TyClDecl (SynDecl),                                                        TyClGroup (..), fun_id,                                                        hm_iface, isQual,-                                                       isQual_maybe, locA,-                                                       mi_fixities,+                                                       isQual_maybe, isVarOcc,+                                                       locA, mi_fixities,+                                                       moduleName,                                                        moduleNameString,                                                        ms_hspp_opts,                                                        nameModule_maybe,-                                                       nameRdrName, noLocA,-                                                       occNameFS, occNameString,+                                                       nameOccName, nameRdrName,+                                                       noLocA, occNameFS,+                                                       occNameString,                                                        pattern IsBoot,                                                        pattern NotBoot,                                                        pattern RealSrcSpan,                                                        pm_parsed_source,+                                                       printWithoutUniques,                                                        rdrNameOcc, rds_rules,                                                        srcSpanFile, topDir,-                                                       unLocA)+                                                       unLoc, unLocA)+import qualified Development.IDE.GHC.Compat           as GHC import           Development.IDE.GHC.Compat.Util      hiding (catch, try)-import qualified GHC                                  (Module,-                                                       ParsedModule (..),+import           Development.IDE.GHC.Dump             (showAstDataHtml)+import           Development.IDE.GHC.ExactPrint       (ExceptStringT (ExceptStringT),+                                                       GetAnnotatedParsedSource (GetAnnotatedParsedSource),+                                                       TransformT,+                                                       graftExprWithM,+                                                       graftSmallestDeclsWithM,+                                                       hoistGraft, transformM)+import qualified GHC                                  (Module, ParsedSource,                                                        moduleName, parseModule)+import qualified GHC                                  as GHCGHC import           GHC.Generics                         (Generic)+import           GHC.Hs.Dump import           Ide.PluginUtils import           Ide.Types import           Language.LSP.Server                  (LspM,@@ -93,48 +123,80 @@                                                            (SemanticTokenAbsolute (length, line),                                                             SemanticTokenRelative (length),                                                             SemanticTokensEdit (_start))+import           Retrie                               (Annotated (astA),+                                                       AnnotatedModule,+                                                       Fixity (Fixity),+                                                       FixityDirection (InfixL),+                                                       Options, Options_ (..),+                                                       RewriteSpec,+                                                       Verbosity (Loud),+                                                       addImports, apply,+                                                       applyWithUpdate)+import           Retrie.Context import           Retrie.CPP                           (CPP (NoCPP), parseCPP) import           Retrie.ExactPrint                    (Annotated, fix,                                                        transformA, unsafeMkA)+import           Retrie.Expr                          (mkLocatedHsVar)+import           Retrie.Fixity                        (FixityEnv, lookupOp,+                                                       mkFixityEnv)+import           Retrie.Monad                         (getGroundTerms,+                                                       runRetrie)+import           Retrie.Options                       (defaultOptions,+                                                       getTargetFiles)+import           Retrie.Replace                       (Change (..),+                                                       Replacement (..))+import           Retrie.Rewrites+import           Retrie.Rewrites.Function             (matchToRewrites)+import           Retrie.SYB                           (everything, extQ,+                                                       listify, mkQ)+import           Retrie.Types+import           Retrie.Universe                      (Universe)+import           System.Directory                     (makeAbsolute)  #if MIN_VERSION_ghc(9,3,0)-import GHC.Types.PkgQual+import           GHC.Types.PkgQual #endif  #if MIN_VERSION_ghc(9,2,0)+import           Control.Exception                    (evaluate)+import           Data.Monoid                          (First (First)) import           Retrie.ExactPrint                    (makeDeltaAst)+import           Retrie.GHC                           (ann) #else+import           Data.Monoid                          (First (..))+import qualified GHC.Exts                             as Ext+import           Retrie.AlphaEnv                      (extendAlphaEnv) import           Retrie.ExactPrint                    (relativiseApiAnns) #endif-import           Retrie.Fixity                        (mkFixityEnv)-import qualified Retrie.GHC                           as GHC-import           Retrie.Monad                         (addImports, apply,-                                                       getGroundTerms,-                                                       runRetrie)-import qualified Retrie.Options                       as Retrie-import           Retrie.Options                       (defaultOptions,-                                                       getTargetFiles)-import           Retrie.Replace                       (Change (..),-                                                       Replacement (..))-import           Retrie.Rewrites-import           Retrie.SYB                           (listify)-import           Retrie.Util                          (Verbosity (Loud))-import           System.Directory                     (makeAbsolute)+import           Control.Arrow                        ((&&&))+import           Development.IDE.Core.Actions         (lookupMod)+import           Development.IDE.Spans.AtPoint        (LookupModule,+                                                       getNamesAtPoint,+                                                       nameToLocation)+import           Development.IDE.Types.Shake          (WithHieDb)  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId =   (defaultPluginDescriptor plId)     { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider,-      pluginCommands = [retrieCommand]+      pluginCommands = [retrieCommand, retrieInlineThisCommand]     }  retrieCommandName :: T.Text retrieCommandName = "retrieCommand" +retrieInlineThisCommandName :: T.Text+retrieInlineThisCommandName = "retrieInlineThisCommand"+ retrieCommand :: PluginCommand IdeState retrieCommand =   PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd +retrieInlineThisCommand :: PluginCommand IdeState+retrieInlineThisCommand =+  PluginCommand (coerce retrieInlineThisCommandName) "inline function call"+     runRetrieInlineThisCmd+ -- | Parameters for the runRetrie PluginCommand. data RunRetrieParams = RunRetrieParams   { description               :: T.Text,@@ -155,7 +217,8 @@             runAction "Retrie.GhcSessionDeps" state $                 useWithStale GhcSessionDeps                 nfp-        (ms, binds, _, _, _) <- MaybeT $ liftIO $ runAction "Retrie.getBinds" state $ getBinds nfp+        (ms, binds, _, _, _) <- MaybeT $ liftIO $+            runAction "Retrie.getBinds" state $ getBinds nfp         let importRewrites = concatMap (extractImports ms binds) rewrites         (errors, edits) <- liftIO $             callRetrie@@ -174,6 +237,83 @@         return ()     return $ Right Null +data RunRetrieInlineThisParams = RunRetrieInlineThisParams+  { inlineIntoThisLocation :: !Location,+    inlineFromThisLocation :: !Location,+    inlineThisDefinition   :: !T.Text+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++runRetrieInlineThisCmd :: IdeState+    -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value)+runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do+    nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation+    nfpSource <- handleMaybe "sourceUri" $+        uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineFromThisLocation+    -- What we do here:+    --   Find the identifier in the given position+    --   Construct an inline rewrite for it+    --   Run retrie to get a list of changes+    --   Select the change that inlines the identifier in the given position+    --   Apply the edit+    ast <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $+        use GetAnnotatedParsedSource nfp+    astSrc <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $+        use GetAnnotatedParsedSource nfpSource+    msr <- handleMaybeM "modSummary" $ liftIO $ runAction "retrie" state $+        use GetModSummaryWithoutTimestamps nfp+    hiFileRes <- handleMaybeM "modIface" $ liftIO $ runAction "retrie" state $+        use GetModIface nfpSource+    let fixityEnv = fixityEnvFromModIface (hirModIface hiFileRes)+        fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation+        intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation+    inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange+    when (null inlineRewrite) $ throwE "Empty rewrite"+    let ShakeExtras{..}= shakeExtras state+    (session, _) <- handleMaybeM "GHCSession" $ liftIO $ runAction "retrie" state $+      useWithStale GhcSessionDeps nfp+    (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp+    result <- liftIO $ try @_ @SomeException $+        runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp+    case result of+        Left err -> throwE $ "Retrie - crashed with: " <> show err+        Right (_,_,NoChange) -> throwE "Retrie - inline produced no changes"+        Right (_,_,Change replacements imports) -> do+            let edits = asEditMap $ asTextEdits $ Change ourReplacement imports+                wedit = WorkspaceEdit (Just edits) Nothing Nothing+                ourReplacement = [ r+                    | r@Replacement{..} <- replacements+                    , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation]+            lift $ sendRequest SWorkspaceApplyEdit+                (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+            return Null++-- Override to skip adding binders to the context, which prevents inlining+-- nested defined functions+myContextUpdater :: ContextUpdater+myContextUpdater c i =+    updateContext c i+    `extQ` (return . updExp)+    `extQ` (skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs)))+    `extQ` (skipUpdate @(Match GhcPs (LHsExpr GhcPs)))+  where+    skipUpdate :: forall a m . Monad m => a -> TransformT m Context+    skipUpdate _ = pure c++    -- override to skip the HsLet case+    updExp :: HsExpr GhcPs -> Context+    updExp HsApp{} =+        c { ctxtParentPrec = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }+    -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)+    -- In left child, prec is 10, so HsApp child will NOT get paren'd+    -- In right child, prec is 11, so every child gets paren'd (unless atomic)+    updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }+    updExp _ = c { ctxtParentPrec = NeverParen }+    -- Deal with Trees-That-Grow adding extension points+    -- as the first child everywhere.+    firstChild :: Int+    firstChild = 1+ extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing)   | Just FunBind {fun_matches}@@ -204,9 +344,13 @@   nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri    (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)-    <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ getBinds nfp+    <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $+        getBinds nfp -  pos <- handleMaybe "pos" $ _start <$> fromCurrentRange posMapping range+  extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras++  range <- handleMaybe "range" $ fromCurrentRange posMapping range+  let pos = _start range   let rewrites =         concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds           ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds@@ -215,16 +359,27 @@                  L (locA -> l) g <- group_tyclds,                  pos `isInsideSrcSpan` l,                  r <- suggestTypeRewrites uri ms_mod g-              ] -  commands <- lift $+  retrieCommands <- lift $     forM rewrites $ \(title, kind, params) -> liftIO $ do       let c = mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params])       return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing -  return $ J.List [InR c | c <- commands]+  inlineSuggestions <- liftIO $ runIdeAction "" extras $+    suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter)+  let inlineCommands =+        [ Just $+            CodeAction _title (Just CodeActionRefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing+        | c@Command{..} <- inlineSuggestions+        ]+  return $ J.List [InR c | c <- retrieCommands ++ catMaybes inlineCommands] +getLocationUri :: Location -> Uri+getLocationUri Location{_uri} = _uri++getLocationRange Location{_range} = _range+ getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])) getBinds nfp = runMaybeT $ do   (tm, posMapping) <- MaybeT $ useWithStale TypeCheck nfp@@ -247,7 +402,7 @@       topLevelBinds =         [ decl           | (_, bagBinds) <- binds,-            L _ decl <- GHC.bagToList bagBinds+            L _ decl <- bagToList bagBinds         ]   return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) @@ -272,6 +427,43 @@      in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestBindRewrites _ _ _ _ = [] +  -- find all the identifiers in the AST for which have source definitions+suggestBindInlines :: PluginId -> Uri -> [HsBindLR GhcRn GhcRn] -> Range -> WithHieDb -> _ -> IdeAction [Command]+suggestBindInlines plId uri binds range hie lookupMod = do+    identifiers <- definedIdentifiers+    return $ map (\(name, siteLoc, srcLoc) ->+        let+            title = "Inline " <> printedName+            printedName = printOutputable name+            params = RunRetrieInlineThisParams+                { inlineIntoThisLocation = siteLoc+                , inlineFromThisLocation = srcLoc+                , inlineThisDefinition= printedName+                }+        in mkLspCommand plId (coerce retrieInlineThisCommandName) title (Just [toJSON params])+        )+        (Set.toList identifiers)+    where+      definedIdentifiers =+        -- we search for candidates to inline in RHSs only, skipping LHSs+        everything (<>) (pure mempty `mkQ` getGRHSIdentifierDetails hie lookupMod) binds++      getGRHSIdentifierDetails :: WithHieDb -> _ -> GRHSs GhcRn (LHsExpr GhcRn) -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))+      getGRHSIdentifierDetails a b it@GRHSs{} =+        -- we only select candidates for which we have source code+        everything (<>) (pure mempty `mkQ` getDefinedIdentifierDetailsViaHieDb a b) it++      getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))+      getDefinedIdentifierDetailsViaHieDb withHieDb lookupModule lname | name <- unLoc lname =+        case srcSpanToLocation (GHC.getLocA lname) of+            Just siteLoc+              | siteRange <- getLocationRange siteLoc+              , range `isSubrangeOf` siteRange -> do+                    mbSrcLocation <- nameToLocation withHieDb lookupModule name+                    return $ maybe mempty (Set.fromList . map (nameOccName name, siteLoc,)) mbSrcLocation+            _ -> pure mempty++ describeRestriction :: IsString p => Bool -> p describeRestriction restrictToOriginatingFile =         if restrictToOriginatingFile then " in current file" else ""@@ -311,7 +503,11 @@           ]         | L (locA -> l) r  <- rds_rules,           pos `isInsideSrcSpan` l,+#if MIN_VERSION_ghc(9,5,0)+          let HsRule {rd_name = L _ rn} = r,+#else           let HsRule {rd_name = L _ (_, rn)} = r,+#endif           let ruleName = unpackFS rn       ]   where@@ -332,9 +528,8 @@                 CodeActionRefactor,                 RunRetrieParams {..}               )-suggestRuleRewrites _ _ _ _ = [] -qualify :: GHC.Module -> String -> String+qualify :: Outputable mod => mod -> String -> String qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x  -------------------------------------------------------------------------------@@ -364,50 +559,7 @@   IO ([CallRetrieError], WorkspaceEdit) callRetrie state session rewrites origin restrictToOriginatingFile = do   knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)-#if MIN_VERSION_ghc(9,2,0)-  -- retrie needs the libdir for `parseRewriteSpecs`-  libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin-#endif-  let reuseParsedModule f = do-        pm <- useOrFail "Retrie.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 <- msrModSummary <$>-                useOrFail "Retrie.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 (GHC.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.decodeUtf8 <$> BS.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)-+  let       -- TODO cover all workspaceFolders       target = "." @@ -429,21 +581,15 @@         unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0 #endif -  (originFixities, originParsedModule) <- reuseParsedModule origin+  (originFixities, originParsedModule) <- reuseParsedModule state origin   retrie <-     (\specs -> apply specs >> addImports annotatedImports)-      <$> parseRewriteSpecs-#if MIN_VERSION_ghc(9,2,0)-        libdir-#endif-        (\_f -> return $ NoCPP originParsedModule)-        originFixities-        theRewrites+      <$> parseSpecs state origin originParsedModule originFixities theRewrites    targets <- getTargetFiles retrieOptions (getGroundTerms retrie)    results <- forM targets $ \t -> runExceptT $ do-    (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule t+    (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t     -- TODO add the imports to the resulting edits     (_user, ast, change@(Change _replacements _imports)) <-       lift $ runRetrie fixityEnv retrie cpp@@ -452,42 +598,114 @@   let (errors :: [CallRetrieError], replacements) = partitionEithers results       editParams :: WorkspaceEdit       editParams =-        WorkspaceEdit (Just $ asEditMap replacements) Nothing Nothing+        WorkspaceEdit (Just $ asEditMap $ concat replacements) Nothing 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++useOrFail ::+  IdeRule r v =>+  IdeState ->+  String ->+  (NormalizedFilePath -> CallRetrieError) ->+  r ->+  NormalizedFilePath ->+  IO (RuleResult r)+useOrFail state lbl mkException rule f =+  useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return++fixityEnvFromModIface :: ModIface -> FixityEnv+fixityEnvFromModIface modIface =+  mkFixityEnv+    [ (fs, (fs, fixity))+      | (n, fixity) <- mi_fixities modIface,+        let fs = occNameFS n+    ]++fixFixities :: Data ast =>+  IdeState+  -> NormalizedFilePath+  -> Annotated ast+  -> IO (FixityEnv, Annotated ast)+fixFixities state f pm = do       HiFileResult {hirModIface} <--        useOrFail "GetModIface" NoTypeCheck GetModIface f+        useOrFail state "GetModIface" NoTypeCheck GetModIface f       let fixities = fixityEnvFromModIface hirModIface       res <- transformA pm (fix fixities)       return (fixities, res)++fixAnns :: ParsedModule -> Annotated GHC.ParsedSource #if MIN_VERSION_ghc(9,2,0)-    fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0+fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0 #else-    fixAnns GHC.ParsedModule {..} =+fixAnns GHC.ParsedModule {..} =       let ranns = relativiseApiAnns pm_parsed_source pm_annotations        in unsafeMkA pm_parsed_source ranns 0 #endif -asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap-asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure))+parseSpecs+  :: IdeState+  -> NormalizedFilePath+  -> AnnotatedModule+  -> FixityEnv+  -> [RewriteSpec]+  -> IO [Rewrite Universe]+parseSpecs state origin originParsedModule originFixities specs = do+#if MIN_VERSION_ghc(9,2,0)+  -- retrie needs the libdir for `parseRewriteSpecs`+  libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin+#endif+  parseRewriteSpecs+#if MIN_VERSION_ghc(9,2,0)+    libdir+#endif+    (\_f -> return $ NoCPP originParsedModule)+    originFixities+    specs +constructfromFunMatches imps fun_id fun_matches = do+    let fName = occNameFS (GHC.occName (unLoc fun_id))+    fe <- mkLocatedHsVar fun_id+    rewrites <- concat <$>+        forM (unLoc $ GHC.mg_alts fun_matches) (matchToRewrites fe imps LeftToRight)+    let urewrites = toURewrite <$> rewrites+    -- traceShowM $ map showQuery urewrites+    assert (not $ null urewrites) $+        return urewrites++showQuery = ppRewrite+-- showQuery :: Rewrite (LHsExpr GhcPs) -> String+-- showQuery q = unlines+--     [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q))+--     , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q))))+--     , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q))+--     ]++s :: Data a => a -> String+s = T.unpack . printOutputable . showAstData NoBlankSrcSpan+#if MIN_VERSION_ghc(9,2,0)+        NoBlankEpAnnotations+#endif+constructInlineFromIdentifer originParsedModule originSpan = do+    -- traceM $ s $ astA originParsedModule+    fmap astA $ transformA originParsedModule $ \(L _ m) -> do+        let ast = everything (<>) (First Nothing `mkQ` matcher) m+            matcher :: HsBindLR GhcPs GhcPs -> First _+            matcher FunBind{fun_id, fun_matches}+                --  | trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined+                | RealSrcSpan sp _ <- GHC.getLocA fun_id+                , sp == originSpan =+                First $ Just (fun_id, fun_matches)+            matcher _ = First Nothing+        case ast of+            First (Just (fun_id, fun_matches))+                ->+                let imports = mempty in+                constructfromFunMatches imports fun_id fun_matches+            _ -> return $ error "cound not find source code to inline"++asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap+asEditMap = coerce . HM.fromListWith (++) . map (second pure)+ asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = [] asTextEdits (Change reps _imports) =@@ -531,9 +749,6 @@  deriving instance ToJSON RewriteSpec -data QualName = QualName {qual, name :: String}-  deriving (Eq, Show, Generic, FromJSON, ToJSON)- newtype IE name   = IEVar name   deriving (Eq, Show, Generic, FromJSON, ToJSON)@@ -562,10 +777,56 @@     ideclImplicit = False     ideclHiding = Nothing     ideclSourceSrc = NoSourceText-#if MIN_VERSION_ghc(9,2,0)-    ideclExt = GHC.EpAnnNotUsed+#if MIN_VERSION_ghc(9,5,0)+    ideclExt = GHCGHC.XImportDeclPass+      { ideclAnn = GHCGHC.EpAnnNotUsed+      , ideclSourceText = ideclSourceSrc+      , ideclImplicit = ideclImplicit+      }+#elif MIN_VERSION_ghc(9,2,0)+    ideclExt = GHCGHC.EpAnnNotUsed #else     ideclExt = GHC.noExtField #endif     ideclAs = toMod <$> ideclAsString     ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified++reuseParsedModule state f = do+        pm <- useOrFail state "Retrie.GetParsedModule" NoParse GetParsedModule f+        (fixities, pm') <- fixFixities state f (fixAnns pm)+        return (fixities, pm')+getCPPmodule state session t = do+    nt <- toNormalizedFilePath' <$> makeAbsolute t+    let getParsedModule f contents = do+          modSummary <- msrModSummary <$>+            useOrFail state "Retrie.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 (GHCGHC.parseModule ms')+              `catch` \e -> throwIO (GHCParseError nt (show @SomeException e))+          (fixities, parsed) <- fixFixities state f (fixAnns parsed)+          return (fixities, parsed)++    contents <- do+      (_, mbContentsVFS) <-+        runAction "Retrie.GetFileContents" state $ getFileContents nt+      case mbContentsVFS of+        Just contents -> return contents+        Nothing       -> T.decodeUtf8 <$> BS.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 state nt+        return (fixities, NoCPP pm)

@@ -0,0 +1,97 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns           #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE PartialTypeSignatures    #-}+{-# LANGUAGE TypeOperators            #-}++module Main (main) where++import           Control.Concurrent                (threadDelay)+import           Control.Monad                     (void)+import           Data.Aeson+import qualified Data.Map                          as M+import           Data.Text                         (Text)+import qualified Development.IDE.GHC.ExactPrint+import qualified Development.IDE.Plugin.CodeAction as Refactor+import           Ide.Plugin.Config+import qualified Ide.Plugin.Retrie                 as Retrie+import           Ide.Types                         (IdePlugins (IdePlugins))+import           System.FilePath+import           Test.Hls+import           Test.Hls                          (PluginTestDescriptor)++main :: IO ()+main = defaultTestRunner tests++retriePlugin :: PluginTestDescriptor a+retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie"++refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log+refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor"++tests :: TestTree+tests = testGroup "Retrie"+    [ inlineThisTests+    ]++inlineThisTests :: TestTree+inlineThisTests = testGroup "Inline this"+    [+        testGroup "provider" [+            testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"],+            testProvider "identifier" "Identity" 4 16 ["Inline identity"],+            testProvider "imported identifier" "Imported" 4 12 ["Inline identity"],+            testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"],+            testProvider "nested let" "NestedLet" 6 12 ["Inline identity"],+            testProvider "class member" "Class" 5 16 [],+            testProvider "operator" "Operator" 4 16 ["Inline */"]+        ],+        testGroup "command" [+            testCommand "top level function" "Identity" 4 16,+            testCommand "top level function in another file" "Imported" 4 12,+            testCommand "nested where function" "NestedWhere" 4 16,+            testCommand "nested let function" "NestedLet" 6 12,+            testCommand "operator" "Operator" 4 16+        ]+    ]+++testProvider title file line row expected = testCase title $ runWithRetrie $ do+    adoc <- openDoc (file <.> "hs") "haskell"+    waitForTypecheck adoc+    let position = Position line row+    codeActions <- getCodeActions adoc $ Range position position+    liftIO $ map codeActionTitle codeActions @?= map Just expected++testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree+testCommand title file row col = goldenWithRetrie title file $ \adoc -> do+    waitForTypecheck adoc+    let p = Position row col+    codeActions <- getCodeActions adoc $ Range p p+    case codeActions of+        [InR ca] -> do+            executeCodeAction ca+            void $ skipManyTill anyMessage $ getDocumentEdit adoc+        [] -> error "No code actions found"++codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle (InR CodeAction {_title}) = Just _title+codeActionTitle _                         = Nothing++goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithRetrie title path act =+    goldenWithHaskellDoc testPlugins title testDataDir path "expected" "hs" $ \doc -> do+        sendConfigurationChanged $ toJSON $+            def { plugins = M.fromList [("retrie", def)] }+        act doc++runWithRetrie :: Session a -> IO a+runWithRetrie = runSessionWithServer testPlugins testDataDir++testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log+testPlugins =+    retriePlugin <>+    refactorPlugin  -- needed for the GetAnnotatedParsedSource rule++testDataDir :: FilePath+testDataDir = "test" </> "testdata"