diff --git a/hls-retrie-plugin.cabal b/hls-retrie-plugin.cabal --- a/hls-retrie-plugin.cabal +++ b/hls-retrie-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/Retrie.hs b/src/Ide/Plugin/Retrie.hs --- a/src/Ide/Plugin/Retrie.hs +++ b/src/Ide/Plugin/Retrie.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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"