1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveAnyClass #-} 3{-# LANGUAGE DeriveGeneric #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE LambdaCase #-} 6{-# LANGUAGE NamedFieldPuns #-} 7{-# LANGUAGE OverloadedStrings #-} 8{-# LANGUAGE PatternSynonyms #-} 9{-# LANGUAGE RecordWildCards #-} 10{-# LANGUAGE ScopedTypeVariables #-} 11{-# LANGUAGE StandaloneDeriving #-} 12{-# LANGUAGE TypeApplications #-} 13{-# LANGUAGE TypeFamilies #-} 14 15{-# OPTIONS -Wno-orphans #-} 16 17module Ide.Plugin.Retrie (descriptor, response, handleMaybe, handleMaybeM) where 18 19import Control.Concurrent.Extra (readVar) 20import Control.Exception.Safe (Exception (..), 21 SomeException, catch, 22 throwIO, try) 23import Control.Monad (forM, unless) 24import Control.Monad.Extra (maybeM) 25import Control.Monad.IO.Class (MonadIO (liftIO)) 26import Control.Monad.Trans.Class (MonadTrans (lift)) 27import Control.Monad.Trans.Except (ExceptT (..), runExceptT, 28 throwE) 29import Control.Monad.Trans.Maybe 30import Data.Aeson (FromJSON (..), 31 ToJSON (..), 32 Value (Null), 33 genericParseJSON) 34import qualified Data.Aeson as Aeson 35import Data.Bifunctor (Bifunctor (first), 36 second) 37import Data.Coerce 38import Data.Either (partitionEithers) 39import qualified Data.HashMap.Strict as HM 40import qualified Data.HashSet as Set 41import Data.Hashable (unhashed) 42import Data.IORef.Extra (atomicModifyIORef'_, 43 newIORef, readIORef) 44import Data.List.Extra (find, nubOrdOn) 45import Data.String (IsString (fromString)) 46import qualified Data.Text as T 47import qualified Data.Text.IO as T 48import Data.Typeable (Typeable) 49import Development.IDE hiding (pluginHandlers) 50import Development.IDE.Core.PositionMapping 51import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar), 52 toKnownFiles) 53import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, 54 HsBindLR (FunBind), 55 HsGroup (..), 56 HsValBindsLR (..), 57 HscEnv, IdP, LRuleDecls, 58 ModSummary (ModSummary, ms_hspp_buf, ms_mod), 59 NHsValBindsLR (..), 60 ParsedModule (..), 61 RuleDecl (HsRule), 62 RuleDecls (HsRules), 63 SrcSpan (..), 64 TyClDecl (SynDecl), 65 TyClGroup (..), fun_id, 66 mi_fixities, 67 moduleNameString, 68 parseModule, 69 pattern IsBoot, 70 pattern NotBoot, 71 pattern OldRealSrcSpan, 72 rds_rules, srcSpanFile) 73import GHC.Generics (Generic) 74import GhcPlugins (Outputable, 75 SourceText (NoSourceText), 76 hm_iface, isQual, 77 isQual_maybe, 78 nameModule_maybe, 79 nameRdrName, occNameFS, 80 occNameString, 81 rdrNameOcc, unpackFS) 82import Ide.PluginUtils 83import Ide.Types 84import Language.LSP.Server (LspM, 85 ProgressCancellable (Cancellable), 86 sendNotification, 87 sendRequest, 88 withIndefiniteProgress) 89import Language.LSP.Types as J hiding 90 (SemanticTokenAbsolute (length, line), 91 SemanticTokenRelative (length), 92 SemanticTokensEdit (_start)) 93import Retrie.CPP (CPP (NoCPP), parseCPP) 94import Retrie.ExactPrint (fix, relativiseApiAnns, 95 transformA, unsafeMkA) 96import Retrie.Fixity (mkFixityEnv) 97import qualified Retrie.GHC as GHC 98import Retrie.Monad (addImports, apply, 99 getGroundTerms, 100 runRetrie) 101import Retrie.Options (defaultOptions, 102 getTargetFiles) 103import qualified Retrie.Options as Retrie 104import Retrie.Replace (Change (..), 105 Replacement (..)) 106import Retrie.Rewrites 107import Retrie.SYB (listify) 108import Retrie.Util (Verbosity (Loud)) 109import StringBuffer (stringToStringBuffer) 110import System.Directory (makeAbsolute) 111 112descriptor :: PluginId -> PluginDescriptor IdeState 113descriptor plId = 114 (defaultPluginDescriptor plId) 115 { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider, 116 pluginCommands = [retrieCommand] 117 } 118 119retrieCommandName :: T.Text 120retrieCommandName = "retrieCommand" 121 122retrieCommand :: PluginCommand IdeState 123retrieCommand = 124 PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd 125 126-- | Parameters for the runRetrie PluginCommand. 127data RunRetrieParams = RunRetrieParams 128 { description :: T.Text, 129 rewrites :: [RewriteSpec], 130 originatingFile :: Uri, 131 restrictToOriginatingFile :: Bool 132 } 133 deriving (Eq, Show, Generic, FromJSON, ToJSON) 134runRetrieCmd :: 135 IdeState -> 136 RunRetrieParams -> 137 LspM c (Either ResponseError Value) 138runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = 139 withIndefiniteProgress description Cancellable $ do 140 runMaybeT $ do 141 nfp <- MaybeT $ return $ uriToNormalizedFilePath $ toNormalizedUri uri 142 (session, _) <- MaybeT $ liftIO $ 143 runAction "Retrie.GhcSessionDeps" state $ 144 useWithStale GhcSessionDeps 145 nfp 146 (ms, binds, _, _, _) <- MaybeT $ liftIO $ runAction "Retrie.getBinds" state $ getBinds nfp 147 let importRewrites = concatMap (extractImports ms binds) rewrites 148 (errors, edits) <- liftIO $ 149 callRetrie 150 state 151 (hscEnv session) 152 (map Right rewrites <> map Left importRewrites) 153 nfp 154 restrictToOriginatingFile 155 unless (null errors) $ 156 lift $ sendNotification SWindowShowMessage $ 157 ShowMessageParams MtWarning $ 158 T.unlines $ 159 "## Found errors during rewrite:" : 160 ["-" <> T.pack (show e) | e <- errors] 161 lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) 162 return () 163 return $ Right Null 164 165extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] 166extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing) 167 | Just FunBind {fun_matches} 168 <- find (\case FunBind{fun_id = L _ n} -> prettyPrint n == thing ; _ -> False) topLevelBinds 169 , names <- listify p fun_matches 170 = 171 [ AddImport {..} 172 | let ideclSource = False, 173 name <- names, 174 let r = nameRdrName name, 175 let ideclQualifiedBool = isQual r, 176 let ideclAsString = moduleNameString . fst <$> isQual_maybe r, 177 let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r), 178 Just ideclNameString <- 179 [moduleNameString . GHC.moduleName <$> nameModule_maybe name] 180 ] 181 where 182 p name = nameModule_maybe name /= Just ms_mod 183-- TODO handle imports for all rewrites 184extractImports _ _ _ = [] 185 186------------------------------------------------------------------------------- 187 188provider :: PluginMethodHandler IdeState TextDocumentCodeAction 189provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = response $ do 190 let (J.CodeActionContext _diags _monly) = ca 191 nuri = toNormalizedUri uri 192 nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri 193 194 (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) 195 <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ getBinds nfp 196 197 pos <- handleMaybe "pos" $ _start <$> fromCurrentRange posMapping range 198 let rewrites = 199 concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds 200 ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds 201 ++ [ r 202 | TyClGroup {group_tyclds} <- hs_tyclds, 203 L l g <- group_tyclds, 204 pos `isInsideSrcSpan` l, 205 r <- suggestTypeRewrites uri ms_mod g 206 207 ] 208 209 commands <- lift $ 210 forM rewrites $ \(title, kind, params) -> liftIO $ do 211 let c = mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params]) 212 return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing 213 214 return $ J.List [InR c | c <- commands] 215 216getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])) 217getBinds nfp = runMaybeT $ do 218 (tm, posMapping) <- MaybeT $ useWithStale TypeCheck nfp 219 -- we use the typechecked source instead of the parsed source 220 -- to be able to extract module names from the Ids, 221 -- so that we can include adding the required imports in the retrie command 222 let rn = tmrRenamed tm 223 ( HsGroup 224 { hs_valds = 225 XValBindsLR 226 (NValBinds binds _sigs :: NHsValBindsLR GHC.GhcRn), 227 hs_ruleds, 228 hs_tyclds 229 }, 230 _, 231 _, 232 _ 233 ) = rn 234 235 topLevelBinds = 236 [ decl 237 | (_, bagBinds) <- binds, 238 L _ decl <- GHC.bagToList bagBinds 239 ] 240 return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) 241 242suggestBindRewrites :: 243 Uri -> 244 Position -> 245 GHC.Module -> 246 HsBindLR GhcRn GhcRn -> 247 [(T.Text, CodeActionKind, RunRetrieParams)] 248suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L l' rdrName} 249 | pos `isInsideSrcSpan` l' = 250 let pprName = prettyPrint rdrName 251 pprNameText = T.pack pprName 252 unfoldRewrite restrictToOriginatingFile = 253 let rewrites = [Unfold (qualify ms_mod pprName)] 254 description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile 255 in (description, CodeActionRefactorInline, RunRetrieParams {..}) 256 foldRewrite restrictToOriginatingFile = 257 let rewrites = [Fold (qualify ms_mod pprName)] 258 description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile 259 in (description, CodeActionRefactorExtract, RunRetrieParams {..}) 260 in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] 261suggestBindRewrites _ _ _ _ = [] 262 263describeRestriction :: IsString p => Bool -> p 264describeRestriction restrictToOriginatingFile = 265 if restrictToOriginatingFile then " in current file" else "" 266 267suggestTypeRewrites :: 268 (Outputable (IdP pass)) => 269 Uri -> 270 GHC.Module -> 271 TyClDecl pass -> 272 [(T.Text, CodeActionKind, RunRetrieParams)] 273suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName = L _ rdrName} = 274 let pprName = prettyPrint rdrName 275 pprNameText = T.pack pprName 276 unfoldRewrite restrictToOriginatingFile = 277 let rewrites = [TypeForward (qualify ms_mod pprName)] 278 description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile 279 in (description, CodeActionRefactorInline, RunRetrieParams {..}) 280 foldRewrite restrictToOriginatingFile = 281 let rewrites = [TypeBackward (qualify ms_mod pprName)] 282 description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile 283 in (description, CodeActionRefactorExtract, RunRetrieParams {..}) 284 in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] 285suggestTypeRewrites _ _ _ = [] 286 287suggestRuleRewrites :: 288 Uri -> 289 Position -> 290 GHC.Module -> 291 LRuleDecls pass -> 292 [(T.Text, CodeActionKind, RunRetrieParams)] 293suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = 294 concat 295 [ [ forwardRewrite ruleName True 296 , forwardRewrite ruleName False 297 , backwardsRewrite ruleName True 298 , backwardsRewrite ruleName False 299 ] 300 | L l r <- rds_rules, 301 pos `isInsideSrcSpan` l, 302#if MIN_VERSION_ghc(8,8,0) 303 let HsRule {rd_name = L _ (_, rn)} = r, 304#else 305 let HsRule _ (L _ (_,rn)) _ _ _ _ = r, 306#endif 307 let ruleName = unpackFS rn 308 ] 309 where 310 forwardRewrite ruleName restrictToOriginatingFile = 311 let rewrites = [RuleForward (qualify ms_mod ruleName)] 312 description = "Apply rule " <> T.pack ruleName <> " forward" <> 313 describeRestriction restrictToOriginatingFile 314 315 in ( description, 316 CodeActionRefactor, 317 RunRetrieParams {..} 318 ) 319 backwardsRewrite ruleName restrictToOriginatingFile = 320 let rewrites = [RuleBackward (qualify ms_mod ruleName)] 321 description = "Apply rule " <> T.pack ruleName <> " backwards" <> 322 describeRestriction restrictToOriginatingFile 323 in ( description, 324 CodeActionRefactor, 325 RunRetrieParams {..} 326 ) 327 328suggestRuleRewrites _ _ _ _ = [] 329 330qualify :: GHC.Module -> String -> String 331qualify ms_mod x = prettyPrint ms_mod <> "." <> x 332 333------------------------------------------------------------------------------- 334-- Retrie driving code 335 336data CallRetrieError 337 = CallRetrieInternalError String NormalizedFilePath 338 | NoParse NormalizedFilePath 339 | GHCParseError NormalizedFilePath String 340 | NoTypeCheck NormalizedFilePath 341 deriving (Eq, Typeable) 342 343instance Show CallRetrieError where 344 show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f 345 show (NoParse f) = "Cannot parse: " <> fromNormalizedFilePath f 346 show (GHCParseError f m) = "Cannot parse " <> fromNormalizedFilePath f <> " : " <> m 347 show (NoTypeCheck f) = "File does not typecheck: " <> fromNormalizedFilePath f 348 349instance Exception CallRetrieError 350 351callRetrie :: 352 IdeState -> 353 HscEnv -> 354 [Either ImportSpec RewriteSpec] -> 355 NormalizedFilePath -> 356 Bool -> 357 IO ([CallRetrieError], WorkspaceEdit) 358callRetrie state session rewrites origin restrictToOriginatingFile = do 359 knownFiles <- toKnownFiles . unhashed <$> readVar (knownTargetsVar $ shakeExtras state) 360 let reuseParsedModule f = do 361 pm <- 362 useOrFail "GetParsedModule" NoParse GetParsedModule f 363 (fixities, pm) <- fixFixities f (fixAnns pm) 364 return (fixities, pm) 365 getCPPmodule t = do 366 nt <- toNormalizedFilePath' <$> makeAbsolute t 367 let getParsedModule f contents = do 368 modSummary <- msrModSummary <$> 369 useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt 370 let ms' = 371 modSummary 372 { ms_hspp_buf = 373 Just (stringToStringBuffer contents) 374 } 375 logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t 376 parsed <- 377 evalGhcEnv session (parseModule ms') 378 `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) 379 (fixities, parsed) <- fixFixities f (fixAnns parsed) 380 return (fixities, parsed) 381 382 contents <- do 383 (_, mbContentsVFS) <- 384 runAction "Retrie.GetFileContents" state $ getFileContents nt 385 case mbContentsVFS of 386 Just contents -> return contents 387 Nothing -> T.readFile (fromNormalizedFilePath nt) 388 if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents) 389 then do 390 fixitiesRef <- newIORef mempty 391 let parseModule x = do 392 (fix, res) <- getParsedModule nt x 393 atomicModifyIORef'_ fixitiesRef (fix <>) 394 return res 395 res <- parseCPP parseModule contents 396 fixities <- readIORef fixitiesRef 397 return (fixities, res) 398 else do 399 (fixities, pm) <- reuseParsedModule nt 400 return (fixities, NoCPP pm) 401 402 -- TODO cover all workspaceFolders 403 target = "." 404 405 retrieOptions :: Retrie.Options 406 retrieOptions = (defaultOptions target) 407 {Retrie.verbosity = Loud 408 ,Retrie.targetFiles = map fromNormalizedFilePath $ 409 if restrictToOriginatingFile 410 then [origin] 411 else Set.toList knownFiles 412 } 413 414 (theImports, theRewrites) = partitionEithers rewrites 415 416 annotatedImports = 417 unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0 418 419 (originFixities, originParsedModule) <- reuseParsedModule origin 420 retrie <- 421 (\specs -> apply specs >> addImports annotatedImports) 422 <$> parseRewriteSpecs 423 (\_f -> return $ NoCPP originParsedModule) 424 originFixities 425 theRewrites 426 427 targets <- getTargetFiles retrieOptions (getGroundTerms retrie) 428 429 results <- forM targets $ \t -> runExceptT $ do 430 (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule t 431 -- TODO add the imports to the resulting edits 432 (_user, ast, change@(Change _replacements _imports)) <- 433 lift $ runRetrie fixityEnv retrie cpp 434 return $ asTextEdits change 435 436 let (errors :: [CallRetrieError], replacements) = partitionEithers results 437 editParams :: WorkspaceEdit 438 editParams = 439 WorkspaceEdit (Just $ asEditMap replacements) Nothing Nothing 440 441 return (errors, editParams) 442 where 443 useOrFail :: 444 IdeRule r v => 445 String -> 446 (NormalizedFilePath -> CallRetrieError) -> 447 r -> 448 NormalizedFilePath -> 449 IO (RuleResult r) 450 useOrFail lbl mkException rule f = 451 useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return 452 fixityEnvFromModIface modIface = 453 mkFixityEnv 454 [ (fs, (fs, fixity)) 455 | (n, fixity) <- mi_fixities modIface, 456 let fs = occNameFS n 457 ] 458 fixFixities f pm = do 459 HiFileResult {hirHomeMod} <- 460 useOrFail "GetModIface" NoTypeCheck GetModIface f 461 let fixities = fixityEnvFromModIface $ hm_iface hirHomeMod 462 res <- transformA pm (fix fixities) 463 return (fixities, res) 464 fixAnns ParsedModule {..} = 465 let ranns = relativiseApiAnns pm_parsed_source pm_annotations 466 in unsafeMkA pm_parsed_source ranns 0 467 468asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap 469asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure)) 470 471asTextEdits :: Change -> [(Uri, TextEdit)] 472asTextEdits NoChange = [] 473asTextEdits (Change reps _imports) = 474 [ (filePathToUri spanLoc, edit) 475 | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps, 476 (OldRealSrcSpan rspan) <- [replLocation], 477 let spanLoc = unpackFS $ srcSpanFile rspan, 478 let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement) 479 ] 480 481------------------------------------------------------------------------------- 482-- Rule wrappers 483 484_useRuleBlocking, 485 _useRuleStale, 486 useRule :: 487 (IdeRule k v) => 488 String -> 489 IdeState -> 490 k -> 491 NormalizedFilePath -> 492 IO (Maybe (RuleResult k)) 493_useRuleBlocking label state rule f = runAction label state (use rule f) 494_useRuleStale label state rule f = 495 fmap fst 496 <$> runIdeAction label (shakeExtras state) (useWithStaleFast rule f) 497 498-- | Chosen approach for calling ghcide Shake rules 499useRule label = _useRuleStale ("Retrie." <> label) 500 501------------------------------------------------------------------------------- 502-- Error handling combinators 503 504handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b 505handleMaybe msg = maybe (throwE msg) return 506 507handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b 508handleMaybeM msg act = maybeM (throwE msg) return $ lift act 509 510response :: Monad m => ExceptT String m a -> m (Either ResponseError a) 511response = 512 fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) 513 . runExceptT 514 515------------------------------------------------------------------------------- 516-- Serialization wrappers and instances 517 518deriving instance Eq RewriteSpec 519 520deriving instance Show RewriteSpec 521 522deriving instance Generic RewriteSpec 523 524deriving instance FromJSON RewriteSpec 525 526deriving instance ToJSON RewriteSpec 527 528data QualName = QualName {qual, name :: String} 529 deriving (Eq, Show, Generic, FromJSON, ToJSON) 530 531data IE name 532 = IEVar name 533 deriving (Eq, Show, Generic, FromJSON, ToJSON) 534 535data ImportSpec = AddImport 536 { ideclNameString :: String, 537 ideclSource :: Bool, 538 ideclQualifiedBool :: Bool, 539 ideclAsString :: Maybe String, 540 ideclThing :: Maybe (IE String) 541 } 542 deriving (Eq, Show, Generic, FromJSON, ToJSON) 543 544toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs 545toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} 546 where 547 ideclSource' = if ideclSource then IsBoot else NotBoot 548 toMod = GHC.noLoc . GHC.mkModuleName 549 ideclName = toMod ideclNameString 550 ideclPkgQual = Nothing 551 ideclSafe = False 552 ideclImplicit = False 553 ideclHiding = Nothing 554 ideclSourceSrc = NoSourceText 555 ideclExt = GHC.noExtField 556 ideclAs = toMod <$> ideclAsString 557#if MIN_VERSION_ghc(8,10,0) 558 ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified 559#else 560 ideclQualified = ideclQualifiedBool 561#endif 562