diff --git a/hls-gadt-plugin.cabal b/hls-gadt-plugin.cabal --- a/hls-gadt-plugin.cabal +++ b/hls-gadt-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-gadt-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Convert to GADT syntax plugin description: Please see the README on GitHub at @@ -30,13 +30,13 @@ , containers , extra , ghc - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , ghc-boot-th , ghc-exactprint - , hls-plugin-api == 2.0.0.1 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lens - , lsp >=1.2.0.1 + , lsp >=2.1.0.0 , mtl , text , transformers @@ -59,7 +59,7 @@ , base , filepath , hls-gadt-plugin - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , lens , lsp , lsp-test diff --git a/src/Ide/Plugin/GADT.hs b/src/Ide/Plugin/GADT.hs --- a/src/Ide/Plugin/GADT.hs +++ b/src/Ide/Plugin/GADT.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -8,33 +9,39 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.GADT (descriptor) where -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import Control.Lens ((^.)) -import Control.Monad.Except -import Data.Aeson (FromJSON, ToJSON, Value (Null), - toJSON) -import Data.Either.Extra (maybeToEither) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text as T +import Control.Lens ((^.)) + +import Control.Monad.Error.Class (MonadError (throwError), + liftEither) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT, runExceptT, + withExceptT) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Either.Extra (maybeToEither) +import qualified Data.Map as Map +import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat -import Control.Monad.Trans.Except (throwE) -import Data.Maybe (mapMaybe) -import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) -import GHC.Generics (Generic) +import Data.Maybe (mapMaybe) +import Development.IDE.Core.PluginUtils +import Development.IDE.Spans.Pragmas (getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Plugin.Error import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types -import Language.LSP.Server (sendRequest) -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (sendRequest) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionHandler + mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler , pluginCommands = [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)] } @@ -50,54 +57,55 @@ -- | A command replaces H98 data decl with GADT decl in place toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams -toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do - nfp <- getNormalizedFilePath uri +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = withExceptT handleGhcidePluginError $ do + nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d - _ -> throwE $ "Expected 1 declaration, but got " <> show (Prelude.length decls) - deps <- liftIO $ runAction (T.unpack pId' <> ".GhcSessionDeps") state $ use GhcSessionDeps nfp - (hsc_dflags . hscEnv -> df) <- liftEither - $ maybeToEither "Get GhcSessionDeps failed" deps - txt <- liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl + _ -> throwError $ UnexpectedNumberOfDeclarations (Prelude.length decls) + deps <- withExceptT GhcidePluginErrors + $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state + $ useE GhcSessionDeps nfp + (hsc_dflags . hscEnv -> df) <- pure deps + txt <- withExceptT (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither - $ maybeToEither "Unable to get data decl range" + $ maybeToEither FailedToFindDataDeclRange $ srcSpanToRange $ locA ann - pragma <- getFirstPragma pId state nfp + pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest - SWorkspaceApplyEdit + SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) (\_ -> pure ()) - pure Null + pure $ InR Null where workSpaceEdit nfp edits = WorkspaceEdit - (pure $ HashMap.fromList + (pure $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, - List edits)]) + edits)]) Nothing Nothing -codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponse $ do - nfp <- getNormalizedFilePath (doc ^. L.uri) +codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT handleGhcidePluginError $ do + nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls - pure $ List actions + pure $ InL actions where mkAction :: T.Text -> Command |? CodeAction mkAction name = InR CodeAction{..} where _title = "Convert \"" <> name <> "\" to GADT syntax" - _kind = Just CodeActionRefactorRewrite + _kind = Just CodeActionKind_RefactorRewrite _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing _edit = Nothing _command = Just $ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam]) - _xdata = Nothing + _data_ = Nothing mkParam = ToGADTParams (doc ^. L.uri) range @@ -106,15 +114,33 @@ IdeState -> Range -> NormalizedFilePath - -> ExceptT String m ([LTyClDecl GP], [Extension]) + -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) getInRangeH98DeclsAndExts state range nfp = do - pm <- handleMaybeM "Unable to get ParsedModuleWithComments" - $ liftIO - $ runAction "GADT.GetParsedModuleWithComments" state - $ use GetParsedModuleWithComments nfp + pm <- withExceptT GhcidePluginErrors + $ runActionE "GADT.GetParsedModuleWithComments" state + $ useE GetParsedModuleWithComments nfp let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm decls = filter isH98DataDecl $ mapMaybe getDataDecl $ filter (inRange range) hsDecls exts = getExtensions pm pure (decls, exts) + +data GadtPluginError + = UnexpectedNumberOfDeclarations Int + | FailedToFindDataDeclRange + | PrettyGadtError T.Text + | GhcidePluginErrors PluginError + +handleGhcidePluginError :: + GadtPluginError -> + PluginError +handleGhcidePluginError = \case + UnexpectedNumberOfDeclarations nums -> do + PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums) + FailedToFindDataDeclRange -> + PluginInternalError $ "Unable to get data decl range" + PrettyGadtError errMsg -> + PluginInternalError $ errMsg + GhcidePluginErrors errors -> + errors diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -74,8 +74,8 @@ isGADTCodeAction CodeAction{..} = case _kind of Nothing -> False Just kind -> case kind of - CodeActionRefactorRewrite -> True - _ -> False + CodeActionKind_RefactorRewrite -> True + _ -> False testDataDir :: FilePath testDataDir = "test" "testdata"