{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Unison.LSP.Types where

import Colog.Core hiding (Lens')
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Cofree qualified as Cofree
import Control.Lens hiding (List, (:<))
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson qualified as Aeson
import Data.IntervalMap.Lazy (IntervalMap)
import Data.IntervalMap.Lazy qualified as IM
import Data.Map qualified as Map
import Ki qualified
import Language.LSP.Logging qualified as LSP
import Language.LSP.Protocol.Lens
import Language.LSP.Protocol.Message (MessageDirection (..), MessageKind (..), Method, TMessage, TNotificationMessage, fromServerNot)
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.Server qualified as LSP
import Language.LSP.VFS
import Unison.Codebase
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Debug qualified as Debug
import Unison.LSP.Orphans ()
import Unison.LabeledDependency (LabeledDependency)
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.Names (Names)
import Unison.Parser.Ann
import Unison.Prelude
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
import Unison.Referent (Referent)
import Unison.Result (Note)
import Unison.Server.Backend qualified as Backend
import Unison.Server.NameSearch (NameSearch)
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol
import Unison.Syntax.Lexer.Unison qualified as Lexer
import Unison.Type (Type)
import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Summary (FileSummary (..))
import UnliftIO

-- | A custom LSP monad wrapper so we can provide our own environment.
newtype Lsp a = Lsp {forall a. Lsp a -> ReaderT Env (LspM Config) a
runLspM :: ReaderT Env (LspM Config) a}
  deriving newtype ((forall a b. (a -> b) -> Lsp a -> Lsp b)
-> (forall a b. a -> Lsp b -> Lsp a) -> Functor Lsp
forall a b. a -> Lsp b -> Lsp a
forall a b. (a -> b) -> Lsp a -> Lsp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Lsp a -> Lsp b
fmap :: forall a b. (a -> b) -> Lsp a -> Lsp b
$c<$ :: forall a b. a -> Lsp b -> Lsp a
<$ :: forall a b. a -> Lsp b -> Lsp a
Functor, Functor Lsp
Functor Lsp =>
(forall a. a -> Lsp a)
-> (forall a b. Lsp (a -> b) -> Lsp a -> Lsp b)
-> (forall a b c. (a -> b -> c) -> Lsp a -> Lsp b -> Lsp c)
-> (forall a b. Lsp a -> Lsp b -> Lsp b)
-> (forall a b. Lsp a -> Lsp b -> Lsp a)
-> Applicative Lsp
forall a. a -> Lsp a
forall a b. Lsp a -> Lsp b -> Lsp a
forall a b. Lsp a -> Lsp b -> Lsp b
forall a b. Lsp (a -> b) -> Lsp a -> Lsp b
forall a b c. (a -> b -> c) -> Lsp a -> Lsp b -> Lsp c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Lsp a
pure :: forall a. a -> Lsp a
$c<*> :: forall a b. Lsp (a -> b) -> Lsp a -> Lsp b
<*> :: forall a b. Lsp (a -> b) -> Lsp a -> Lsp b
$cliftA2 :: forall a b c. (a -> b -> c) -> Lsp a -> Lsp b -> Lsp c
liftA2 :: forall a b c. (a -> b -> c) -> Lsp a -> Lsp b -> Lsp c
$c*> :: forall a b. Lsp a -> Lsp b -> Lsp b
*> :: forall a b. Lsp a -> Lsp b -> Lsp b
$c<* :: forall a b. Lsp a -> Lsp b -> Lsp a
<* :: forall a b. Lsp a -> Lsp b -> Lsp a
Applicative, Applicative Lsp
Applicative Lsp =>
(forall a b. Lsp a -> (a -> Lsp b) -> Lsp b)
-> (forall a b. Lsp a -> Lsp b -> Lsp b)
-> (forall a. a -> Lsp a)
-> Monad Lsp
forall a. a -> Lsp a
forall a b. Lsp a -> Lsp b -> Lsp b
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
>>= :: forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
$c>> :: forall a b. Lsp a -> Lsp b -> Lsp b
>> :: forall a b. Lsp a -> Lsp b -> Lsp b
$creturn :: forall a. a -> Lsp a
return :: forall a. a -> Lsp a
Monad, Monad Lsp
Monad Lsp => (forall a. IO a -> Lsp a) -> MonadIO Lsp
forall a. IO a -> Lsp a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Lsp a
liftIO :: forall a. IO a -> Lsp a
MonadIO, MonadIO Lsp
MonadIO Lsp =>
(forall b. ((forall a. Lsp a -> IO a) -> IO b) -> Lsp b)
-> MonadUnliftIO Lsp
forall b. ((forall a. Lsp a -> IO a) -> IO b) -> Lsp b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. Lsp a -> IO a) -> IO b) -> Lsp b
withRunInIO :: forall b. ((forall a. Lsp a -> IO a) -> IO b) -> Lsp b
MonadUnliftIO, MonadReader Env, MonadLsp Config)

-- | Log an info message to the client's LSP log.
logInfo :: Text -> Lsp ()
logInfo :: Text -> Lsp ()
logInfo Text
msg = do
  let LogAction WithSeverity Text -> Lsp ()
log = LogAction Lsp (WithSeverity Text)
forall c (m :: * -> *).
MonadLsp c m =>
LogAction m (WithSeverity Text)
LSP.defaultClientLogger
  WithSeverity Text -> Lsp ()
log (Text -> Severity -> WithSeverity Text
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity Text
msg Severity
Info)

-- | Log an error message to the client's LSP log, this will be shown to the user in most LSP
-- implementations.
logError :: Text -> Lsp ()
logError :: Text -> Lsp ()
logError Text
msg = do
  let LogAction WithSeverity Text -> Lsp ()
log = LogAction Lsp (WithSeverity Text)
forall c (m :: * -> *).
MonadLsp c m =>
LogAction m (WithSeverity Text)
LSP.defaultClientLogger
  WithSeverity Text -> Lsp ()
log (Text -> Severity -> WithSeverity Text
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity Text
msg Severity
Error)

-- | Environment for the Lsp monad.
data Env = Env
  { -- contains handlers for talking to the client.
    Env -> LanguageContextEnv Config
lspContext :: LanguageContextEnv Config,
    Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann,
    Env -> IO Names
currentNamesCache :: IO Names,
    Env -> IO PrettyPrintEnvDecl
ppedCache :: IO PrettyPrintEnvDecl,
    Env -> IO (NameSearch Transaction)
nameSearchCache :: IO (NameSearch Sqlite.Transaction),
    Env -> IO ProjectPath
currentProjectPathCache :: IO PP.ProjectPath,
    Env -> MVar VFS
vfsVar :: MVar VFS,
    Env -> Runtime Symbol
runtime :: Runtime Symbol,
    -- The information we have for each file.
    -- The MVar is filled when analysis finishes, and is emptied whenever
    -- the file has changed (until it's checked again)
    Env -> TVar (Map Uri (TMVar FileAnalysis))
checkedFilesVar :: TVar (Map Uri (TMVar FileAnalysis)),
    Env -> TVar (Set Uri)
dirtyFilesVar :: TVar (Set Uri),
    -- A map  of request IDs to an action which kills that request.
    Env -> TVar (Map (Int32 |? Text) (IO ()))
cancellationMapVar :: TVar (Map (Int32 |? Text) (IO ())),
    -- A lazily computed map of all valid completion suffixes from the current path.
    Env -> TMVar CompletionTree
completionsVar :: TMVar CompletionTree,
    Env -> Scope
scope :: Ki.Scope
  }

-- | A suffix tree over path segments of name completions.
-- see 'namesToCompletionTree' for more on how this is built and the invariants it should have.
newtype CompletionTree = CompletionTree
  { CompletionTree
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
unCompletionTree :: Cofree (Map NameSegment) (Set (Name, LabeledDependency))
  }
  deriving (Int -> CompletionTree -> ShowS
[CompletionTree] -> ShowS
CompletionTree -> String
(Int -> CompletionTree -> ShowS)
-> (CompletionTree -> String)
-> ([CompletionTree] -> ShowS)
-> Show CompletionTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompletionTree -> ShowS
showsPrec :: Int -> CompletionTree -> ShowS
$cshow :: CompletionTree -> String
show :: CompletionTree -> String
$cshowList :: [CompletionTree] -> ShowS
showList :: [CompletionTree] -> ShowS
Show)

instance Semigroup CompletionTree where
  CompletionTree (Set (Name, LabeledDependency)
a Cofree.:< Map
  NameSegment
  (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
subtreeA) <> :: CompletionTree -> CompletionTree -> CompletionTree
<> CompletionTree (Set (Name, LabeledDependency)
b Cofree.:< Map
  NameSegment
  (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
subtreeB) =
    Cofree (Map NameSegment) (Set (Name, LabeledDependency))
-> CompletionTree
CompletionTree (Set (Name, LabeledDependency)
a Set (Name, LabeledDependency)
-> Set (Name, LabeledDependency) -> Set (Name, LabeledDependency)
forall a. Semigroup a => a -> a -> a
<> Set (Name, LabeledDependency)
b Set (Name, LabeledDependency)
-> Map
     NameSegment
     (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
Cofree.:< (Cofree (Map NameSegment) (Set (Name, LabeledDependency))
 -> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
 -> Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> Map
     NameSegment
     (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> Map
     NameSegment
     (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> Map
     NameSegment
     (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\Cofree (Map NameSegment) (Set (Name, LabeledDependency))
a Cofree (Map NameSegment) (Set (Name, LabeledDependency))
b -> CompletionTree
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
unCompletionTree (CompletionTree
 -> Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> CompletionTree
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
forall a b. (a -> b) -> a -> b
$ Cofree (Map NameSegment) (Set (Name, LabeledDependency))
-> CompletionTree
CompletionTree Cofree (Map NameSegment) (Set (Name, LabeledDependency))
a CompletionTree -> CompletionTree -> CompletionTree
forall a. Semigroup a => a -> a -> a
<> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
-> CompletionTree
CompletionTree Cofree (Map NameSegment) (Set (Name, LabeledDependency))
b) Map
  NameSegment
  (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
subtreeA Map
  NameSegment
  (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
subtreeB)

instance Monoid CompletionTree where
  mempty :: CompletionTree
mempty = Cofree (Map NameSegment) (Set (Name, LabeledDependency))
-> CompletionTree
CompletionTree (Cofree (Map NameSegment) (Set (Name, LabeledDependency))
 -> CompletionTree)
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
-> CompletionTree
forall a b. (a -> b) -> a -> b
$ Set (Name, LabeledDependency)
forall a. Monoid a => a
mempty Set (Name, LabeledDependency)
-> Map
     NameSegment
     (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
-> Cofree (Map NameSegment) (Set (Name, LabeledDependency))
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
Cofree.:< Map
  NameSegment
  (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
forall a. Monoid a => a
mempty

-- | A monotonically increasing file version tracked by the lsp client.
type FileVersion = Int32

type LexedSource = (Text, [Lexer.Token Lexer.Lexeme])

data TypeSignatureHint = TypeSignatureHint
  { TypeSignatureHint -> Name
name :: Name,
    TypeSignatureHint -> Referent
referent :: Referent,
    TypeSignatureHint -> Range
bindingLocation :: Range,
    TypeSignatureHint -> Type Symbol Ann
signature :: Type Symbol Ann
  }
  deriving (Int -> TypeSignatureHint -> ShowS
[TypeSignatureHint] -> ShowS
TypeSignatureHint -> String
(Int -> TypeSignatureHint -> ShowS)
-> (TypeSignatureHint -> String)
-> ([TypeSignatureHint] -> ShowS)
-> Show TypeSignatureHint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSignatureHint -> ShowS
showsPrec :: Int -> TypeSignatureHint -> ShowS
$cshow :: TypeSignatureHint -> String
show :: TypeSignatureHint -> String
$cshowList :: [TypeSignatureHint] -> ShowS
showList :: [TypeSignatureHint] -> ShowS
Show)

data FileAnalysis = FileAnalysis
  { FileAnalysis -> Uri
fileUri :: Uri,
    FileAnalysis -> Int32
fileVersion :: FileVersion,
    FileAnalysis -> LexedSource
lexedSource :: LexedSource,
    FileAnalysis -> IntervalMap Position Lexeme
tokenMap :: IM.IntervalMap Position Lexer.Lexeme,
    FileAnalysis -> Maybe (UnisonFile Symbol Ann)
parsedFile :: Maybe (UF.UnisonFile Symbol Ann),
    FileAnalysis -> Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile :: Maybe (UF.TypecheckedUnisonFile Symbol Ann),
    FileAnalysis -> Seq (Note Symbol Ann)
notes :: Seq (Note Symbol Ann),
    FileAnalysis -> IntervalMap Position [Diagnostic]
diagnostics :: IntervalMap Position [Diagnostic],
    FileAnalysis -> IntervalMap Position [CodeAction]
codeActions :: IntervalMap Position [CodeAction],
    FileAnalysis -> Map Symbol TypeSignatureHint
typeSignatureHints :: Map Symbol TypeSignatureHint,
    FileAnalysis -> Maybe FileSummary
fileSummary :: Maybe FileSummary
  }
  deriving stock (Int -> FileAnalysis -> ShowS
[FileAnalysis] -> ShowS
FileAnalysis -> String
(Int -> FileAnalysis -> ShowS)
-> (FileAnalysis -> String)
-> ([FileAnalysis] -> ShowS)
-> Show FileAnalysis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileAnalysis -> ShowS
showsPrec :: Int -> FileAnalysis -> ShowS
$cshow :: FileAnalysis -> String
show :: FileAnalysis -> String
$cshowList :: [FileAnalysis] -> ShowS
showList :: [FileAnalysis] -> ShowS
Show)

getCurrentProjectPath :: Lsp PP.ProjectPath
getCurrentProjectPath :: Lsp ProjectPath
getCurrentProjectPath = (Env -> IO ProjectPath) -> Lsp (IO ProjectPath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> IO ProjectPath
currentProjectPathCache Lsp (IO ProjectPath)
-> (IO ProjectPath -> Lsp ProjectPath) -> Lsp ProjectPath
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ProjectPath -> Lsp ProjectPath
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

getCodebaseCompletions :: Lsp CompletionTree
getCodebaseCompletions :: Lsp CompletionTree
getCodebaseCompletions = (Env -> TMVar CompletionTree) -> Lsp (TMVar CompletionTree)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TMVar CompletionTree
completionsVar Lsp (TMVar CompletionTree)
-> (TMVar CompletionTree -> Lsp CompletionTree)
-> Lsp CompletionTree
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM CompletionTree -> Lsp CompletionTree
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CompletionTree -> Lsp CompletionTree)
-> (TMVar CompletionTree -> STM CompletionTree)
-> TMVar CompletionTree
-> Lsp CompletionTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar CompletionTree -> STM CompletionTree
forall a. TMVar a -> STM a
readTMVar

currentPPED :: Lsp PrettyPrintEnvDecl
currentPPED :: Lsp PrettyPrintEnvDecl
currentPPED = (Env -> IO PrettyPrintEnvDecl) -> Lsp (IO PrettyPrintEnvDecl)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> IO PrettyPrintEnvDecl
ppedCache Lsp (IO PrettyPrintEnvDecl)
-> (IO PrettyPrintEnvDecl -> Lsp PrettyPrintEnvDecl)
-> Lsp PrettyPrintEnvDecl
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO PrettyPrintEnvDecl -> Lsp PrettyPrintEnvDecl
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

getNameSearch :: Lsp (NameSearch Sqlite.Transaction)
getNameSearch :: Lsp (NameSearch Transaction)
getNameSearch = (Env -> IO (NameSearch Transaction))
-> Lsp (IO (NameSearch Transaction))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> IO (NameSearch Transaction)
nameSearchCache Lsp (IO (NameSearch Transaction))
-> (IO (NameSearch Transaction) -> Lsp (NameSearch Transaction))
-> Lsp (NameSearch Transaction)
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (NameSearch Transaction) -> Lsp (NameSearch Transaction)
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

getCurrentNames :: Lsp Names
getCurrentNames :: Lsp Names
getCurrentNames = (Env -> IO Names) -> Lsp (IO Names)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> IO Names
currentNamesCache Lsp (IO Names) -> (IO Names -> Lsp Names) -> Lsp Names
forall a b. Lsp a -> (a -> Lsp b) -> Lsp b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Names -> Lsp Names
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

data Config = Config
  { Config -> Int
formattingWidth :: Int,
    -- 'Nothing' will load ALL available completions, which is slower, but may provide a better
    -- solution for some users.
    --
    -- 'Just n' will only fetch the first 'n' completions and will prompt the client to ask for
    -- more completions after more typing.
    Config -> Maybe Int
maxCompletions :: Maybe Int
  }
  deriving stock (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

instance Aeson.FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON = String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Config" \Object
obj -> do
    Maybe Int
maxCompletions <- Object
obj Object -> Key -> Parser (Maybe (Maybe Int))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:! Key
"maxCompletions" Parser (Maybe (Maybe Int)) -> Maybe Int -> Parser (Maybe Int)
forall a. Parser (Maybe a) -> a -> Parser a
Aeson..!= Config -> Maybe Int
maxCompletions Config
defaultLSPConfig
    DebugFlag -> String -> String -> Parser ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP String
"Config" (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"maxCompletions: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
maxCompletions
    Int
formattingWidth <- Object
obj Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"formattingWidth" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
Aeson..!= Config -> Int
formattingWidth Config
defaultLSPConfig
    pure Config {Int
Maybe Int
$sel:formattingWidth:Config :: Int
$sel:maxCompletions:Config :: Maybe Int
maxCompletions :: Maybe Int
formattingWidth :: Int
..}

instance Aeson.ToJSON Config where
  toJSON :: Config -> Value
toJSON (Config Int
formattingWidth Maybe Int
maxCompletions) =
    [Pair] -> Value
Aeson.object
      [ Key
"formattingWidth" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Int
formattingWidth,
        Key
"maxCompletions" Key -> Maybe Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Maybe Int
maxCompletions
      ]

defaultLSPConfig :: Config
defaultLSPConfig :: Config
defaultLSPConfig = Config {Int
Maybe Int
$sel:formattingWidth:Config :: Int
$sel:maxCompletions:Config :: Maybe Int
formattingWidth :: Int
maxCompletions :: Maybe Int
..}
  where
    formattingWidth :: Int
formattingWidth = Int
80
    maxCompletions :: Maybe Int
maxCompletions = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
100

-- | Lift a backend computation into the Lsp monad.
lspBackend :: Backend.Backend IO a -> Lsp (Either Backend.BackendError a)
lspBackend :: forall a. Backend IO a -> Lsp (Either BackendError a)
lspBackend = IO (Either BackendError a) -> Lsp (Either BackendError a)
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either BackendError a) -> Lsp (Either BackendError a))
-> (Backend IO a -> IO (Either BackendError a))
-> Backend IO a
-> Lsp (Either BackendError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT BackendError IO a -> IO (Either BackendError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT BackendError IO a -> IO (Either BackendError a))
-> (Backend IO a -> ExceptT BackendError IO a)
-> Backend IO a
-> IO (Either BackendError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT BackendEnv (ExceptT BackendError IO) a
 -> BackendEnv -> ExceptT BackendError IO a)
-> BackendEnv
-> ReaderT BackendEnv (ExceptT BackendError IO) a
-> ExceptT BackendError IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT BackendEnv (ExceptT BackendError IO) a
-> BackendEnv -> ExceptT BackendError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bool -> BackendEnv
Backend.BackendEnv Bool
False) (ReaderT BackendEnv (ExceptT BackendError IO) a
 -> ExceptT BackendError IO a)
-> (Backend IO a -> ReaderT BackendEnv (ExceptT BackendError IO) a)
-> Backend IO a
-> ExceptT BackendError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Backend IO a -> ReaderT BackendEnv (ExceptT BackendError IO) a
forall (m :: * -> *) a.
Backend m a -> ReaderT BackendEnv (ExceptT BackendError m) a
Backend.runBackend

sendNotification :: forall (m :: Method 'ServerToClient 'Notification). (TMessage m ~ TNotificationMessage m) => TNotificationMessage m -> Lsp ()
sendNotification :: forall (m :: Method 'ServerToClient 'Notification).
(TMessage m ~ TNotificationMessage m) =>
TNotificationMessage m -> Lsp ()
sendNotification TNotificationMessage m
notif = do
  FromServerMessage -> IO ()
sendServerMessage <- (Env -> FromServerMessage -> IO ())
-> Lsp (FromServerMessage -> IO ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (LanguageContextEnv Config -> FromServerMessage -> IO ()
forall config.
LanguageContextEnv config -> FromServerMessage -> IO ()
resSendMessage (LanguageContextEnv Config -> FromServerMessage -> IO ())
-> (Env -> LanguageContextEnv Config)
-> Env
-> FromServerMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> LanguageContextEnv Config
lspContext)
  IO () -> Lsp ()
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Lsp ()) -> IO () -> Lsp ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
sendServerMessage (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ TNotificationMessage m -> FromServerMessage
forall (m :: Method 'ServerToClient 'Notification).
(TMessage m ~ TNotificationMessage m) =>
TNotificationMessage m -> FromServerMessage
fromServerNot TNotificationMessage m
notif -- (notif ^. method) notif

data RangedCodeAction = RangedCodeAction
  { -- All the ranges the code action applies
    RangedCodeAction -> [Range]
_codeActionRanges :: [Range],
    RangedCodeAction -> CodeAction
_codeAction :: CodeAction
  }
  deriving stock (RangedCodeAction -> RangedCodeAction -> Bool
(RangedCodeAction -> RangedCodeAction -> Bool)
-> (RangedCodeAction -> RangedCodeAction -> Bool)
-> Eq RangedCodeAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RangedCodeAction -> RangedCodeAction -> Bool
== :: RangedCodeAction -> RangedCodeAction -> Bool
$c/= :: RangedCodeAction -> RangedCodeAction -> Bool
/= :: RangedCodeAction -> RangedCodeAction -> Bool
Eq, Int -> RangedCodeAction -> ShowS
[RangedCodeAction] -> ShowS
RangedCodeAction -> String
(Int -> RangedCodeAction -> ShowS)
-> (RangedCodeAction -> String)
-> ([RangedCodeAction] -> ShowS)
-> Show RangedCodeAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RangedCodeAction -> ShowS
showsPrec :: Int -> RangedCodeAction -> ShowS
$cshow :: RangedCodeAction -> String
show :: RangedCodeAction -> String
$cshowList :: [RangedCodeAction] -> ShowS
showList :: [RangedCodeAction] -> ShowS
Show)

instance HasCodeAction RangedCodeAction CodeAction where
  codeAction :: Lens' RangedCodeAction CodeAction
codeAction = (RangedCodeAction -> CodeAction)
-> (RangedCodeAction -> CodeAction -> RangedCodeAction)
-> Lens' RangedCodeAction CodeAction
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\RangedCodeAction {CodeAction
$sel:_codeAction:RangedCodeAction :: RangedCodeAction -> CodeAction
_codeAction :: CodeAction
_codeAction} -> CodeAction
_codeAction) (\RangedCodeAction
rca CodeAction
ca -> RangedCodeAction {$sel:_codeActionRanges:RangedCodeAction :: [Range]
_codeActionRanges = RangedCodeAction -> [Range]
_codeActionRanges RangedCodeAction
rca, $sel:_codeAction:RangedCodeAction :: CodeAction
_codeAction = CodeAction
ca})

rangedCodeAction :: Text -> [Diagnostic] -> [Range] -> RangedCodeAction
rangedCodeAction :: Text -> [Diagnostic] -> [Range] -> RangedCodeAction
rangedCodeAction Text
title [Diagnostic]
diags [Range]
ranges =
  [Range] -> CodeAction -> RangedCodeAction
RangedCodeAction [Range]
ranges (CodeAction -> RangedCodeAction) -> CodeAction -> RangedCodeAction
forall a b. (a -> b) -> a -> b
$
    CodeAction
      { $sel:_title:CodeAction :: Text
_title = Text
title,
        $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = Maybe CodeActionKind
forall a. Maybe a
Nothing,
        $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = [Diagnostic] -> Maybe [Diagnostic]
forall a. a -> Maybe a
Just [Diagnostic]
diags,
        $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = Maybe Bool
forall a. Maybe a
Nothing,
        $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
_disabled = Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing,
        $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = Maybe WorkspaceEdit
forall a. Maybe a
Nothing,
        $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing,
        $sel:_data_:CodeAction :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
      }

-- | Provided ranges must not intersect.
includeEdits :: Uri -> Text -> [Range] -> RangedCodeAction -> RangedCodeAction
includeEdits :: Uri -> Text -> [Range] -> RangedCodeAction -> RangedCodeAction
includeEdits Uri
uri Text
replacement [Range]
ranges RangedCodeAction
rca =
  let edits :: [TextEdit]
edits = do
        Range
r <- [Range]
ranges
        pure $ Range -> Text -> TextEdit
TextEdit Range
r Text
replacement
      workspaceEdit :: WorkspaceEdit
workspaceEdit =
        WorkspaceEdit
          { $sel:_changes:WorkspaceEdit :: Maybe (Map Uri [TextEdit])
_changes = Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
Map.singleton Uri
uri [TextEdit]
edits,
            $sel:_documentChanges:WorkspaceEdit :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges = Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing,
            $sel:_changeAnnotations:WorkspaceEdit :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changeAnnotations = Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
          }
   in RangedCodeAction
rca RangedCodeAction
-> (RangedCodeAction -> RangedCodeAction) -> RangedCodeAction
forall a b. a -> (a -> b) -> b
& (CodeAction -> Identity CodeAction)
-> RangedCodeAction -> Identity RangedCodeAction
forall s a. HasCodeAction s a => Lens' s a
Lens' RangedCodeAction CodeAction
codeAction ((CodeAction -> Identity CodeAction)
 -> RangedCodeAction -> Identity RangedCodeAction)
-> ((Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
    -> CodeAction -> Identity CodeAction)
-> (Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
-> RangedCodeAction
-> Identity RangedCodeAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
-> CodeAction -> Identity CodeAction
forall s a. HasEdit s a => Lens' s a
Lens' CodeAction (Maybe WorkspaceEdit)
edit ((Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
 -> RangedCodeAction -> Identity RangedCodeAction)
-> WorkspaceEdit -> RangedCodeAction -> RangedCodeAction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ WorkspaceEdit
workspaceEdit

getConfig :: Lsp Config
getConfig :: Lsp Config
getConfig = Lsp Config
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig

setConfig :: Config -> Lsp ()
setConfig :: Config -> Lsp ()
setConfig = Config -> Lsp ()
forall config (m :: * -> *). MonadLsp config m => config -> m ()
LSP.setConfig