hls-refactor-plugin-1.0.0.0: src/Development/IDE/Plugin/CodeAction/Args.hs
module Development.IDE.Plugin.CodeAction.Args
( CodeActionTitle,
CodeActionPreferred,
GhcideCodeActionResult,
GhcideCodeAction,
mkGhcideCAPlugin,
mkGhcideCAsPlugin,
ToTextEdit (..),
ToCodeAction (..),
wrap,
mkCA,
)
where
import Control.Concurrent.STM.Stats (readTVarIO)
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Data.Either (fromRight)
import qualified Data.HashMap.Strict as Map
import Data.IORef.Extra
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Development.IDE hiding
(pluginHandlers)
import Development.IDE.Core.Shake
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Compat.ExactPrint
import Development.IDE.GHC.ExactPrint
#if !MIN_VERSION_ghc(9,3,0)
import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,
rewriteToEdit)
#endif
import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),
GlobalBindingTypeSigsResult)
import Development.IDE.Spans.LocalBindings (Bindings)
import Development.IDE.Types.Exports (ExportsMap)
import Development.IDE.Types.Options (IdeOptions)
import Ide.Plugin.Config (Config)
import Ide.Types
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
type CodeActionTitle = T.Text
type CodeActionPreferred = Bool
type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])]
type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult
-------------------------------------------------------------------------------------------------
{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}
runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do
let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key
caaGhcSession <- onceIO $ runRule GhcSession
caaExportsMap <-
onceIO $
caaGhcSession >>= \case
Just env -> do
pkgExports <- envPackageExports env
localExports <- readTVarIO (exportsMap $ shakeExtras state)
pure $ localExports <> pkgExports
_ -> pure mempty
caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
caaContents <-
onceIO $
runRule GetFileContents >>= \case
Just (_, txt) -> pure txt
_ -> pure Nothing
caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
#if !MIN_VERSION_ghc(9,3,0)
caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
#endif
caaTmr <- onceIO $ runRule TypeCheck
caaHar <- onceIO $ runRule GetHieAst
caaBindings <- onceIO $ runRule GetBindings
caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
liftIO $
concat
<$> sequence
[ runReaderT codeAction caa
| caaDiagnostic <- diags,
let caa = CodeActionArgs {..}
]
mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
mkCA title kind isPreferred diags edit =
InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing
mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState
mkGhcideCAPlugin codeAction plId =
(defaultPluginDescriptor plId)
{ pluginHandlers = mkPluginHandler STextDocumentCodeAction $
\state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do
results <- runGhcideCodeAction state params codeAction
pure $
Right $
List
[ mkCA title kind isPreferred diags edit
| (title, kind, isPreferred, tedit) <- results,
let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
]
}
mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState
mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions
-------------------------------------------------------------------------------------------------
class ToTextEdit a where
toTextEdit :: CodeActionArgs -> a -> IO [TextEdit]
instance ToTextEdit TextEdit where
toTextEdit _ = pure . pure
#if !MIN_VERSION_ghc(9,3,0)
instance ToTextEdit Rewrite where
toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $
runMaybeT $ do
df <- MaybeT caaDf
#if !MIN_VERSION_ghc(9,2,0)
ps <- MaybeT caaAnnSource
let r = rewriteToEdit df (annsA ps) rw
#else
let r = rewriteToEdit df rw
#endif
pure $ fromRight [] r
#endif
instance ToTextEdit a => ToTextEdit [a] where
toTextEdit caa = foldMap (toTextEdit caa)
instance ToTextEdit a => ToTextEdit (Maybe a) where
toTextEdit caa = maybe (pure []) (toTextEdit caa)
instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where
toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)
-------------------------------------------------------------------------------------------------
data CodeActionArgs = CodeActionArgs
{ caaExportsMap :: IO ExportsMap,
caaGhcSession :: IO (Maybe HscEnvEq),
caaIdeOptions :: IO IdeOptions,
caaParsedModule :: IO (Maybe ParsedModule),
caaContents :: IO (Maybe T.Text),
caaDf :: IO (Maybe DynFlags),
#if MIN_VERSION_ghc(9,3,0)
caaAnnSource :: IO (Maybe ParsedSource),
#else
caaAnnSource :: IO (Maybe (Annotated ParsedSource)),
#endif
caaTmr :: IO (Maybe TcModuleResult),
caaHar :: IO (Maybe HieAstResult),
caaBindings :: IO (Maybe Bindings),
caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult),
caaDiagnostic :: Diagnostic
}
-- | There's no concurrency in each provider,
-- so we don't need to be thread-safe here
onceIO :: MonadIO m => IO a -> m (IO a)
onceIO io = do
var <- liftIO $ newIORef Nothing
pure $
readIORef var >>= \case
Just x -> pure x
_ -> io >>= \x -> writeIORef' var (Just x) >> pure x
-------------------------------------------------------------------------------------------------
wrap :: (ToCodeAction a) => a -> GhcideCodeAction
wrap = toCodeAction
class ToCodeAction a where
toCodeAction :: a -> GhcideCodeAction
instance ToCodeAction GhcideCodeAction where
toCodeAction = id
instance Semigroup GhcideCodeAction where
a <> b = toCodeAction [a, b]
instance Monoid GhcideCodeAction where
mempty = pure []
instance ToCodeAction a => ToCodeAction [a] where
toCodeAction = fmap concat . mapM toCodeAction
instance ToCodeAction a => ToCodeAction (Maybe a) where
toCodeAction = maybe (pure []) toCodeAction
instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where
toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te
instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where
toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te
instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where
toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te
instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where
toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te
-------------------------------------------------------------------------------------------------
toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction
toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f
toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction
toCodeAction2 get f = ReaderT $ \caa ->
get caa >>= \case
Just x -> flip runReaderT caa . toCodeAction . f $ x
_ -> pure []
toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction
toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f
-- | this instance returns a delta AST, useful for exactprint transforms
instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
#if !MIN_VERSION_ghc(9,3,0)
toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->
x >>= \case
Just s -> flip runReaderT caa . toCodeAction . f . astA $ s
_ -> pure []
#else
toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} ->
x >>= \case
Just s -> flip runReaderT caa . toCodeAction . f . pm_parsed_source $ s
_ -> pure []
#endif
instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where
toCodeAction = toCodeAction3 caaExportsMap
instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
toCodeAction = toCodeAction3 caaIdeOptions
instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x
instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where
toCodeAction = toCodeAction1 caaParsedModule
instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where
toCodeAction = toCodeAction2 caaParsedModule
instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where
toCodeAction = toCodeAction1 caaContents
instance ToCodeAction r => ToCodeAction (T.Text -> r) where
toCodeAction = toCodeAction2 caaContents
instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
toCodeAction = toCodeAction1 caaDf
instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
toCodeAction = toCodeAction2 caaDf
#if !MIN_VERSION_ghc(9,3,0)
instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where
toCodeAction = toCodeAction1 caaAnnSource
instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where
toCodeAction = toCodeAction2 caaAnnSource
#endif
instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where
toCodeAction = toCodeAction1 caaTmr
instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where
toCodeAction = toCodeAction2 caaTmr
instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where
toCodeAction = toCodeAction1 caaHar
instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where
toCodeAction = toCodeAction2 caaHar
instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where
toCodeAction = toCodeAction1 caaBindings
instance ToCodeAction r => ToCodeAction (Bindings -> r) where
toCodeAction = toCodeAction2 caaBindings
instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where
toCodeAction = toCodeAction1 caaGblSigs
instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where
toCodeAction = toCodeAction2 caaGblSigs
instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where
toCodeAction = toCodeAction1 caaGhcSession
instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where
toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession)