{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.GADT (descriptor) where
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, 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 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 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 :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
Ide.Types.pluginHandlers =
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeAction
SMethod_TextDocumentCodeAction PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler
, pluginCommands :: [PluginCommand IdeState]
pluginCommands =
[forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
toGADTSyntaxCommandId Text
"convert data decl to GADT syntax" (PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand PluginId
plId)]
}
data ToGADTParams = ToGADTParams
{ ToGADTParams -> Uri
uri :: Uri
, ToGADTParams -> Range
range :: Range
} deriving (forall x. Rep ToGADTParams x -> ToGADTParams
forall x. ToGADTParams -> Rep ToGADTParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ToGADTParams x -> ToGADTParams
$cfrom :: forall x. ToGADTParams -> Rep ToGADTParams x
Generic, [ToGADTParams] -> Encoding
[ToGADTParams] -> Value
ToGADTParams -> Encoding
ToGADTParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ToGADTParams] -> Encoding
$ctoEncodingList :: [ToGADTParams] -> Encoding
toJSONList :: [ToGADTParams] -> Value
$ctoJSONList :: [ToGADTParams] -> Value
toEncoding :: ToGADTParams -> Encoding
$ctoEncoding :: ToGADTParams -> Encoding
toJSON :: ToGADTParams -> Value
$ctoJSON :: ToGADTParams -> Value
ToJSON, Value -> Parser [ToGADTParams]
Value -> Parser ToGADTParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ToGADTParams]
$cparseJSONList :: Value -> Parser [ToGADTParams]
parseJSON :: Value -> Parser ToGADTParams
$cparseJSON :: Value -> Parser ToGADTParams
FromJSON)
toGADTSyntaxCommandId :: CommandId
toGADTSyntaxCommandId :: CommandId
toGADTSyntaxCommandId = CommandId
"GADT.toGADT"
toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand pId :: PluginId
pId@(PluginId Text
pId') IdeState
state ToGADTParams{Uri
Range
range :: Range
uri :: Uri
range :: ToGADTParams -> Range
uri :: ToGADTParams -> Uri
..} = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (PluginError -> GadtPluginError
GhcidePluginErrors) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp
(L SrcSpanAnn' (EpAnn AnnListItem)
ann TyClDecl GP
decl) <- case [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls of
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
d] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
d
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Int -> GadtPluginError
UnexpectedNumberOfDeclarations (forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls)
HscEnvEq
deps <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> String
T.unpack Text
pId' forall a. Semigroup a => a -> a -> a
<> String
".GhcSessionDeps") IdeState
state
forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
(HscEnv -> DynFlags
hsc_dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv -> DynFlags
df) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnvEq
deps
Text
txt <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Text -> GadtPluginError
PrettyGadtError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DynFlags -> TyClDecl GP -> Either String String
prettyGADTDecl DynFlags
df forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GP -> TyClDecl GP
h98ToGADTDecl) TyClDecl GP
decl
Range
range <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
forall a b. (a -> b) -> a -> b
$ forall a b. a -> Maybe b -> Either a b
maybeToEither GadtPluginError
FailedToFindDataDeclRange
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
ann
NextPragmaInfo
pragma <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m NextPragmaInfo
getFirstPragma PluginId
pId IdeState
state NormalizedFilePath
nfp
let insertEdit :: [TextEdit]
insertEdit = [NextPragmaInfo -> Extension -> TextEdit
insertNewPragma NextPragmaInfo
pragma Extension
GADTs | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Extension]
exts) [Extension
GADTSyntax, Extension
GADTs]]
LspId 'Method_WorkspaceApplyEdit
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest
SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit
(Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing (NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp (Range -> Text -> TextEdit
TextEdit Range
range Text
txt forall a. a -> [a] -> [a]
: [TextEdit]
insertEdit)))
(\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null
where
workSpaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp [TextEdit]
edits = Maybe (Map Uri [TextEdit])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[(String -> Uri
filePathToUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp,
[TextEdit]
edits)])
forall a. Maybe a
Nothing forall a. Maybe a
Nothing
codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
doc Range
range CodeActionContext
_) = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (PluginError -> GadtPluginError
GhcidePluginErrors) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (TextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls, [Extension]
_) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp
let actions :: [Command |? CodeAction]
actions = forall a b. (a -> b) -> [a] -> [b]
map (Text -> Command |? CodeAction
mkAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. TyClDecl pass -> LIdP pass
tcdLName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [Command |? CodeAction]
actions
where
mkAction :: T.Text -> Command |? CodeAction
mkAction :: Text -> Command |? CodeAction
mkAction Text
name = forall a b. b -> a |? b
InR CodeAction{Maybe CodeActionKind
Maybe Command
Text
forall a. Maybe a
$sel:_title:CodeAction :: Text
$sel:_kind:CodeAction :: Maybe CodeActionKind
$sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
$sel:_isPreferred:CodeAction :: Maybe Bool
$sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
$sel:_edit:CodeAction :: Maybe WorkspaceEdit
$sel:_command:CodeAction :: Maybe Command
$sel:_data_:CodeAction :: Maybe Value
_data_ :: forall a. Maybe a
_command :: Maybe Command
_edit :: forall a. Maybe a
_disabled :: forall a. Maybe a
_isPreferred :: forall a. Maybe a
_diagnostics :: forall a. Maybe a
_kind :: Maybe CodeActionKind
_title :: Text
..}
where
_title :: Text
_title = Text
"Convert \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\" to GADT syntax"
_kind :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorRewrite
_diagnostics :: Maybe a
_diagnostics = forall a. Maybe a
Nothing
_isPreferred :: Maybe a
_isPreferred = forall a. Maybe a
Nothing
_disabled :: Maybe a
_disabled = forall a. Maybe a
Nothing
_edit :: Maybe a
_edit = forall a. Maybe a
Nothing
_command :: Maybe Command
_command = forall a. a -> Maybe a
Just
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
toGADTSyntaxCommandId Text
_title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON ToGADTParams
mkParam])
_data_ :: Maybe a
_data_ = forall a. Maybe a
Nothing
mkParam :: ToGADTParams
mkParam = Uri -> Range -> ToGADTParams
ToGADTParams (TextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri) Range
range
getInRangeH98DeclsAndExts :: (MonadIO m) =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp = do
ParsedModule
pm <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"GADT.GetParsedModuleWithComments" IdeState
state
forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
let (L SrcSpan
_ [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
hsDecls) = HsModule -> [LHsDecl GP]
hsmodDecls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
decls :: [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls = forall a. (a -> Bool) -> [a] -> [a]
filter LTyClDecl GP -> Bool
isH98DataDecl
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsDecl GP -> Maybe (LTyClDecl GP)
getDataDecl
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. HasSrcSpan a => Range -> a -> Bool
inRange Range
range) [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
hsDecls
exts :: [Extension]
exts = ParsedModule -> [Extension]
getExtensions ParsedModule
pm
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts)
data GadtPluginError
= UnexpectedNumberOfDeclarations Int
| FailedToFindDataDeclRange
| PrettyGadtError T.Text
| GhcidePluginErrors PluginError
handleGhcidePluginError ::
GadtPluginError ->
PluginError
handleGhcidePluginError :: GadtPluginError -> PluginError
handleGhcidePluginError = \case
UnexpectedNumberOfDeclarations Int
nums -> do
Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
"Expected one declaration but found: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
nums)
GadtPluginError
FailedToFindDataDeclRange ->
Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
"Unable to get data decl range"
PrettyGadtError Text
errMsg ->
Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
errMsg
GhcidePluginErrors PluginError
errors ->
PluginError
errors