{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RecordWildCards     #-}

{-# LANGUAGE NoMonoLocalBinds    #-}

{-# OPTIONS_GHC -Wno-orphans     #-}

module Wingman.AbstractLSP (installInteractions) where

import           Control.Monad (void)
import           Control.Monad.IO.Class
import           Control.Monad.Trans (lift)
import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Data.Aeson as A
import           Data.Coerce
import           Data.Foldable (traverse_)
import           Data.Monoid (Last (..))
import qualified Data.Text as T
import           Data.Traversable (for)
import           Data.Tuple.Extra (uncurry3)
import           Development.IDE (IdeState)
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource))
import qualified Ide.Plugin.Config as Plugin
import           Ide.Types
import           Language.LSP.Server (LspM, sendRequest, getClientCapabilities)
import qualified Language.LSP.Types as LSP
import           Language.LSP.Types hiding (CodeLens, CodeAction)
import           Wingman.AbstractLSP.Types
import           Wingman.EmptyCase (fromMaybeT)
import           Wingman.LanguageServer (getTacticConfig, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)
import           Wingman.StaticPlugin (enableQuasiQuotes)
import           Wingman.Types


------------------------------------------------------------------------------
-- | Attact the 'Interaction's to a 'PluginDescriptor'. Interactions are
-- self-contained request/response pairs that abstract over the LSP, and
-- provide a unified interface for doing interesting things, without needing to
-- dive into the underlying API too directly.
installInteractions
    :: [Interaction]
    -> PluginDescriptor IdeState
    -> PluginDescriptor IdeState
installInteractions :: [Interaction]
-> PluginDescriptor IdeState -> PluginDescriptor IdeState
installInteractions [Interaction]
is PluginDescriptor IdeState
desc =
  let plId :: PluginId
plId = PluginDescriptor IdeState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor IdeState
desc
   in PluginDescriptor IdeState
desc
        { pluginCommands :: [PluginCommand IdeState]
pluginCommands = PluginDescriptor IdeState -> [PluginCommand IdeState]
forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginCommands PluginDescriptor IdeState
desc [PluginCommand IdeState]
-> [PluginCommand IdeState] -> [PluginCommand IdeState]
forall a. Semigroup a => a -> a -> a
<> (Interaction -> PluginCommand IdeState)
-> [Interaction] -> [PluginCommand IdeState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PluginId -> Interaction -> PluginCommand IdeState
buildCommand PluginId
plId) [Interaction]
is
        , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = PluginDescriptor IdeState -> PluginHandlers IdeState
forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginHandlers PluginDescriptor IdeState
desc PluginHandlers IdeState
-> PluginHandlers IdeState -> PluginHandlers IdeState
forall a. Semigroup a => a -> a -> a
<> [Interaction] -> PluginHandlers IdeState
buildHandlers [Interaction]
is
        }


------------------------------------------------------------------------------
-- | Extract 'PluginHandlers' from 'Interaction's.
buildHandlers
    :: [Interaction]
    -> PluginHandlers IdeState
buildHandlers :: [Interaction] -> PluginHandlers IdeState
buildHandlers [Interaction]
cs =
  ((Interaction -> PluginHandlers IdeState)
 -> [Interaction] -> PluginHandlers IdeState)
-> [Interaction]
-> (Interaction -> PluginHandlers IdeState)
-> PluginHandlers IdeState
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Interaction -> PluginHandlers IdeState)
-> [Interaction] -> PluginHandlers IdeState
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Interaction]
cs ((Interaction -> PluginHandlers IdeState)
 -> PluginHandlers IdeState)
-> (Interaction -> PluginHandlers IdeState)
-> PluginHandlers IdeState
forall a b. (a -> b) -> a -> b
$ \(Interaction (Continuation sort target b
c :: Continuation sort target b)) ->
    case Continuation sort target b -> SynthesizeCommand target b
forall sort target payload.
Continuation sort target payload
-> SynthesizeCommand target payload
c_makeCommand Continuation sort target b
c of
      SynthesizeCodeAction LspEnv -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)]
k ->
        SClientMethod 'TextDocumentCodeAction
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeAction
STextDocumentCodeAction (PluginMethodHandler IdeState 'TextDocumentCodeAction
 -> PluginHandlers IdeState)
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall a b. (a -> b) -> a -> b
$ sort
-> (LspEnv
    -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
forall target sort b.
(IsContinuationSort sort, ToJSON b, IsTarget target) =>
sort
-> (LspEnv
    -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider @target (Continuation sort target b -> sort
forall sort target payload.
Continuation sort target payload -> sort
c_sort Continuation sort target b
c) LspEnv -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)]
k
      SynthesizeCodeLens LspEnv
-> TargetArgs target -> MaybeT (LspM Config) [(Range, Metadata, b)]
k ->
        SClientMethod 'TextDocumentCodeLens
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeLens
STextDocumentCodeLens   (PluginMethodHandler IdeState 'TextDocumentCodeLens
 -> PluginHandlers IdeState)
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
-> PluginHandlers IdeState
forall a b. (a -> b) -> a -> b
$ sort
-> (LspEnv
    -> TargetArgs target
    -> MaybeT (LspM Config) [(Range, Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
forall target sort b.
(IsContinuationSort sort, ToJSON b, IsTarget target) =>
sort
-> (LspEnv
    -> TargetArgs target
    -> MaybeT (LspM Config) [(Range, Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLensProvider   @target (Continuation sort target b -> sort
forall sort target payload.
Continuation sort target payload -> sort
c_sort Continuation sort target b
c) LspEnv
-> TargetArgs target -> MaybeT (LspM Config) [(Range, Metadata, b)]
k


------------------------------------------------------------------------------
-- | Extract a 'PluginCommand' from an 'Interaction'.
buildCommand
  :: PluginId
  -> Interaction
  -> PluginCommand IdeState
buildCommand :: PluginId -> Interaction -> PluginCommand IdeState
buildCommand PluginId
plId (Interaction (Continuation sort target b
c :: Continuation sort target b)) =
  PluginCommand :: forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand
    { commandId :: CommandId
commandId = sort -> CommandId
forall a. IsContinuationSort a => a -> CommandId
toCommandId (sort -> CommandId) -> sort -> CommandId
forall a b. (a -> b) -> a -> b
$ Continuation sort target b -> sort
forall sort target payload.
Continuation sort target payload -> sort
c_sort Continuation sort target b
c
    , commandDesc :: Text
commandDesc = String -> Text
T.pack String
""
    , commandFunc :: CommandFunction IdeState (FileContext, b)
commandFunc = PluginId
-> Continuation sort target b
-> CommandFunction IdeState (FileContext, b)
forall sort a b.
IsTarget a =>
PluginId
-> Continuation sort a b
-> CommandFunction IdeState (FileContext, b)
runContinuation PluginId
plId Continuation sort target b
c
    }


------------------------------------------------------------------------------
-- | Boilerplate for running a 'Continuation' as part of an LSP command.
runContinuation
    :: forall sort a b
     . IsTarget a
    => PluginId
    -> Continuation sort a b
    -> CommandFunction IdeState (FileContext, b)
runContinuation :: PluginId
-> Continuation sort a b
-> CommandFunction IdeState (FileContext, b)
runContinuation PluginId
plId Continuation sort a b
cont IdeState
state (FileContext
fc, b
b) = do
  Either ResponseError Value
-> MaybeT (LspM Config) (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT
    (ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ ResponseError :: ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError
              { $sel:_code:ResponseError :: ErrorCode
_code = ErrorCode
InternalError
              , $sel:_message:ResponseError :: Text
_message = String -> Text
T.pack String
"TODO(sandy)"
              , $sel:_xdata:ResponseError :: Maybe Value
_xdata =  Maybe Value
forall a. Maybe a
Nothing
              } ) (MaybeT (LspM Config) (Either ResponseError Value)
 -> LspM Config (Either ResponseError Value))
-> MaybeT (LspM Config) (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
      env :: LspEnv
env@LspEnv{DynFlags
IdeState
PluginId
Config
FileContext
le_fileContext :: LspEnv -> FileContext
le_config :: LspEnv -> Config
le_dflags :: LspEnv -> DynFlags
le_pluginId :: LspEnv -> PluginId
le_ideState :: LspEnv -> IdeState
le_fileContext :: FileContext
le_config :: Config
le_dflags :: DynFlags
le_pluginId :: PluginId
le_ideState :: IdeState
..} <- IdeState -> PluginId -> FileContext -> MaybeT (LspM Config) LspEnv
buildEnv IdeState
state PluginId
plId FileContext
fc
      NormalizedFilePath
nfp <- Uri -> MaybeT (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Applicative m =>
Uri -> MaybeT m NormalizedFilePath
getNfp (Uri -> MaybeT (LspM Config) NormalizedFilePath)
-> Uri -> MaybeT (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ FileContext -> Uri
fc_uri FileContext
le_fileContext
      let stale :: a -> MaybeT IO (TrackedStale (RuleResult a))
stale a
a = String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale (RuleResult a))
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Show a, Typeable a, NFData a,
 Show r, Typeable r, NFData r) =>
String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale r)
runStaleIde String
"runContinuation" IdeState
state NormalizedFilePath
nfp a
a
      TargetArgs a
args <- LspEnv -> MaybeT (LspM Config) (TargetArgs a)
forall t.
IsTarget t =>
LspEnv -> MaybeT (LspM Config) (TargetArgs t)
fetchTargetArgs @a LspEnv
env
      [ContinuationResult]
res <- Continuation sort a b
-> LspEnv
-> TargetArgs a
-> FileContext
-> b
-> MaybeT (LspM Config) [ContinuationResult]
forall sort target payload.
Continuation sort target payload
-> LspEnv
-> TargetArgs target
-> FileContext
-> payload
-> MaybeT (LspM Config) [ContinuationResult]
c_runCommand Continuation sort a b
cont LspEnv
env TargetArgs a
args FileContext
fc b
b

      -- This block returns a maybe error.
      ([Maybe ResponseError] -> Either ResponseError Value)
-> MaybeT (LspM Config) [Maybe ResponseError]
-> MaybeT (LspM Config) (Either ResponseError Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either ResponseError Value
-> (ResponseError -> Either ResponseError Value)
-> Maybe ResponseError
-> Either ResponseError Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
A.Null) ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (Maybe ResponseError -> Either ResponseError Value)
-> ([Maybe ResponseError] -> Maybe ResponseError)
-> [Maybe ResponseError]
-> Either ResponseError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last ResponseError -> Maybe ResponseError
coerce (Last ResponseError -> Maybe ResponseError)
-> ([Maybe ResponseError] -> Last ResponseError)
-> [Maybe ResponseError]
-> Maybe ResponseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ResponseError -> Last ResponseError)
-> [Maybe ResponseError] -> Last ResponseError
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe ResponseError -> Last ResponseError
forall a. Maybe a -> Last a
Last) (MaybeT (LspM Config) [Maybe ResponseError]
 -> MaybeT (LspM Config) (Either ResponseError Value))
-> MaybeT (LspM Config) [Maybe ResponseError]
-> MaybeT (LspM Config) (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$
        [ContinuationResult]
-> (ContinuationResult
    -> MaybeT (LspM Config) (Maybe ResponseError))
-> MaybeT (LspM Config) [Maybe ResponseError]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ContinuationResult]
res ((ContinuationResult -> MaybeT (LspM Config) (Maybe ResponseError))
 -> MaybeT (LspM Config) [Maybe ResponseError])
-> (ContinuationResult
    -> MaybeT (LspM Config) (Maybe ResponseError))
-> MaybeT (LspM Config) [Maybe ResponseError]
forall a b. (a -> b) -> a -> b
$ \case
          ErrorMessages [UserFacingMessage]
errs -> do
            (UserFacingMessage -> MaybeT (LspM Config) ())
-> [UserFacingMessage] -> MaybeT (LspM Config) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ UserFacingMessage -> MaybeT (LspM Config) ()
showUserFacingMessage [UserFacingMessage]
errs
            Maybe ResponseError -> MaybeT (LspM Config) (Maybe ResponseError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ResponseError
forall a. Maybe a
Nothing
          RawEdit WorkspaceEdit
edits -> do
            WorkspaceEdit -> MaybeT (LspM Config) ()
sendEdits WorkspaceEdit
edits
            Maybe ResponseError -> MaybeT (LspM Config) (Maybe ResponseError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ResponseError
forall a. Maybe a
Nothing
          GraftEdit Graft (Either String) ParsedSource
gr -> do
            ClientCapabilities
ccs <- LspM Config ClientCapabilities
-> MaybeT (LspM Config) ClientCapabilities
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LspM Config ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
            TrackedStale Tracked ('Stale s) (Annotated ParsedSource)
pm PositionMap ('Stale s) 'Current
_ <- (IO (Maybe (TrackedStale (Annotated ParsedSource)))
 -> LspM Config (Maybe (TrackedStale (Annotated ParsedSource))))
-> MaybeT IO (TrackedStale (Annotated ParsedSource))
-> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource))
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe (TrackedStale (Annotated ParsedSource)))
-> LspM Config (Maybe (TrackedStale (Annotated ParsedSource)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO (TrackedStale (Annotated ParsedSource))
 -> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource)))
-> MaybeT IO (TrackedStale (Annotated ParsedSource))
-> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ GetAnnotatedParsedSource
-> MaybeT IO (TrackedStale (RuleResult GetAnnotatedParsedSource))
forall a.
(Hashable a, Show a, Show (RuleResult a), Typeable a,
 Typeable (RuleResult a), NFData a, NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale GetAnnotatedParsedSource
GetAnnotatedParsedSource
            case DynFlags
-> ClientCapabilities
-> Uri
-> Annotated ParsedSource
-> Graft (Either String) ParsedSource
-> Either UserFacingMessage WorkspaceEdit
mkWorkspaceEdits (DynFlags -> DynFlags
enableQuasiQuotes DynFlags
le_dflags) ClientCapabilities
ccs (FileContext -> Uri
fc_uri FileContext
le_fileContext) (Tracked ('Stale s) (Annotated ParsedSource)
-> Annotated ParsedSource
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked ('Stale s) (Annotated ParsedSource)
pm) Graft (Either String) ParsedSource
gr of
              Left UserFacingMessage
errs ->
                Maybe ResponseError -> MaybeT (LspM Config) (Maybe ResponseError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ResponseError -> MaybeT (LspM Config) (Maybe ResponseError))
-> Maybe ResponseError
-> MaybeT (LspM Config) (Maybe ResponseError)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Maybe ResponseError
forall a. a -> Maybe a
Just (ResponseError -> Maybe ResponseError)
-> ResponseError -> Maybe ResponseError
forall a b. (a -> b) -> a -> b
$ ResponseError :: ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError
                  { $sel:_code:ResponseError :: ErrorCode
_code    = ErrorCode
InternalError
                  , $sel:_message:ResponseError :: Text
_message = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UserFacingMessage -> String
forall a. Show a => a -> String
show UserFacingMessage
errs
                  , $sel:_xdata:ResponseError :: Maybe Value
_xdata   = Maybe Value
forall a. Maybe a
Nothing
                  }
              Right WorkspaceEdit
edits -> do
                WorkspaceEdit -> MaybeT (LspM Config) ()
sendEdits WorkspaceEdit
edits
                Maybe ResponseError -> MaybeT (LspM Config) (Maybe ResponseError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ResponseError
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Push a 'WorkspaceEdit' to the client.
sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) ()
sendEdits :: WorkspaceEdit -> MaybeT (LspM Config) ()
sendEdits WorkspaceEdit
edits =
  MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit)
-> MaybeT (LspM Config) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit)
 -> MaybeT (LspM Config) ())
-> MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit)
-> MaybeT (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ LspM Config (LspId 'WorkspaceApplyEdit)
-> MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config (LspId 'WorkspaceApplyEdit)
 -> MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit))
-> LspM Config (LspId 'WorkspaceApplyEdit)
-> MaybeT (LspM Config) (LspId 'WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$
    SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspM Config ())
-> LspM Config (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest
      SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit
      (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edits)
      (LspM Config ()
-> Either ResponseError ApplyWorkspaceEditResponseBody
-> LspM Config ()
forall a b. a -> b -> a
const (LspM Config ()
 -> Either ResponseError ApplyWorkspaceEditResponseBody
 -> LspM Config ())
-> LspM Config ()
-> Either ResponseError ApplyWorkspaceEditResponseBody
-> LspM Config ()
forall a b. (a -> b) -> a -> b
$ () -> LspM Config ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())


------------------------------------------------------------------------------
-- | Push a 'UserFacingMessage' to the client.
showUserFacingMessage
    :: UserFacingMessage
    -> MaybeT (LspM Plugin.Config) ()
showUserFacingMessage :: UserFacingMessage -> MaybeT (LspM Config) ()
showUserFacingMessage UserFacingMessage
ufm =
  MaybeT (LspM Config) () -> MaybeT (LspM Config) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (LspM Config) () -> MaybeT (LspM Config) ())
-> MaybeT (LspM Config) () -> MaybeT (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ LspM Config () -> MaybeT (LspM Config) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config () -> MaybeT (LspM Config) ())
-> LspM Config () -> MaybeT (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ ShowMessageParams -> LspM Config ()
forall cfg (m :: * -> *).
MonadLsp cfg m =>
ShowMessageParams -> m ()
showLspMessage (ShowMessageParams -> LspM Config ())
-> ShowMessageParams -> LspM Config ()
forall a b. (a -> b) -> a -> b
$ UserFacingMessage -> ShowMessageParams
mkShowMessageParams UserFacingMessage
ufm


------------------------------------------------------------------------------
-- | Build an 'LspEnv', which contains the majority of things we need to know
-- in a 'Continuation'.
buildEnv
    :: IdeState
    -> PluginId
    -> FileContext
    -> MaybeT (LspM Plugin.Config) LspEnv
buildEnv :: IdeState -> PluginId -> FileContext -> MaybeT (LspM Config) LspEnv
buildEnv IdeState
state PluginId
plId FileContext
fc = do
  Config
cfg <- LspM Config Config -> MaybeT (LspM Config) Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config Config -> MaybeT (LspM Config) Config)
-> LspM Config Config -> MaybeT (LspM Config) Config
forall a b. (a -> b) -> a -> b
$ PluginId -> LspM Config Config
forall (m :: * -> *). MonadLsp Config m => PluginId -> m Config
getTacticConfig PluginId
plId
  NormalizedFilePath
nfp <- Uri -> MaybeT (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Applicative m =>
Uri -> MaybeT m NormalizedFilePath
getNfp (Uri -> MaybeT (LspM Config) NormalizedFilePath)
-> Uri -> MaybeT (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ FileContext -> Uri
fc_uri FileContext
fc
  DynFlags
dflags <- (IO (Maybe DynFlags) -> LspM Config (Maybe DynFlags))
-> MaybeT IO DynFlags -> MaybeT (LspM Config) DynFlags
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe DynFlags) -> LspM Config (Maybe DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO DynFlags -> MaybeT (LspM Config) DynFlags)
-> MaybeT IO DynFlags -> MaybeT (LspM Config) DynFlags
forall a b. (a -> b) -> a -> b
$ IdeState -> NormalizedFilePath -> MaybeT IO DynFlags
getIdeDynflags IdeState
state NormalizedFilePath
nfp
  LspEnv -> MaybeT (LspM Config) LspEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspEnv -> MaybeT (LspM Config) LspEnv)
-> LspEnv -> MaybeT (LspM Config) LspEnv
forall a b. (a -> b) -> a -> b
$ LspEnv :: IdeState -> PluginId -> DynFlags -> Config -> FileContext -> LspEnv
LspEnv
    { le_ideState :: IdeState
le_ideState = IdeState
state
    , le_pluginId :: PluginId
le_pluginId = PluginId
plId
    , le_dflags :: DynFlags
le_dflags   = DynFlags
dflags
    , le_config :: Config
le_config   = Config
cfg
    , le_fileContext :: FileContext
le_fileContext = FileContext
fc
    }


------------------------------------------------------------------------------
-- | Lift a 'Continuation' into an LSP CodeAction.
codeActionProvider
    :: forall target sort b
     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)
    => sort
    -> ( LspEnv
     -> TargetArgs target
     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]
       )
    -> PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: sort
-> (LspEnv
    -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider sort
sort LspEnv -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)]
k IdeState
state PluginId
plId
                   (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do
  Either ResponseError (List (Command |? CodeAction))
-> MaybeT
     (LspM Config) (Either ResponseError (List (Command |? CodeAction)))
-> LspM
     Config (Either ResponseError (List (Command |? CodeAction)))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List []) (MaybeT
   (LspM Config) (Either ResponseError (List (Command |? CodeAction)))
 -> LspM
      Config (Either ResponseError (List (Command |? CodeAction))))
-> MaybeT
     (LspM Config) (Either ResponseError (List (Command |? CodeAction)))
-> LspM
     Config (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ do
    let fc :: FileContext
fc = FileContext :: Uri -> Maybe (Tracked 'Current Range) -> FileContext
FileContext
                { fc_uri :: Uri
fc_uri   = Uri
uri
                , fc_range :: Maybe (Tracked 'Current Range)
fc_range = Tracked 'Current Range -> Maybe (Tracked 'Current Range)
forall a. a -> Maybe a
Just (Tracked 'Current Range -> Maybe (Tracked 'Current Range))
-> Tracked 'Current Range -> Maybe (Tracked 'Current Range)
forall a b. (a -> b) -> a -> b
$ Range -> Tracked 'Current Range
forall age. age -> Tracked 'Current age
unsafeMkCurrent Range
range
                }
    LspEnv
env <- IdeState -> PluginId -> FileContext -> MaybeT (LspM Config) LspEnv
buildEnv IdeState
state PluginId
plId FileContext
fc
    TargetArgs target
args <- LspEnv -> MaybeT (LspM Config) (TargetArgs target)
forall t.
IsTarget t =>
LspEnv -> MaybeT (LspM Config) (TargetArgs t)
fetchTargetArgs @target LspEnv
env
    [(Metadata, b)]
actions <- LspEnv -> TargetArgs target -> MaybeT (LspM Config) [(Metadata, b)]
k LspEnv
env TargetArgs target
args
    Either ResponseError (List (Command |? CodeAction))
-> MaybeT
     (LspM Config) (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either ResponseError (List (Command |? CodeAction))
 -> MaybeT
      (LspM Config)
      (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> MaybeT
     (LspM Config) (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right
      (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List
      ([Command |? CodeAction] -> List (Command |? CodeAction))
-> [Command |? CodeAction] -> List (Command |? CodeAction)
forall a b. (a -> b) -> a -> b
$ ((Metadata, b) -> Command |? CodeAction)
-> [(Metadata, b)] -> [Command |? CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR (CodeAction -> Command |? CodeAction)
-> ((Metadata, b) -> CodeAction)
-> (Metadata, b)
-> Command |? CodeAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Metadata -> b -> CodeAction) -> (Metadata, b) -> CodeAction
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (PluginId -> FileContext -> sort -> Metadata -> b -> CodeAction
forall b sort.
(ToJSON b, IsContinuationSort sort) =>
PluginId -> FileContext -> sort -> Metadata -> b -> CodeAction
makeCodeAction PluginId
plId FileContext
fc sort
sort)) [(Metadata, b)]
actions


------------------------------------------------------------------------------
-- | Lift a 'Continuation' into an LSP CodeLens.
codeLensProvider
    :: forall target sort b
     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)
    => sort
    -> ( LspEnv
     -> TargetArgs target
     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]
      )
    -> PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider :: sort
-> (LspEnv
    -> TargetArgs target
    -> MaybeT (LspM Config) [(Range, Metadata, b)])
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLensProvider sort
sort LspEnv
-> TargetArgs target -> MaybeT (LspM Config) [(Range, Metadata, b)]
k IdeState
state PluginId
plId
                 (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do
      Either ResponseError (List CodeLens)
-> MaybeT (LspM Config) (Either ResponseError (List CodeLens))
-> LspM Config (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List []) (MaybeT (LspM Config) (Either ResponseError (List CodeLens))
 -> LspM Config (Either ResponseError (List CodeLens)))
-> MaybeT (LspM Config) (Either ResponseError (List CodeLens))
-> LspM Config (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ do
        let fc :: FileContext
fc = FileContext :: Uri -> Maybe (Tracked 'Current Range) -> FileContext
FileContext
                   { fc_uri :: Uri
fc_uri   = Uri
uri
                   , fc_range :: Maybe (Tracked 'Current Range)
fc_range = Maybe (Tracked 'Current Range)
forall a. Maybe a
Nothing
                   }
        LspEnv
env <- IdeState -> PluginId -> FileContext -> MaybeT (LspM Config) LspEnv
buildEnv IdeState
state PluginId
plId FileContext
fc
        TargetArgs target
args <- LspEnv -> MaybeT (LspM Config) (TargetArgs target)
forall t.
IsTarget t =>
LspEnv -> MaybeT (LspM Config) (TargetArgs t)
fetchTargetArgs @target LspEnv
env
        [(Range, Metadata, b)]
actions <- LspEnv
-> TargetArgs target -> MaybeT (LspM Config) [(Range, Metadata, b)]
k LspEnv
env TargetArgs target
args
        Either ResponseError (List CodeLens)
-> MaybeT (LspM Config) (Either ResponseError (List CodeLens))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Either ResponseError (List CodeLens)
 -> MaybeT (LspM Config) (Either ResponseError (List CodeLens)))
-> Either ResponseError (List CodeLens)
-> MaybeT (LspM Config) (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right
          (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List
          ([CodeLens] -> List CodeLens) -> [CodeLens] -> List CodeLens
forall a b. (a -> b) -> a -> b
$ ((Range, Metadata, b) -> CodeLens)
-> [(Range, Metadata, b)] -> [CodeLens]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Range -> Metadata -> b -> CodeLens)
-> (Range, Metadata, b) -> CodeLens
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 ((Range -> Metadata -> b -> CodeLens)
 -> (Range, Metadata, b) -> CodeLens)
-> (Range -> Metadata -> b -> CodeLens)
-> (Range, Metadata, b)
-> CodeLens
forall a b. (a -> b) -> a -> b
$ PluginId
-> sort -> FileContext -> Range -> Metadata -> b -> CodeLens
forall b sort.
(ToJSON b, IsContinuationSort sort) =>
PluginId
-> sort -> FileContext -> Range -> Metadata -> b -> CodeLens
makeCodeLens PluginId
plId sort
sort FileContext
fc) [(Range, Metadata, b)]
actions


------------------------------------------------------------------------------
-- | Build a 'LSP.CodeAction'.
makeCodeAction
    :: (A.ToJSON b, IsContinuationSort sort)
    => PluginId
    -> FileContext
    -> sort
    -> Metadata
    -> b
    -> LSP.CodeAction
makeCodeAction :: PluginId -> FileContext -> sort -> Metadata -> b -> CodeAction
makeCodeAction PluginId
plId FileContext
fc sort
sort (Metadata Text
title CodeActionKind
kind Bool
preferred) b
b =
  let cmd_id :: CommandId
cmd_id = sort -> CommandId
forall a. IsContinuationSort a => a -> CommandId
toCommandId sort
sort
      cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
cmd_id Text
title (Maybe [Value] -> Command) -> Maybe [Value] -> Command
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [(FileContext, b) -> Value
forall a. ToJSON a => a -> Value
A.toJSON (FileContext
fc, b
b)]
   in CodeAction :: Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction
        { $sel:_title:CodeAction :: Text
_title       = Text
title
        , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind        = CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
kind
        , $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = Maybe (List Diagnostic)
forall a. Maybe a
Nothing
        , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
preferred
        , $sel:_disabled:CodeAction :: Maybe Reason
_disabled    = Maybe Reason
forall a. Maybe a
Nothing
        , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit        = Maybe WorkspaceEdit
forall a. Maybe a
Nothing
        , $sel:_command:CodeAction :: Maybe Command
_command     = Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd
        , $sel:_xdata:CodeAction :: Maybe Value
_xdata       = Maybe Value
forall a. Maybe a
Nothing
        }


------------------------------------------------------------------------------
-- | Build a 'LSP.CodeLens'.
makeCodeLens
    :: (A.ToJSON b, IsContinuationSort sort)
    => PluginId
    -> sort
    -> FileContext
    -> Range
    -> Metadata
    -> b
    -> LSP.CodeLens
makeCodeLens :: PluginId
-> sort -> FileContext -> Range -> Metadata -> b -> CodeLens
makeCodeLens PluginId
plId sort
sort FileContext
fc Range
range (Metadata Text
title CodeActionKind
_ Bool
_) b
b =
  let fc' :: FileContext
fc' = FileContext
fc { fc_range :: Maybe (Tracked 'Current Range)
fc_range = Tracked 'Current Range -> Maybe (Tracked 'Current Range)
forall a. a -> Maybe a
Just (Tracked 'Current Range -> Maybe (Tracked 'Current Range))
-> Tracked 'Current Range -> Maybe (Tracked 'Current Range)
forall a b. (a -> b) -> a -> b
$ Range -> Tracked 'Current Range
forall age. age -> Tracked 'Current age
unsafeMkCurrent Range
range }
      cmd_id :: CommandId
cmd_id = sort -> CommandId
forall a. IsContinuationSort a => a -> CommandId
toCommandId sort
sort
      cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
cmd_id Text
title (Maybe [Value] -> Command) -> Maybe [Value] -> Command
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [(FileContext, b) -> Value
forall a. ToJSON a => a -> Value
A.toJSON (FileContext
fc', b
b)]
   in CodeLens :: Range -> Maybe Command -> Maybe Value -> CodeLens
LSP.CodeLens
        { $sel:_range:CodeLens :: Range
_range = Range
range
        , $sel:_command:CodeLens :: Maybe Command
_command = Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd
        , $sel:_xdata:CodeLens :: Maybe Value
_xdata = Maybe Value
forall a. Maybe a
Nothing
        }