{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.LSP.Handlers where
import Data.Void (Void)
import Dhall.Core
( Expr (Embed, Note)
, Import (..)
, ImportHashed (..)
, ImportType (..)
, headers
, pretty
)
import Dhall.Import (localToPath)
import Dhall.Parser (Src (..))
import Dhall.LSP.Backend.Completion
( Completion (..)
, buildCompletionContext
, completeEnvironmentImport
, completeFromContext
, completeLocalImport
, completeProjections
, completionQueryAt
)
import Dhall.LSP.Backend.Dhall
( FileIdentifier
, fileIdentifierFromFilePath
, fileIdentifierFromURI
, invalidate
, load
, parse
, parseWithHeader
, typecheck
)
import Dhall.LSP.Backend.Diagnostics
( Diagnosis (..)
, Range (..)
, diagnose
, embedsWithRanges
, explain
, rangeFromDhall
)
import Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader)
import Dhall.LSP.Backend.Freezing
( computeSemanticHash
, getAllImportsWithHashPositions
, getImportHashPosition
, stripHash
)
import Dhall.LSP.Backend.Linting (Suggestion (..), lint, suggest)
import Dhall.LSP.Backend.Parsing (binderExprFromText)
import Dhall.LSP.Backend.Typing (annotateLet, exprAt, typeAt)
import Dhall.LSP.State
import Control.Applicative ((<|>))
import Control.Concurrent.MVar
import Control.Lens (assign, modifying, use, uses, (^.))
import Control.Monad (forM, guard)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (catchE, runExceptT, throwE)
import Control.Monad.Trans.State.Strict (execStateT)
import Data.Default (def)
import Data.Maybe (maybeToList)
import Data.Text (Text, isPrefixOf)
import System.FilePath
import Text.Megaparsec (SourcePos (..), unPos)
import qualified Data.Aeson as J
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Rope.UTF16 as Rope
import qualified Data.Text as Text
import qualified Language.Haskell.LSP.Core as LSP
import qualified Language.Haskell.LSP.Messages as LSP
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Types.Lens as J
import qualified Language.Haskell.LSP.VFS as LSP
import qualified Network.URI as URI
import qualified Network.URI.Encode as URI
wrapHandler
:: MVar ServerState
-> (a -> HandlerM ())
-> a
-> IO ()
wrapHandler :: MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
vstate a -> HandlerM ()
handle a
message =
MVar ServerState -> (ServerState -> IO ServerState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ServerState
vstate ((ServerState -> IO ServerState) -> IO ())
-> (ServerState -> IO ServerState) -> IO ()
forall a b. (a -> b) -> a -> b
$
StateT ServerState IO (Either (Severity, Text) ())
-> ServerState -> IO ServerState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT ServerState IO (Either (Severity, Text) ())
-> ServerState -> IO ServerState)
-> (HandlerM ()
-> StateT ServerState IO (Either (Severity, Text) ()))
-> HandlerM ()
-> ServerState
-> IO ServerState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerM () -> StateT ServerState IO (Either (Severity, Text) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (HandlerM () -> ServerState -> IO ServerState)
-> HandlerM () -> ServerState -> IO ServerState
forall a b. (a -> b) -> a -> b
$
HandlerM () -> ((Severity, Text) -> HandlerM ()) -> HandlerM ()
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (a -> HandlerM ()
handle a
message) (Severity, Text) -> HandlerM ()
lspUserMessage
getServerConfig :: HandlerM ServerConfig
getServerConfig :: HandlerM ServerConfig
getServerConfig = do
LspFuncs ServerConfig
lsp <- Getting (LspFuncs ServerConfig) ServerState (LspFuncs ServerConfig)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (LspFuncs ServerConfig)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (LspFuncs ServerConfig) ServerState (LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs
Maybe ServerConfig
mConfig <- IO (Maybe ServerConfig)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe ServerConfig)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LspFuncs ServerConfig -> IO (Maybe ServerConfig)
forall c. LspFuncs c -> IO (Maybe c)
LSP.config LspFuncs ServerConfig
lsp)
case Maybe ServerConfig
mConfig of
Just ServerConfig
config -> ServerConfig -> HandlerM ServerConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ServerConfig
config
Maybe ServerConfig
Nothing -> ServerConfig -> HandlerM ServerConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ServerConfig
forall a. Default a => a
def
lspUserMessage :: (Severity, Text) -> HandlerM ()
lspUserMessage :: (Severity, Text) -> HandlerM ()
lspUserMessage (Severity
Log, Text
text) =
(NotificationMessage ServerMethod LogMessageParams
-> FromServerMessage)
-> ServerMethod -> LogMessageParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod LogMessageParams
-> FromServerMessage
LSP.NotLogMessage ServerMethod
J.WindowLogMessage
(LogMessageParams -> HandlerM ())
-> LogMessageParams -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> LogMessageParams
J.LogMessageParams MessageType
J.MtLog Text
text
lspUserMessage (Severity
severity, Text
text) =
(NotificationMessage ServerMethod ShowMessageParams
-> FromServerMessage)
-> ServerMethod -> ShowMessageParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod ShowMessageParams
-> FromServerMessage
LSP.NotShowMessage ServerMethod
J.WindowShowMessage
(ShowMessageParams -> HandlerM ())
-> ShowMessageParams -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> ShowMessageParams
J.ShowMessageParams MessageType
severity' Text
text
where severity' :: MessageType
severity' = case Severity
severity of
Severity
Error -> MessageType
J.MtError
Severity
Warning -> MessageType
J.MtWarning
Severity
Info -> MessageType
J.MtInfo
Severity
Log -> MessageType
J.MtLog
lspSend :: LSP.FromServerMessage -> HandlerM ()
lspSend :: FromServerMessage -> HandlerM ()
lspSend FromServerMessage
msg = do
FromServerMessage -> IO ()
send <- Getting
(FromServerMessage -> IO ())
ServerState
(FromServerMessage -> IO ())
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(FromServerMessage -> IO ())
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((LspFuncs ServerConfig
-> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
-> ServerState -> Const (FromServerMessage -> IO ()) ServerState
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs ((LspFuncs ServerConfig
-> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
-> ServerState -> Const (FromServerMessage -> IO ()) ServerState)
-> (((FromServerMessage -> IO ())
-> Const (FromServerMessage -> IO ()) (FromServerMessage -> IO ()))
-> LspFuncs ServerConfig
-> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig))
-> Getting
(FromServerMessage -> IO ())
ServerState
(FromServerMessage -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FromServerMessage -> IO ())
-> Const (FromServerMessage -> IO ()) (FromServerMessage -> IO ()))
-> LspFuncs ServerConfig
-> Const (FromServerMessage -> IO ()) (LspFuncs ServerConfig)
forall (f :: * -> *).
Functor f =>
LensLike' f (LspFuncs ServerConfig) (FromServerMessage -> IO ())
sendFunc)
IO () -> HandlerM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerM ()) -> IO () -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
send FromServerMessage
msg
lspRespond :: (J.ResponseMessage response -> LSP.FromServerMessage)
-> J.RequestMessage J.ClientMethod request response -> response -> HandlerM ()
lspRespond :: (ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage response -> FromServerMessage
constructor RequestMessage ClientMethod request response
request response
response =
FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (ResponseMessage response -> FromServerMessage)
-> ResponseMessage response
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseMessage response -> FromServerMessage
constructor (ResponseMessage response -> HandlerM ())
-> ResponseMessage response -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ RequestMessage ClientMethod request response
-> response -> ResponseMessage response
forall req resp.
RequestMessage ClientMethod req resp
-> resp -> ResponseMessage resp
LSP.makeResponseMessage RequestMessage ClientMethod request response
request response
response
lspSendNotification
:: (J.NotificationMessage J.ServerMethod params -> LSP.FromServerMessage)
-> J.ServerMethod -> params -> HandlerM ()
lspSendNotification :: (NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod params -> FromServerMessage
constructor ServerMethod
method params
params =
FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (NotificationMessage ServerMethod params -> FromServerMessage)
-> NotificationMessage ServerMethod params
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotificationMessage ServerMethod params -> FromServerMessage
constructor (NotificationMessage ServerMethod params -> HandlerM ())
-> NotificationMessage ServerMethod params -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ Text
-> ServerMethod
-> params
-> NotificationMessage ServerMethod params
forall m a. Text -> m -> a -> NotificationMessage m a
J.NotificationMessage Text
"2.0" ServerMethod
method params
params
lspRequest
:: (J.RequestMessage J.ServerMethod params response -> LSP.FromServerMessage)
-> J.ServerMethod -> params -> HandlerM ()
lspRequest :: (RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage ServerMethod params response -> FromServerMessage
constructor ServerMethod
method params
params = do
IO LspId
getNextReqId <- LensLike' (Const (IO LspId)) ServerState (LspFuncs ServerConfig)
-> (LspFuncs ServerConfig -> IO LspId)
-> ExceptT (Severity, Text) (StateT ServerState IO) (IO LspId)
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (IO LspId)) ServerState (LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs LspFuncs ServerConfig -> IO LspId
forall c. LspFuncs c -> IO LspId
LSP.getNextReqId
LspId
reqId <- IO LspId -> ExceptT (Severity, Text) (StateT ServerState IO) LspId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LspId
getNextReqId
FromServerMessage -> HandlerM ()
lspSend (FromServerMessage -> HandlerM ())
-> (RequestMessage ServerMethod params response
-> FromServerMessage)
-> RequestMessage ServerMethod params response
-> HandlerM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestMessage ServerMethod params response -> FromServerMessage
constructor (RequestMessage ServerMethod params response -> HandlerM ())
-> RequestMessage ServerMethod params response -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ Text
-> LspId
-> ServerMethod
-> params
-> RequestMessage ServerMethod params response
forall m req resp.
Text -> LspId -> m -> req -> RequestMessage m req resp
J.RequestMessage Text
"2.0" LspId
reqId ServerMethod
method params
params
readUri :: J.Uri -> HandlerM Text
readUri :: Uri -> HandlerM Text
readUri Uri
uri = do
NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc <- LensLike'
(Const (NormalizedUri -> IO (Maybe VirtualFile)))
ServerState
(LspFuncs ServerConfig)
-> (LspFuncs ServerConfig
-> NormalizedUri -> IO (Maybe VirtualFile))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(NormalizedUri -> IO (Maybe VirtualFile))
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
(Const (NormalizedUri -> IO (Maybe VirtualFile)))
ServerState
(LspFuncs ServerConfig)
Lens' ServerState (LspFuncs ServerConfig)
lspFuncs LspFuncs ServerConfig -> NormalizedUri -> IO (Maybe VirtualFile)
forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
LSP.getVirtualFileFunc
Maybe VirtualFile
mVirtualFile <- IO (Maybe VirtualFile)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe VirtualFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe VirtualFile)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe VirtualFile))
-> IO (Maybe VirtualFile)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)
case Maybe VirtualFile
mVirtualFile of
Just (LSP.VirtualFile Int
_ Int
_ Rope
rope) -> Text -> HandlerM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Text
Rope.toText Rope
rope)
Maybe VirtualFile
Nothing -> String -> HandlerM Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> HandlerM Text) -> String -> HandlerM Text
forall a b. (a -> b) -> a -> b
$ String
"Could not find " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in VFS."
loadFile :: J.Uri -> HandlerM (Expr Src Void)
loadFile :: Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri = do
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Either DhallError (Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to parse Dhall file.")
Either DhallError (Cache, Expr Src Void)
loaded <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
expr Cache
cache
(Cache
cache', Expr Src Void
expr') <- case Either DhallError (Cache, Expr Src Void)
loaded of
Right (Cache, Expr Src Void)
x -> (Cache, Expr Src Void)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache, Expr Src Void)
x
Either DhallError (Cache, Expr Src Void)
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to resolve imports.")
ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
Expr Src Void -> HandlerM (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
expr'
fileIdentifierFromUri :: J.Uri -> HandlerM FileIdentifier
fileIdentifierFromUri :: Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri =
let mFileIdentifier :: Maybe FileIdentifier
mFileIdentifier = (String -> FileIdentifier) -> Maybe String -> Maybe FileIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> FileIdentifier
fileIdentifierFromFilePath (Uri -> Maybe String
J.uriToFilePath Uri
uri)
Maybe FileIdentifier
-> Maybe FileIdentifier -> Maybe FileIdentifier
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do URI
uri' <- (String -> Maybe URI
URI.parseURI (String -> Maybe URI) -> (Uri -> String) -> Uri -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Uri -> Text) -> Uri -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> Text
J.getUri) Uri
uri
URI -> Maybe FileIdentifier
fileIdentifierFromURI URI
uri')
in case Maybe FileIdentifier
mFileIdentifier of
Just FileIdentifier
fileIdentifier -> FileIdentifier -> HandlerM FileIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return FileIdentifier
fileIdentifier
Maybe FileIdentifier
Nothing -> (Severity, Text) -> HandlerM FileIdentifier
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Uri -> Text
J.getUri Uri
uri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid name for a dhall file.")
rangeToJSON :: Range -> J.Range
rangeToJSON :: Range -> Range
rangeToJSON (Range (Int
x1,Int
y1) (Int
x2,Int
y2)) = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)
hoverExplain :: J.HoverRequest -> HandlerM ()
hoverExplain :: HoverRequest -> HandlerM ()
hoverExplain HoverRequest
request = do
let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
J.Position Int
line Int
col = HoverRequest
request HoverRequest -> Getting Position HoverRequest Position -> Position
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest)
-> ((Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> Getting Position HoverRequest Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position
Maybe DhallError
mError <- LensLike'
(Const (Maybe DhallError)) ServerState (Map Uri DhallError)
-> (Map Uri DhallError -> Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
(Const (Maybe DhallError)) ServerState (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors ((Map Uri DhallError -> Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (Map Uri DhallError -> Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b. (a -> b) -> a -> b
$ Uri -> Map Uri DhallError -> Maybe DhallError
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Uri
uri
let isHovered :: Diagnosis -> Bool
isHovered (Diagnosis Text
_ (Just (Range (Int, Int)
left (Int, Int)
right)) Text
_) =
(Int, Int)
left (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
line,Int
col) Bool -> Bool -> Bool
&& (Int
line,Int
col) (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
right
isHovered Diagnosis
_ = Bool
False
hoverFromDiagnosis :: Diagnosis -> Maybe Hover
hoverFromDiagnosis (Diagnosis Text
_ (Just (Range (Int, Int)
left (Int, Int)
right)) Text
diagnosis) =
let _range :: Maybe Range
_range = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Range
J.Range ((Int -> Int -> Position) -> (Int, Int) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Position
J.Position (Int, Int)
left)
((Int -> Int -> Position) -> (Int, Int) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Position
J.Position (Int, Int)
right)
encodedDiag :: String
encodedDiag = String -> String
URI.encode (Text -> String
Text.unpack Text
diagnosis)
command :: Text
command = Text
"[Explain error](dhall-explain:?"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
encodedDiag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"
_contents :: HoverContents
_contents = MarkupContent -> HoverContents
J.HoverContents (MarkupContent -> HoverContents) -> MarkupContent -> HoverContents
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
J.MarkupContent MarkupKind
J.MkMarkdown Text
command
in Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover :: HoverContents -> Maybe Range -> Hover
J.Hover { Maybe Range
HoverContents
$sel:_contents:Hover :: HoverContents
$sel:_range:Hover :: Maybe Range
_contents :: HoverContents
_range :: Maybe Range
.. }
hoverFromDiagnosis Diagnosis
_ = Maybe Hover
forall a. Maybe a
Nothing
mHover :: Maybe Hover
mHover = do DhallError
err <- Maybe DhallError
mError
Diagnosis
explanation <- DhallError -> Maybe Diagnosis
explain DhallError
err
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Diagnosis -> Bool
isHovered Diagnosis
explanation)
Diagnosis -> Maybe Hover
hoverFromDiagnosis Diagnosis
explanation
(ResponseMessage (Maybe Hover) -> FromServerMessage)
-> HoverRequest -> Maybe Hover -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (Maybe Hover) -> FromServerMessage
LSP.RspHover HoverRequest
request Maybe Hover
mHover
hoverType :: J.HoverRequest -> HandlerM ()
hoverType :: HoverRequest -> HandlerM ()
hoverType HoverRequest
request = do
let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
J.Position Int
line Int
col = HoverRequest
request HoverRequest -> Getting Position HoverRequest Position -> Position
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> HoverRequest -> Const Position HoverRequest)
-> ((Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams)
-> Getting Position HoverRequest Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> TextDocumentPositionParams
-> Const Position TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position
Expr Src Void
expr <- Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri
(WellTyped
welltyped, WellTyped
_) <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr of
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Info, Text
"Can't infer type; code does not type-check.")
Right (WellTyped, WellTyped)
wt -> (WellTyped, WellTyped)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) a. Monad m => a -> m a
return (WellTyped, WellTyped)
wt
case (Int, Int) -> WellTyped -> Either String (Maybe Src, Expr Src Void)
typeAt (Int
line,Int
col) WellTyped
welltyped of
Left String
err -> (Severity, Text) -> HandlerM ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, String -> Text
Text.pack String
err)
Right (Maybe Src
mSrc, Expr Src Void
typ) ->
let _range :: Maybe Range
_range = (Src -> Range) -> Maybe Src -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Range -> Range
rangeToJSON (Range -> Range) -> (Src -> Range) -> Src -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Src -> Range
rangeFromDhall) Maybe Src
mSrc
_contents :: HoverContents
_contents = MarkupContent -> HoverContents
J.HoverContents (MarkupContent -> HoverContents) -> MarkupContent -> HoverContents
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
J.MarkupContent MarkupKind
J.MkPlainText (Expr Src Void -> Text
forall a. Pretty a => a -> Text
pretty Expr Src Void
typ)
hover :: Hover
hover = Hover :: HoverContents -> Maybe Range -> Hover
J.Hover{Maybe Range
HoverContents
_contents :: HoverContents
_range :: Maybe Range
$sel:_contents:Hover :: HoverContents
$sel:_range:Hover :: Maybe Range
..}
in (ResponseMessage (Maybe Hover) -> FromServerMessage)
-> HoverRequest -> Maybe Hover -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (Maybe Hover) -> FromServerMessage
LSP.RspHover HoverRequest
request (Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover
hover)
hoverHandler :: J.HoverRequest -> HandlerM ()
hoverHandler :: HoverRequest -> HandlerM ()
hoverHandler HoverRequest
request = do
let uri :: Uri
uri = HoverRequest
request HoverRequest -> Getting Uri HoverRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest
forall s a. HasParams s a => Lens' s a
J.params ((TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> HoverRequest -> Const Uri HoverRequest)
-> ((Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> Getting Uri HoverRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
Map Uri DhallError
errorMap <- Getting (Map Uri DhallError) ServerState (Map Uri DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Map Uri DhallError)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map Uri DhallError) ServerState (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors
case Uri -> Map Uri DhallError -> Maybe DhallError
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Uri
uri Map Uri DhallError
errorMap of
Maybe DhallError
Nothing -> HoverRequest -> HandlerM ()
hoverType HoverRequest
request
Maybe DhallError
_ -> HoverRequest -> HandlerM ()
hoverExplain HoverRequest
request
documentLinkHandler :: J.DocumentLinkRequest -> HandlerM ()
documentLinkHandler :: DocumentLinkRequest -> HandlerM ()
documentLinkHandler DocumentLinkRequest
req = do
let uri :: Uri
uri = DocumentLinkRequest
req DocumentLinkRequest -> Getting Uri DocumentLinkRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DocumentLinkParams -> Const Uri DocumentLinkParams)
-> DocumentLinkRequest -> Const Uri DocumentLinkRequest
forall s a. HasParams s a => Lens' s a
J.params ((DocumentLinkParams -> Const Uri DocumentLinkParams)
-> DocumentLinkRequest -> Const Uri DocumentLinkRequest)
-> ((Uri -> Const Uri Uri)
-> DocumentLinkParams -> Const Uri DocumentLinkParams)
-> Getting Uri DocumentLinkRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentLinkParams -> Const Uri DocumentLinkParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentLinkParams -> Const Uri DocumentLinkParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DocumentLinkParams
-> Const Uri DocumentLinkParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
String
path <- case Uri -> Maybe String
J.uriToFilePath Uri
uri of
Maybe String
Nothing -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not process document links; failed to convert URI to file path.")
Just String
p -> String -> ExceptT (Severity, Text) (StateT ServerState IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not process document links; did not parse.")
let imports :: [(Range, Import)]
imports = Expr Src Import -> [(Range, Import)]
forall a. Expr Src a -> [(Range, a)]
embedsWithRanges Expr Src Import
expr :: [(Range, Import)]
let basePath :: String
basePath = String -> String
takeDirectory String
path
let go :: (Range, Import) -> IO [J.DocumentLink]
go :: (Range, Import) -> IO [DocumentLink]
go (Range
range, Import (ImportHashed Maybe SHA256Digest
_ (Local FilePrefix
prefix File
file)) ImportMode
_) = do
String
filePath <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
let filePath' :: String
filePath' = String
basePath String -> String -> String
</> String
filePath
let url' :: Uri
url' = String -> Uri
J.filePathToUri String
filePath'
let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
let _target :: Maybe Text
_target = Text -> Maybe Text
forall a. a -> Maybe a
Just (Uri -> Text
J.getUri Uri
url')
[DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Text -> DocumentLink
J.DocumentLink {Maybe Text
Range
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Text
_target :: Maybe Text
_range :: Range
..}]
go (Range
range, Import (ImportHashed Maybe SHA256Digest
_ (Remote URL
url)) ImportMode
_) = do
let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
let url' :: URL
url' = URL
url { headers :: Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
forall a. Maybe a
Nothing }
let _target :: Maybe Text
_target = Text -> Maybe Text
forall a. a -> Maybe a
Just (URL -> Text
forall a. Pretty a => a -> Text
pretty URL
url')
[DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Text -> DocumentLink
J.DocumentLink {Maybe Text
Range
_target :: Maybe Text
_range :: Range
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Text
..}]
go (Range, Import)
_ = [DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[[DocumentLink]]
links <- IO [[DocumentLink]]
-> ExceptT
(Severity, Text) (StateT ServerState IO) [[DocumentLink]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[DocumentLink]]
-> ExceptT
(Severity, Text) (StateT ServerState IO) [[DocumentLink]])
-> IO [[DocumentLink]]
-> ExceptT
(Severity, Text) (StateT ServerState IO) [[DocumentLink]]
forall a b. (a -> b) -> a -> b
$ ((Range, Import) -> IO [DocumentLink])
-> [(Range, Import)] -> IO [[DocumentLink]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range, Import) -> IO [DocumentLink]
go [(Range, Import)]
imports
(ResponseMessage (List DocumentLink) -> FromServerMessage)
-> DocumentLinkRequest -> List DocumentLink -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (List DocumentLink) -> FromServerMessage
LSP.RspDocumentLink DocumentLinkRequest
req ([DocumentLink] -> List DocumentLink
forall a. [a] -> List a
J.List ([[DocumentLink]] -> [DocumentLink]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DocumentLink]]
links))
diagnosticsHandler :: J.Uri -> HandlerM ()
diagnosticsHandler :: Uri -> HandlerM ()
diagnosticsHandler Uri
uri = do
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
ASetter ServerState ServerState Cache Cache
-> (Cache -> Cache) -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache (FileIdentifier -> Cache -> Cache
invalidate FileIdentifier
fileIdentifier)
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
Maybe DhallError
errs <- (ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> (DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> (DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (Maybe DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> (DhallError -> Maybe DhallError)
-> DhallError
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhallError -> Maybe DhallError
forall a. a -> Maybe a
Just) (ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError))
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Maybe DhallError)
forall a b. (a -> b) -> a -> b
$ do
Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT DhallError (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Left DhallError
err -> DhallError
-> ExceptT DhallError (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
Either DhallError (Cache, Expr Src Void)
loaded <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
DhallError
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
DhallError
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
DhallError
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
expr Cache
cache
(Cache
cache', Expr Src Void
expr') <- case Either DhallError (Cache, Expr Src Void)
loaded of
Right (Cache, Expr Src Void)
x -> (Cache, Expr Src Void)
-> ExceptT
DhallError (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache, Expr Src Void)
x
Left DhallError
err -> DhallError
-> ExceptT
DhallError (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
WellTyped
_ <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr' of
Right (WellTyped
wt, WellTyped
_typ) -> WellTyped -> ExceptT DhallError (StateT ServerState IO) WellTyped
forall (m :: * -> *) a. Monad m => a -> m a
return WellTyped
wt
Left DhallError
err -> DhallError -> ExceptT DhallError (StateT ServerState IO) WellTyped
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DhallError
err
ASetter ServerState ServerState Cache Cache
-> Cache -> ExceptT DhallError (StateT ServerState IO) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
Maybe DhallError
-> ExceptT DhallError (StateT ServerState IO) (Maybe DhallError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DhallError
forall a. Maybe a
Nothing
let suggestions :: [Suggestion]
suggestions =
case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
expr -> Expr Src Import -> [Suggestion]
suggest Expr Src Import
expr
Either DhallError (Expr Src Import)
_ -> []
suggestionToDiagnostic :: Suggestion -> Diagnostic
suggestionToDiagnostic Suggestion {Text
Range
suggestion :: Suggestion -> Text
range :: Suggestion -> Range
suggestion :: Text
range :: Range
..} =
let _range :: Range
_range = Range -> Range
rangeToJSON Range
range
_severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsHint
_source :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Dhall.Lint"
_code :: Maybe a
_code = Maybe a
forall a. Maybe a
Nothing
_message :: Text
_message = Text
suggestion
_tags :: Maybe a
_tags = Maybe a
forall a. Maybe a
Nothing
_relatedInformation :: Maybe a
_relatedInformation = Maybe a
forall a. Maybe a
Nothing
in Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic {Maybe Text
Maybe NumberOrString
Maybe DiagnosticSeverity
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
forall a. Maybe a
$sel:_range:Diagnostic :: Range
$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
$sel:_code:Diagnostic :: Maybe NumberOrString
$sel:_source:Diagnostic :: Maybe Text
$sel:_message:Diagnostic :: Text
$sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation :: forall a. Maybe a
_tags :: forall a. Maybe a
_message :: Text
_code :: forall a. Maybe a
_source :: Maybe Text
_severity :: Maybe DiagnosticSeverity
_range :: Range
..}
diagnosisToDiagnostic :: Diagnosis -> Diagnostic
diagnosisToDiagnostic Diagnosis {Maybe Range
Text
diagnosis :: Diagnosis -> Text
range :: Diagnosis -> Maybe Range
doctor :: Diagnosis -> Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
..} =
let _range :: Range
_range = case Maybe Range
range of
Just Range
range' ->
Range -> Range
rangeToJSON Range
range'
Maybe Range
Nothing -> Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
0 Int
0)
_severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsError
_source :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
doctor
_code :: Maybe a
_code = Maybe a
forall a. Maybe a
Nothing
_tags :: Maybe a
_tags = Maybe a
forall a. Maybe a
Nothing
_message :: Text
_message = Text
diagnosis
_relatedInformation :: Maybe a
_relatedInformation = Maybe a
forall a. Maybe a
Nothing
in Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic {Maybe Text
Maybe NumberOrString
Maybe DiagnosticSeverity
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
forall a. Maybe a
_relatedInformation :: forall a. Maybe a
_message :: Text
_tags :: forall a. Maybe a
_code :: forall a. Maybe a
_source :: Maybe Text
_severity :: Maybe DiagnosticSeverity
_range :: Range
$sel:_range:Diagnostic :: Range
$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
$sel:_code:Diagnostic :: Maybe NumberOrString
$sel:_source:Diagnostic :: Maybe Text
$sel:_message:Diagnostic :: Text
$sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
..}
diagnostics :: [Diagnostic]
diagnostics = (DhallError -> [Diagnostic]) -> [DhallError] -> [Diagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Diagnosis -> Diagnostic) -> [Diagnosis] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map Diagnosis -> Diagnostic
diagnosisToDiagnostic ([Diagnosis] -> [Diagnostic])
-> (DhallError -> [Diagnosis]) -> DhallError -> [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhallError -> [Diagnosis]
diagnose) (Maybe DhallError -> [DhallError]
forall a. Maybe a -> [a]
maybeToList Maybe DhallError
errs)
[Diagnostic] -> [Diagnostic] -> [Diagnostic]
forall a. [a] -> [a] -> [a]
++ (Suggestion -> Diagnostic) -> [Suggestion] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map Suggestion -> Diagnostic
suggestionToDiagnostic [Suggestion]
suggestions
ASetter
ServerState ServerState (Map Uri DhallError) (Map Uri DhallError)
-> (Map Uri DhallError -> Map Uri DhallError) -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
ServerState ServerState (Map Uri DhallError) (Map Uri DhallError)
Lens' ServerState (Map Uri DhallError)
errors ((Maybe DhallError -> Maybe DhallError)
-> Uri -> Map Uri DhallError -> Map Uri DhallError
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe DhallError -> Maybe DhallError -> Maybe DhallError
forall a b. a -> b -> a
const Maybe DhallError
errs) Uri
uri)
(NotificationMessage ServerMethod PublishDiagnosticsParams
-> FromServerMessage)
-> ServerMethod -> PublishDiagnosticsParams -> HandlerM ()
forall params.
(NotificationMessage ServerMethod params -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspSendNotification NotificationMessage ServerMethod PublishDiagnosticsParams
-> FromServerMessage
LSP.NotPublishDiagnostics ServerMethod
J.TextDocumentPublishDiagnostics
(Uri -> List Diagnostic -> PublishDiagnosticsParams
J.PublishDiagnosticsParams Uri
uri ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
J.List [Diagnostic]
diagnostics))
documentFormattingHandler :: J.DocumentFormattingRequest -> HandlerM ()
documentFormattingHandler :: DocumentFormattingRequest -> HandlerM ()
documentFormattingHandler DocumentFormattingRequest
request = do
let uri :: Uri
uri = DocumentFormattingRequest
request DocumentFormattingRequest
-> Getting Uri DocumentFormattingRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> DocumentFormattingRequest -> Const Uri DocumentFormattingRequest
forall s a. HasParams s a => Lens' s a
J.params ((DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> DocumentFormattingRequest
-> Const Uri DocumentFormattingRequest)
-> ((Uri -> Const Uri Uri)
-> DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> Getting Uri DocumentFormattingRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentFormattingParams -> Const Uri DocumentFormattingParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DocumentFormattingParams
-> Const Uri DocumentFormattingParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
(Header
header, Expr Src Import
expr) <- case Text -> Either DhallError (Header, Expr Src Import)
parseWithHeader Text
txt of
Right (Header, Expr Src Import)
res -> (Header, Expr Src Import)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header, Expr Src Import)
res
Either DhallError (Header, Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to format dhall code; parse error.")
ServerConfig {Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig
let formatted :: Text
formatted = Maybe CharacterSet -> Expr Src Import -> Header -> Text
forall b.
Pretty b =>
Maybe CharacterSet -> Expr Src b -> Header -> Text
formatExprWithHeader Maybe CharacterSet
chosenCharacterSet Expr Src Import
expr Header
header
numLines :: Int
numLines = Text -> Int
Text.length Text
txt
range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
numLines Int
0)
edits :: List TextEdit
edits = [TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
formatted]
(ResponseMessage (List TextEdit) -> FromServerMessage)
-> DocumentFormattingRequest -> List TextEdit -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage (List TextEdit) -> FromServerMessage
LSP.RspDocumentFormatting DocumentFormattingRequest
request List TextEdit
edits
executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM ()
executeCommandHandler :: ExecuteCommandRequest -> HandlerM ()
executeCommandHandler ExecuteCommandRequest
request
| Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.lint" = ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat ExecuteCommandRequest
request
| Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.annotateLet" = ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet ExecuteCommandRequest
request
| Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeImport" = ExecuteCommandRequest -> HandlerM ()
executeFreezeImport ExecuteCommandRequest
request
| Text
command Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeAllImports" = ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports ExecuteCommandRequest
request
| Bool
otherwise = (Severity, Text) -> HandlerM ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Command '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
command
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not known; ignored.")
where command :: Text
command = ExecuteCommandRequest
request ExecuteCommandRequest
-> Getting Text ExecuteCommandRequest Text -> Text
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
J.params ((ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest)
-> ((Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting Text ExecuteCommandRequest Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
J.command
getCommandArguments :: J.FromJSON a => J.ExecuteCommandRequest -> HandlerM a
getCommandArguments :: ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request = do
Value
json <- case ExecuteCommandRequest
request ExecuteCommandRequest
-> Getting
(Maybe (List Value)) ExecuteCommandRequest (Maybe (List Value))
-> Maybe (List Value)
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> ExecuteCommandRequest
-> Const (Maybe (List Value)) ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
J.params ((ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> ExecuteCommandRequest
-> Const (Maybe (List Value)) ExecuteCommandRequest)
-> ((Maybe (List Value)
-> Const (Maybe (List Value)) (Maybe (List Value)))
-> ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> Getting
(Maybe (List Value)) ExecuteCommandRequest (Maybe (List Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (List Value)
-> Const (Maybe (List Value)) (Maybe (List Value)))
-> ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams
forall s a. HasArguments s a => Lens' s a
J.arguments of
Just (J.List (Value
x : [Value]
_)) -> Value -> ExceptT (Severity, Text) (StateT ServerState IO) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
Maybe (List Value)
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to execute command; arguments missing.")
case Value -> Result a
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
J.Success a
args -> a -> HandlerM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
args
Result a
_ -> (Severity, Text) -> HandlerM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to execute command; failed to parse arguments.")
executeLintAndFormat :: J.ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat :: ExecuteCommandRequest -> HandlerM ()
executeLintAndFormat ExecuteCommandRequest
request = do
Uri
uri <- ExecuteCommandRequest -> HandlerM Uri
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
(Header
header, Expr Src Import
expr) <- case Text -> Either DhallError (Header, Expr Src Import)
parseWithHeader Text
txt of
Right (Header, Expr Src Import)
res -> (Header, Expr Src Import)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header, Expr Src Import)
res
Either DhallError (Header, Expr Src Import)
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Header, Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to lint dhall code; parse error.")
ServerConfig {Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig
let linted :: Text
linted = Maybe CharacterSet -> Expr Src Import -> Header -> Text
forall b.
Pretty b =>
Maybe CharacterSet -> Expr Src b -> Header -> Text
formatExprWithHeader Maybe CharacterSet
chosenCharacterSet (Expr Src Import -> Expr Src Import
forall s. Eq s => Expr s Import -> Expr s Import
lint Expr Src Import
expr) Header
header
numLines :: Int
numLines = Text -> Int
Text.length Text
txt
range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
0 Int
0) (Int -> Int -> Position
J.Position Int
numLines Int
0)
edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
(WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
linted]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing
(ResponseMessage Value -> FromServerMessage)
-> ExecuteCommandRequest -> Value -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage Value -> FromServerMessage
LSP.RspExecuteCommand ExecuteCommandRequest
request Value
J.Null
(RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
(WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)
executeAnnotateLet :: J.ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet :: ExecuteCommandRequest -> HandlerM ()
executeAnnotateLet ExecuteCommandRequest
request = do
TextDocumentPositionParams
args <- ExecuteCommandRequest -> HandlerM TextDocumentPositionParams
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request :: HandlerM J.TextDocumentPositionParams
let uri :: Uri
uri = TextDocumentPositionParams
args TextDocumentPositionParams
-> ((Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
line :: Int
line = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
col :: Int
col = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character
Expr Src Void
expr <- Uri -> HandlerM (Expr Src Void)
loadFile Uri
uri
(WellTyped
welltyped, WellTyped
_) <- case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr of
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Failed to annotate let binding; not well-typed.")
Right (WellTyped, WellTyped)
e -> (WellTyped, WellTyped)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (WellTyped, WellTyped)
forall (m :: * -> *) a. Monad m => a -> m a
return (WellTyped, WellTyped)
e
ServerConfig {Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
chosenCharacterSet :: ServerConfig -> Maybe CharacterSet
..} <- HandlerM ServerConfig
getServerConfig
(Src (SourcePos String
_ Pos
x1 Pos
y1) (SourcePos String
_ Pos
x2 Pos
y2) Text
_, Expr Src Void
annotExpr)
<- case (Int, Int) -> WellTyped -> Either String (Src, Expr Src Void)
annotateLet (Int
line, Int
col) WellTyped
welltyped of
Right (Src, Expr Src Void)
x -> (Src, Expr Src Void)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Src, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Src, Expr Src Void)
x
Left String
msg -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Src, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, String -> Text
Text.pack String
msg)
let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position (Pos -> Int
unPos Pos
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Pos -> Int
unPos Pos
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
(Int -> Int -> Position
J.Position (Pos -> Int
unPos Pos
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Pos -> Int
unPos Pos
y2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
txt :: Text
txt = Maybe CharacterSet -> Expr Src Void -> Text
forall b. Pretty b => Maybe CharacterSet -> Expr Src b -> Text
formatExpr Maybe CharacterSet
chosenCharacterSet Expr Src Void
annotExpr
edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
(WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range Text
txt]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing
(RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
(WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)
executeFreezeAllImports :: J.ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports :: ExecuteCommandRequest -> HandlerM ()
executeFreezeAllImports ExecuteCommandRequest
request = do
Uri
uri <- ExecuteCommandRequest -> HandlerM Uri
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Could not freeze imports; did not parse.")
let importRanges :: [(Import, Range)]
importRanges = Expr Src Import -> [(Import, Range)]
getAllImportsWithHashPositions Expr Src Import
expr
[TextEdit]
edits <- [(Import, Range)]
-> ((Import, Range)
-> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
-> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Import, Range)]
importRanges (((Import, Range)
-> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
-> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit])
-> ((Import, Range)
-> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit)
-> ExceptT (Severity, Text) (StateT ServerState IO) [TextEdit]
forall a b. (a -> b) -> a -> b
$ \(Import
import_, Range (Int
x1, Int
y1) (Int
x2, Int
y2)) -> do
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
let importExpr :: Expr s Import
importExpr = Import -> Expr s Import
forall s a. a -> Expr s a
Embed (Import -> Import
stripHash Import
import_)
Either DhallError (Cache, Text)
hashResult <- IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import -> Cache -> IO (Either DhallError (Cache, Text))
computeSemanticHash FileIdentifier
fileIdentifier Expr Src Import
forall s. Expr s Import
importExpr Cache
cache
(Cache
cache', Text
hash) <- case Either DhallError (Cache, Text)
hashResult of
Right (Cache
c, Text
t) -> (Cache, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
c, Text
t)
Left DhallError
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Could not freeze import; failed to evaluate import.")
ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)
TextEdit
-> ExceptT (Severity, Text) (StateT ServerState IO) TextEdit
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> Text -> TextEdit
J.TextEdit Range
range (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash))
let workspaceEdit :: WorkspaceEdit
workspaceEdit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
(WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [TextEdit]
edits))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing
(RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
(WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
workspaceEdit)
executeFreezeImport :: J.ExecuteCommandRequest -> HandlerM ()
executeFreezeImport :: ExecuteCommandRequest -> HandlerM ()
executeFreezeImport ExecuteCommandRequest
request = do
TextDocumentPositionParams
args <- ExecuteCommandRequest -> HandlerM TextDocumentPositionParams
forall a. FromJSON a => ExecuteCommandRequest -> HandlerM a
getCommandArguments ExecuteCommandRequest
request :: HandlerM J.TextDocumentPositionParams
let uri :: Uri
uri = TextDocumentPositionParams
args TextDocumentPositionParams
-> ((Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
line :: Int
line = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
col :: Int
col = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Int TextDocumentPositionParams Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> TextDocumentPositionParams
-> Const Int TextDocumentPositionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int TextDocumentPositionParams Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
Expr Src Import
expr <- case Text -> Either DhallError (Expr Src Import)
parse Text
txt of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"Could not freeze import; did not parse.")
(Src
src, Import
import_)
<- case (Int, Int) -> Expr Src Import -> Maybe (Expr Src Import)
forall a. (Int, Int) -> Expr Src a -> Maybe (Expr Src a)
exprAt (Int
line, Int
col) Expr Src Import
expr of
Just (Note Src
src (Embed Import
i)) -> (Src, Import)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Src, Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Src
src, Import
i)
Maybe (Expr Src Import)
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Src, Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Warning, Text
"You weren't pointing at an import!")
Range (Int
x1, Int
y1) (Int
x2, Int
y2) <- case Src -> Maybe Range
getImportHashPosition Src
src of
Just Range
range -> Range -> ExceptT (Severity, Text) (StateT ServerState IO) Range
forall (m :: * -> *) a. Monad m => a -> m a
return Range
range
Maybe Range
Nothing -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) Range
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Failed to re-parse import!")
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
let importExpr :: Expr s Import
importExpr = Import -> Expr s Import
forall s a. a -> Expr s a
Embed (Import -> Import
stripHash Import
import_)
Either DhallError (Cache, Text)
hashResult <- IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Text))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import -> Cache -> IO (Either DhallError (Cache, Text))
computeSemanticHash FileIdentifier
fileIdentifier Expr Src Import
forall s. Expr s Import
importExpr Cache
cache
(Cache
cache', Text
hash) <- case Either DhallError (Cache, Text)
hashResult of
Right (Cache
c, Text
t) -> (Cache, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
c, Text
t)
Left DhallError
_ -> (Severity, Text)
-> ExceptT (Severity, Text) (StateT ServerState IO) (Cache, Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Could not freeze import; failed to evaluate import.")
ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
let range :: Range
range = Position -> Position -> Range
J.Range (Int -> Int -> Position
J.Position Int
x1 Int
y1) (Int -> Int -> Position
J.Position Int
x2 Int
y2)
edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit
(WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
uri ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [Range -> Text -> TextEdit
J.TextEdit Range
range (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash)]))) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing
(RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage)
-> ServerMethod -> ApplyWorkspaceEditParams -> HandlerM ()
forall params response.
(RequestMessage ServerMethod params response -> FromServerMessage)
-> ServerMethod -> params -> HandlerM ()
lspRequest RequestMessage
ServerMethod
ApplyWorkspaceEditParams
ApplyWorkspaceEditResponseBody
-> FromServerMessage
LSP.ReqApplyWorkspaceEdit ServerMethod
J.WorkspaceApplyEdit
(WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit)
completionHandler :: J.CompletionRequest -> HandlerM ()
completionHandler :: CompletionRequest -> HandlerM ()
completionHandler CompletionRequest
request = do
let uri :: Uri
uri = CompletionRequest
request CompletionRequest -> Getting Uri CompletionRequest Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Uri CompletionParams)
-> CompletionRequest -> Const Uri CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Uri CompletionParams)
-> CompletionRequest -> Const Uri CompletionRequest)
-> ((Uri -> Const Uri Uri)
-> CompletionParams -> Const Uri CompletionParams)
-> Getting Uri CompletionRequest Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CompletionParams -> Const Uri CompletionParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CompletionParams -> Const Uri CompletionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> CompletionParams
-> Const Uri CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
line :: Int
line = CompletionRequest
request CompletionRequest -> Getting Int CompletionRequest Int -> Int
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest)
-> ((Int -> Const Int Int)
-> CompletionParams -> Const Int CompletionParams)
-> Getting Int CompletionRequest Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> CompletionParams
-> Const Int CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
J.line
col :: Int
col = CompletionRequest
request CompletionRequest -> Getting Int CompletionRequest Int -> Int
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest
forall s a. HasParams s a => Lens' s a
J.params ((CompletionParams -> Const Int CompletionParams)
-> CompletionRequest -> Const Int CompletionRequest)
-> ((Int -> Const Int Int)
-> CompletionParams -> Const Int CompletionParams)
-> Getting Int CompletionRequest Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams
forall s a. HasPosition s a => Lens' s a
J.position ((Position -> Const Int Position)
-> CompletionParams -> Const Int CompletionParams)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> CompletionParams
-> Const Int CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
J.character
Text
txt <- Uri -> HandlerM Text
readUri Uri
uri
let (Text
completionLeadup, Text
completionPrefix) = Text -> (Int, Int) -> (Text, Text)
completionQueryAt Text
txt (Int
line, Int
col)
let computeCompletions :: ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
computeCompletions
| Text
"env:" Text -> Text -> Bool
`isPrefixOf` Text
completionPrefix =
IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Completion]
completeEnvironmentImport
| (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`isPrefixOf` Text
completionPrefix) [ Text
"/", Text
"./", Text
"../", Text
"~/" ] = do
let relativeTo :: String
relativeTo | Just String
path <- Uri -> Maybe String
J.uriToFilePath Uri
uri = String
path
| Bool
otherwise = String
"."
IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion])
-> IO [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO [Completion]
completeLocalImport String
relativeTo (Text -> String
Text.unpack Text
completionPrefix)
| (Text
target, Text
_) <- Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." Text
completionPrefix
, Bool -> Bool
not (Text -> Bool
Text.null Text
target) = do
let bindersExpr :: Expr Src Import
bindersExpr = Text -> Expr Src Import
binderExprFromText Text
completionLeadup
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
Either DhallError (Cache, Expr Src Void)
loadedBinders <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
bindersExpr Cache
cache
(Cache
cache', Expr Src Void
bindersExpr') <-
case Either DhallError (Cache, Expr Src Void)
loadedBinders of
Right (Cache
cache', Expr Src Void
binders) ->
(Cache, Expr Src Void)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache
cache', Expr Src Void
binders)
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Cache, Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; failed to load binders expression.")
let completionContext :: CompletionContext
completionContext = Expr Src Void -> CompletionContext
buildCompletionContext Expr Src Void
bindersExpr'
Expr Src Import
targetExpr <- case Text -> Either DhallError (Expr Src Import)
parse (Int -> Text -> Text
Text.dropEnd Int
1 Text
target) of
Right Expr Src Import
e -> Expr Src Import
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
e
Left DhallError
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState IO) (Expr Src Import)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; prefix did not parse.")
Either DhallError (Cache, Expr Src Void)
loaded' <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
targetExpr Cache
cache'
case Either DhallError (Cache, Expr Src Void)
loaded' of
Right (Cache
cache'', Expr Src Void
targetExpr') -> do
ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache''
[Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionContext -> Expr Src Void -> [Completion]
completeProjections CompletionContext
completionContext Expr Src Void
targetExpr')
Left DhallError
_ -> [Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = do
let bindersExpr :: Expr Src Import
bindersExpr = Text -> Expr Src Import
binderExprFromText Text
completionLeadup
FileIdentifier
fileIdentifier <- Uri -> HandlerM FileIdentifier
fileIdentifierFromUri Uri
uri
Cache
cache <- Getting Cache ServerState Cache
-> ExceptT (Severity, Text) (StateT ServerState IO) Cache
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Cache ServerState Cache
Lens' ServerState Cache
importCache
Either DhallError (Cache, Expr Src Void)
loadedBinders <- IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState IO)
(Either DhallError (Cache, Expr Src Void))
forall a b. (a -> b) -> a -> b
$ FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileIdentifier Expr Src Import
bindersExpr Cache
cache
Expr Src Void
bindersExpr' <-
case Either DhallError (Cache, Expr Src Void)
loadedBinders of
Right (Cache
cache', Expr Src Void
binders) -> do
ASetter ServerState ServerState Cache Cache -> Cache -> HandlerM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter ServerState ServerState Cache Cache
Lens' ServerState Cache
importCache Cache
cache'
Expr Src Void -> HandlerM (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
binders
Left DhallError
_ -> (Severity, Text) -> HandlerM (Expr Src Void)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Log, Text
"Could not complete projection; failed to load binders expression.")
let context :: CompletionContext
context = Expr Src Void -> CompletionContext
buildCompletionContext Expr Src Void
bindersExpr'
[Completion]
-> ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionContext -> [Completion]
completeFromContext CompletionContext
context)
[Completion]
completions <- ExceptT (Severity, Text) (StateT ServerState IO) [Completion]
computeCompletions
let item :: Completion -> CompletionItem
item (Completion {Maybe (Expr Src Void)
Text
completeType :: Completion -> Maybe (Expr Src Void)
completeText :: Completion -> Text
completeType :: Maybe (Expr Src Void)
completeText :: Text
..}) = CompletionItem :: Text
-> Maybe CompletionItemKind
-> Maybe (List CompletionItemTag)
-> Maybe Text
-> Maybe CompletionDoc
-> Maybe Bool
-> Maybe Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe InsertTextFormat
-> Maybe TextEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
J.CompletionItem {Maybe Bool
Maybe Text
Maybe Value
Maybe CompletionItemKind
Maybe InsertTextFormat
Maybe CompletionDoc
Maybe TextEdit
Maybe Command
Maybe (List Text)
Maybe (List CompletionItemTag)
Maybe (List TextEdit)
Text
forall a. Maybe a
$sel:_label:CompletionItem :: Text
$sel:_kind:CompletionItem :: Maybe CompletionItemKind
$sel:_tags:CompletionItem :: Maybe (List CompletionItemTag)
$sel:_detail:CompletionItem :: Maybe Text
$sel:_documentation:CompletionItem :: Maybe CompletionDoc
$sel:_deprecated:CompletionItem :: Maybe Bool
$sel:_preselect:CompletionItem :: Maybe Bool
$sel:_sortText:CompletionItem :: Maybe Text
$sel:_filterText:CompletionItem :: Maybe Text
$sel:_insertText:CompletionItem :: Maybe Text
$sel:_insertTextFormat:CompletionItem :: Maybe InsertTextFormat
$sel:_textEdit:CompletionItem :: Maybe TextEdit
$sel:_additionalTextEdits:CompletionItem :: Maybe (List TextEdit)
$sel:_commitCharacters:CompletionItem :: Maybe (List Text)
$sel:_command:CompletionItem :: Maybe Command
$sel:_xdata:CompletionItem :: Maybe Value
_xdata :: forall a. Maybe a
_command :: forall a. Maybe a
_commitCharacters :: forall a. Maybe a
_additionalTextEdits :: forall a. Maybe a
_textEdit :: forall a. Maybe a
_insertTextFormat :: forall a. Maybe a
_insertText :: forall a. Maybe a
_filterText :: forall a. Maybe a
_sortText :: forall a. Maybe a
_preselect :: forall a. Maybe a
_deprecated :: forall a. Maybe a
_documentation :: forall a. Maybe a
_detail :: Maybe Text
_tags :: Maybe (List CompletionItemTag)
_kind :: forall a. Maybe a
_label :: Text
..}
where
_label :: Text
_label = Text
completeText
_kind :: Maybe a
_kind = Maybe a
forall a. Maybe a
Nothing
_tags :: Maybe (List CompletionItemTag)
_tags = Maybe (List CompletionItemTag)
forall a. Monoid a => a
mempty
_detail :: Maybe Text
_detail = (Expr Src Void -> Text) -> Maybe (Expr Src Void) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Void -> Text
forall a. Pretty a => a -> Text
pretty Maybe (Expr Src Void)
completeType
_documentation :: Maybe a
_documentation = Maybe a
forall a. Maybe a
Nothing
_deprecated :: Maybe a
_deprecated = Maybe a
forall a. Maybe a
Nothing
_preselect :: Maybe a
_preselect = Maybe a
forall a. Maybe a
Nothing
_sortText :: Maybe a
_sortText = Maybe a
forall a. Maybe a
Nothing
_filterText :: Maybe a
_filterText = Maybe a
forall a. Maybe a
Nothing
_insertText :: Maybe a
_insertText = Maybe a
forall a. Maybe a
Nothing
_insertTextFormat :: Maybe a
_insertTextFormat = Maybe a
forall a. Maybe a
Nothing
_textEdit :: Maybe a
_textEdit = Maybe a
forall a. Maybe a
Nothing
_additionalTextEdits :: Maybe a
_additionalTextEdits = Maybe a
forall a. Maybe a
Nothing
_commitCharacters :: Maybe a
_commitCharacters = Maybe a
forall a. Maybe a
Nothing
_command :: Maybe a
_command = Maybe a
forall a. Maybe a
Nothing
_xdata :: Maybe a
_xdata = Maybe a
forall a. Maybe a
Nothing
(ResponseMessage CompletionResponseResult -> FromServerMessage)
-> CompletionRequest -> CompletionResponseResult -> HandlerM ()
forall response request.
(ResponseMessage response -> FromServerMessage)
-> RequestMessage ClientMethod request response
-> response
-> HandlerM ()
lspRespond ResponseMessage CompletionResponseResult -> FromServerMessage
LSP.RspCompletion CompletionRequest
request (CompletionResponseResult -> HandlerM ())
-> CompletionResponseResult -> HandlerM ()
forall a b. (a -> b) -> a -> b
$ List CompletionItem -> CompletionResponseResult
J.Completions ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
J.List ((Completion -> CompletionItem) -> [Completion] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Completion -> CompletionItem
item [Completion]
completions))
nullHandler :: a -> HandlerM ()
nullHandler :: a -> HandlerM ()
nullHandler a
_ = () -> HandlerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
didOpenTextDocumentNotificationHandler
:: J.DidOpenTextDocumentNotification -> HandlerM ()
didOpenTextDocumentNotificationHandler :: DidOpenTextDocumentNotification -> HandlerM ()
didOpenTextDocumentNotificationHandler DidOpenTextDocumentNotification
notification = do
let uri :: Uri
uri = DidOpenTextDocumentNotification
notification DidOpenTextDocumentNotification
-> Getting Uri DidOpenTextDocumentNotification Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> DidOpenTextDocumentNotification
-> Const Uri DidOpenTextDocumentNotification
forall s a. HasParams s a => Lens' s a
J.params ((DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> DidOpenTextDocumentNotification
-> Const Uri DidOpenTextDocumentNotification)
-> ((Uri -> Const Uri Uri)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams)
-> Getting Uri DidOpenTextDocumentNotification Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentItem -> Const Uri TextDocumentItem)
-> DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentItem -> Const Uri TextDocumentItem)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentItem -> Const Uri TextDocumentItem)
-> (Uri -> Const Uri Uri)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentItem -> Const Uri TextDocumentItem
forall s a. HasUri s a => Lens' s a
J.uri
Uri -> HandlerM ()
diagnosticsHandler Uri
uri
didSaveTextDocumentNotificationHandler
:: J.DidSaveTextDocumentNotification -> HandlerM ()
didSaveTextDocumentNotificationHandler :: DidSaveTextDocumentNotification -> HandlerM ()
didSaveTextDocumentNotificationHandler DidSaveTextDocumentNotification
notification = do
let uri :: Uri
uri = DidSaveTextDocumentNotification
notification DidSaveTextDocumentNotification
-> Getting Uri DidSaveTextDocumentNotification Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> DidSaveTextDocumentNotification
-> Const Uri DidSaveTextDocumentNotification
forall s a. HasParams s a => Lens' s a
J.params ((DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> DidSaveTextDocumentNotification
-> Const Uri DidSaveTextDocumentNotification)
-> ((Uri -> Const Uri Uri)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams)
-> Getting Uri DidSaveTextDocumentNotification Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
Uri -> HandlerM ()
diagnosticsHandler Uri
uri