{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
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.Lens (assign, modifying, use, (^.))
import Control.Monad (forM, guard)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Except (catchE, throwE)
import Data.Aeson (FromJSON(..), Value(..))
import Data.Maybe (maybeToList)
import Data.Text (Text, isPrefixOf)
import Language.LSP.Server (Handlers, LspT)
import Language.LSP.Types hiding (Range(..), line)
import Language.LSP.Types.Lens
import System.FilePath
import Text.Megaparsec (SourcePos (..), unPos)
import qualified Data.Aeson as Aeson
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.LSP.Server as LSP
import qualified Language.LSP.Types as LSP.Types
import qualified Language.LSP.VFS as LSP
import qualified Network.URI as URI
import qualified Network.URI.Encode as URI
liftLSP :: LspT ServerConfig IO a -> HandlerM a
liftLSP :: LspT ServerConfig IO a -> HandlerM a
liftLSP LspT ServerConfig IO a
m = StateT ServerState (LspT ServerConfig IO) a -> HandlerM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT ServerConfig IO a
-> StateT ServerState (LspT ServerConfig IO) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LspT ServerConfig IO a
m)
readUri :: Uri -> HandlerM Text
readUri :: Uri -> HandlerM Text
readUri Uri
uri_ = do
Maybe VirtualFile
mVirtualFile <- LspT ServerConfig IO (Maybe VirtualFile)
-> HandlerM (Maybe VirtualFile)
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (NormalizedUri -> LspT ServerConfig IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
LSP.getVirtualFile (Uri -> NormalizedUri
LSP.Types.toNormalizedUri Uri
uri_))
case Maybe VirtualFile
mVirtualFile of
Just (LSP.VirtualFile Int32
_ Int
_ Rope
rope) -> Text -> HandlerM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Text
Rope.toText Rope
rope)
Maybe VirtualFile
Nothing -> (Severity, Text) -> HandlerM Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Severity
Error, Text
"Could not find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Uri -> String
forall a. Show a => a -> String
show Uri
uri_) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in VFS.")
loadFile :: 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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'
Expr Src Void -> HandlerM (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
expr'
fileIdentifierFromUri :: 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
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
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
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 -> LSP.Types.Range
rangeToJSON :: Range -> Range
rangeToJSON (Range (Int
x1,Int
y1) (Int
x2,Int
y2)) =
Position -> Position -> Range
LSP.Types.Range
(UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y1))
(UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x2) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y2))
hoverHandler :: Handlers HandlerM
hoverHandler :: Handlers HandlerM
hoverHandler =
SMethod 'TextDocumentHover
-> Handler HandlerM 'TextDocumentHover -> Handlers HandlerM
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'TextDocumentHover
STextDocumentHover \RequestMessage 'TextDocumentHover
request Either ResponseError (Maybe Hover)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond -> do
let uri_ :: Uri
uri_ = RequestMessage 'TextDocumentHover
requestRequestMessage 'TextDocumentHover
-> Getting Uri (RequestMessage 'TextDocumentHover) Uri -> Uri
forall s a. s -> Getting a s a -> a
^.(HoverParams -> Const Uri HoverParams)
-> RequestMessage 'TextDocumentHover
-> Const Uri (RequestMessage 'TextDocumentHover)
forall s a. HasParams s a => Lens' s a
params((HoverParams -> Const Uri HoverParams)
-> RequestMessage 'TextDocumentHover
-> Const Uri (RequestMessage 'TextDocumentHover))
-> ((Uri -> Const Uri Uri) -> HoverParams -> Const Uri HoverParams)
-> Getting Uri (RequestMessage 'TextDocumentHover) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> HoverParams -> Const Uri HoverParams
forall s a. HasTextDocument s a => Lens' s a
textDocument((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> HoverParams -> Const Uri HoverParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> HoverParams
-> Const Uri HoverParams
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
uri
let Position{ _line :: Position -> UInt
_line = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
_line, _character :: Position -> UInt
_character = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
_character } = RequestMessage 'TextDocumentHover
requestRequestMessage 'TextDocumentHover
-> Getting Position (RequestMessage 'TextDocumentHover) Position
-> Position
forall s a. s -> Getting a s a -> a
^.(HoverParams -> Const Position HoverParams)
-> RequestMessage 'TextDocumentHover
-> Const Position (RequestMessage 'TextDocumentHover)
forall s a. HasParams s a => Lens' s a
params((HoverParams -> Const Position HoverParams)
-> RequestMessage 'TextDocumentHover
-> Const Position (RequestMessage 'TextDocumentHover))
-> ((Position -> Const Position Position)
-> HoverParams -> Const Position HoverParams)
-> Getting Position (RequestMessage 'TextDocumentHover) Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Position -> Const Position Position)
-> HoverParams -> Const Position HoverParams
forall s a. HasPosition s a => Lens' s a
position
Map Uri DhallError
errorMap <- Getting (Map Uri DhallError) ServerState (Map Uri DhallError)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 -> do
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 (LspT ServerConfig 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 (LspT ServerConfig 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
_character) WellTyped
welltyped of
Left String
err -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
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) -> do
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
let _contents :: HoverContents
_contents = MarkupContent -> HoverContents
HoverContents (MarkupKind -> Text -> MarkupContent
MarkupContent MarkupKind
MkPlainText (Expr Src Void -> Text
forall a. Pretty a => a -> Text
pretty Expr Src Void
typ))
Either ResponseError (Maybe Hover)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond (Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right (Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover :: HoverContents -> Maybe Range -> Hover
Hover{ HoverContents
$sel:_contents:Hover :: HoverContents
_contents :: HoverContents
_contents, Maybe Range
$sel:_range:Hover :: Maybe Range
_range :: Maybe Range
_range }))
Just DhallError
err -> do
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
_character) Bool -> Bool -> Bool
&& (Int
_line, Int
_character) (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
right
isHovered Diagnosis
_ =
Bool
False
let hoverFromDiagnosis :: Diagnosis -> Maybe Hover
hoverFromDiagnosis (Diagnosis Text
_ (Just (Range (Int, Int)
left (Int, Int)
right)) Text
diagnosis) = do
let _range :: Maybe Range
_range = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Range
rangeToJSON ((Int, Int) -> (Int, Int) -> Range
Range (Int, Int)
left (Int, Int)
right))
encodedDiag :: String
encodedDiag = String -> String
URI.encode (Text -> String
Text.unpack Text
diagnosis)
_kind :: MarkupKind
_kind = MarkupKind
MkMarkdown
_value :: Text
_value =
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
HoverContents MarkupContent :: MarkupKind -> Text -> MarkupContent
MarkupContent{Text
MarkupKind
$sel:_kind:MarkupContent :: MarkupKind
$sel:_value:MarkupContent :: Text
_value :: Text
_kind :: MarkupKind
..}
Hover -> Maybe Hover
forall a. a -> Maybe a
Just Hover :: HoverContents -> Maybe Range -> Hover
Hover{ HoverContents
_contents :: HoverContents
$sel:_contents:Hover :: HoverContents
_contents, Maybe Range
_range :: Maybe Range
$sel:_range:Hover :: Maybe Range
_range }
hoverFromDiagnosis Diagnosis
_ =
Maybe Hover
forall a. Maybe a
Nothing
let mHover :: Maybe Hover
mHover = do
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
Either ResponseError (Maybe Hover)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond (Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right Maybe Hover
mHover)
documentLinkHandler :: Handlers HandlerM
documentLinkHandler :: Handlers HandlerM
documentLinkHandler =
SMethod 'TextDocumentDocumentLink
-> Handler HandlerM 'TextDocumentDocumentLink -> Handlers HandlerM
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'TextDocumentDocumentLink
STextDocumentDocumentLink \RequestMessage 'TextDocumentDocumentLink
request Either ResponseError (List DocumentLink)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond -> do
let uri_ :: Uri
uri_ = RequestMessage 'TextDocumentDocumentLink
requestRequestMessage 'TextDocumentDocumentLink
-> Getting Uri (RequestMessage 'TextDocumentDocumentLink) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^.(DocumentLinkParams -> Const Uri DocumentLinkParams)
-> RequestMessage 'TextDocumentDocumentLink
-> Const Uri (RequestMessage 'TextDocumentDocumentLink)
forall s a. HasParams s a => Lens' s a
params((DocumentLinkParams -> Const Uri DocumentLinkParams)
-> RequestMessage 'TextDocumentDocumentLink
-> Const Uri (RequestMessage 'TextDocumentDocumentLink))
-> ((Uri -> Const Uri Uri)
-> DocumentLinkParams -> Const Uri DocumentLinkParams)
-> Getting Uri (RequestMessage 'TextDocumentDocumentLink) 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
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
uri
String
path <- case Uri -> Maybe String
uriToFilePath Uri
uri_ of
Maybe String
Nothing ->
(Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 [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 _range :: Range
_range = Range -> Range
rangeToJSON Range
range_
let _target :: Maybe Uri
_target = Uri -> Maybe Uri
forall a. a -> Maybe a
Just (String -> Uri
filePathToUri String
filePath')
let _tooltip :: Maybe a
_tooltip = Maybe a
forall a. Maybe a
Nothing
let _xdata :: Maybe a
_xdata = Maybe a
forall a. Maybe a
Nothing
[DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Uri -> Maybe Text -> Maybe Value -> DocumentLink
DocumentLink {Maybe Text
Maybe Value
Maybe Uri
Range
forall a. Maybe a
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Uri
$sel:_tooltip:DocumentLink :: Maybe Text
$sel:_xdata:DocumentLink :: Maybe Value
_xdata :: forall a. Maybe a
_tooltip :: forall a. Maybe a
_target :: Maybe Uri
_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 Uri
_target = Uri -> Maybe Uri
forall a. a -> Maybe a
Just (Text -> Uri
Uri (URL -> Text
forall a. Pretty a => a -> Text
pretty URL
url'))
let _tooltip :: Maybe a
_tooltip = Maybe a
forall a. Maybe a
Nothing
let _xdata :: Maybe a
_xdata = Maybe a
forall a. Maybe a
Nothing
[DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentLink :: Range -> Maybe Uri -> Maybe Text -> Maybe Value -> DocumentLink
DocumentLink {Maybe Text
Maybe Value
Maybe Uri
Range
forall a. Maybe a
_xdata :: forall a. Maybe a
_tooltip :: forall a. Maybe a
_target :: Maybe Uri
_range :: Range
$sel:_range:DocumentLink :: Range
$sel:_target:DocumentLink :: Maybe Uri
$sel:_tooltip:DocumentLink :: Maybe Text
$sel:_xdata:DocumentLink :: Maybe Value
..}]
go (Range, Import)
_ = [DocumentLink] -> IO [DocumentLink]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[[DocumentLink]]
links <- IO [[DocumentLink]]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[[DocumentLink]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[DocumentLink]]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[[DocumentLink]])
-> IO [[DocumentLink]]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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
Either ResponseError (List DocumentLink)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond (List DocumentLink -> Either ResponseError (List DocumentLink)
forall a b. b -> Either a b
Right ([DocumentLink] -> List DocumentLink
forall a. [a] -> List a
List ([[DocumentLink]] -> [DocumentLink]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DocumentLink]]
links)))
diagnosticsHandler :: Uri -> HandlerM ()
diagnosticsHandler :: Uri
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
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)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Maybe DhallError)
-> (DhallError
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> (DhallError
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> ExceptT
DhallError
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT
DhallError
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError)
-> (DhallError
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig IO))
(Maybe DhallError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DhallError
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> (DhallError -> Maybe DhallError)
-> DhallError
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig IO))
(Maybe DhallError)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError))
-> ExceptT
DhallError
(StateT ServerState (LspT ServerConfig IO))
(Maybe DhallError)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
DhallError
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO)) WellTyped
forall (m :: * -> *) a. Monad m => a -> m a
return WellTyped
wt
Left DhallError
err -> DhallError
-> ExceptT
DhallError (StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 { range :: Suggestion -> Range
range = Range
range_, Text
suggestion :: Suggestion -> Text
suggestion :: Text
.. } =
let _range :: Range
_range = Range -> Range
rangeToJSON Range
range_
_severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
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 (Int32 |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
Diagnostic {Maybe Text
Maybe DiagnosticSeverity
Maybe (Int32 |? Text)
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 (Int32 |? Text)
$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 { range :: Diagnosis -> Maybe Range
range = Maybe Range
range_, Text
diagnosis :: Diagnosis -> Text
doctor :: Diagnosis -> Text
diagnosis :: Text
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
LSP.Types.Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
0)
_severity :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
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 (Int32 |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
Diagnostic {Maybe Text
Maybe DiagnosticSeverity
Maybe (Int32 |? Text)
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 (Int32 |? Text)
$sel:_source:Diagnostic :: Maybe Text
$sel:_message:Diagnostic :: Text
$sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
..}
ASetter
ServerState ServerState (Map Uri DhallError) (Map Uri DhallError)
-> (Map Uri DhallError -> Map Uri DhallError)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
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)
let _version :: Maybe a
_version = Maybe a
forall a. Maybe a
Nothing
let _diagnostics :: List Diagnostic
_diagnostics =
[Diagnostic] -> List Diagnostic
forall a. [a] -> List a
List
( (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
)
LspT ServerConfig IO ()
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (SServerMethod 'TextDocumentPublishDiagnostics
-> MessageParams 'TextDocumentPublishDiagnostics
-> LspT ServerConfig IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics PublishDiagnosticsParams :: Uri -> Maybe UInt -> List Diagnostic -> PublishDiagnosticsParams
PublishDiagnosticsParams{ Uri
$sel:_uri:PublishDiagnosticsParams :: Uri
_uri :: Uri
_uri, Maybe UInt
forall a. Maybe a
$sel:_version:PublishDiagnosticsParams :: Maybe UInt
_version :: forall a. Maybe a
_version, List Diagnostic
$sel:_diagnostics:PublishDiagnosticsParams :: List Diagnostic
_diagnostics :: List Diagnostic
_diagnostics })
documentFormattingHandler :: Handlers HandlerM
documentFormattingHandler :: Handlers HandlerM
documentFormattingHandler =
SMethod 'TextDocumentFormatting
-> Handler HandlerM 'TextDocumentFormatting -> Handlers HandlerM
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'TextDocumentFormatting
STextDocumentFormatting \RequestMessage 'TextDocumentFormatting
request Either ResponseError (List TextEdit)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond -> do
let _uri :: Uri
_uri = RequestMessage 'TextDocumentFormatting
requestRequestMessage 'TextDocumentFormatting
-> Getting Uri (RequestMessage 'TextDocumentFormatting) Uri -> Uri
forall s a. s -> Getting a s a -> a
^.(DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> RequestMessage 'TextDocumentFormatting
-> Const Uri (RequestMessage 'TextDocumentFormatting)
forall s a. HasParams s a => Lens' s a
params((DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> RequestMessage 'TextDocumentFormatting
-> Const Uri (RequestMessage 'TextDocumentFormatting))
-> ((Uri -> Const Uri Uri)
-> DocumentFormattingParams -> Const Uri DocumentFormattingParams)
-> Getting Uri (RequestMessage 'TextDocumentFormatting) 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
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
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 (LspT ServerConfig 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 (LspT ServerConfig 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
..} <- LspT ServerConfig IO ServerConfig -> HandlerM ServerConfig
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP LspT ServerConfig IO ServerConfig
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig
let numLines :: UInt
numLines = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length Text
txt)
let _newText :: Text
_newText= 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
let _range :: Range
_range = Position -> Position -> Range
LSP.Types.Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
numLines UInt
0)
Either ResponseError (List TextEdit)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond (List TextEdit -> Either ResponseError (List TextEdit)
forall a b. b -> Either a b
Right ([TextEdit] -> List TextEdit
forall a. [a] -> List a
List [TextEdit :: Range -> Text -> TextEdit
TextEdit{Text
Range
$sel:_range:TextEdit :: Range
$sel:_newText:TextEdit :: Text
_range :: Range
_newText :: Text
..}]))
executeCommandHandler :: Handlers HandlerM
executeCommandHandler :: Handlers HandlerM
executeCommandHandler =
SMethod 'WorkspaceExecuteCommand
-> Handler HandlerM 'WorkspaceExecuteCommand -> Handlers HandlerM
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'WorkspaceExecuteCommand
SWorkspaceExecuteCommand \RequestMessage 'WorkspaceExecuteCommand
request Either ResponseError Value
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond -> do
let command_ :: Text
command_ = RequestMessage 'WorkspaceExecuteCommand
requestRequestMessage 'WorkspaceExecuteCommand
-> Getting Text (RequestMessage 'WorkspaceExecuteCommand) Text
-> Text
forall s a. s -> Getting a s a -> a
^.(ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> RequestMessage 'WorkspaceExecuteCommand
-> Const Text (RequestMessage 'WorkspaceExecuteCommand)
forall s a. HasParams s a => Lens' s a
params((ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> RequestMessage 'WorkspaceExecuteCommand
-> Const Text (RequestMessage 'WorkspaceExecuteCommand))
-> ((Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting Text (RequestMessage 'WorkspaceExecuteCommand) 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
command
if | Text
command_ Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.lint" ->
RequestMessage 'WorkspaceExecuteCommand
-> (Either ResponseError Value
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ())
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall a b.
RequestMessage 'WorkspaceExecuteCommand
-> (Either a Value -> HandlerM b)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeLintAndFormat RequestMessage 'WorkspaceExecuteCommand
request Either ResponseError Value
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond
| Text
command_ Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.annotateLet" ->
RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeAnnotateLet RequestMessage 'WorkspaceExecuteCommand
request
| Text
command_ Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeImport" ->
RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeFreezeImport RequestMessage 'WorkspaceExecuteCommand
request
| Text
command_ Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dhall.server.freezeAllImports" ->
RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeFreezeAllImports RequestMessage 'WorkspaceExecuteCommand
request
| Bool
otherwise -> do
(Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
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."
)
getCommandArguments
:: FromJSON a => RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments :: RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments RequestMessage 'WorkspaceExecuteCommand
request = do
Value
json <- case RequestMessage 'WorkspaceExecuteCommand
request RequestMessage 'WorkspaceExecuteCommand
-> Getting
(Maybe (List Value))
(RequestMessage 'WorkspaceExecuteCommand)
(Maybe (List Value))
-> Maybe (List Value)
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> RequestMessage 'WorkspaceExecuteCommand
-> Const
(Maybe (List Value)) (RequestMessage 'WorkspaceExecuteCommand)
forall s a. HasParams s a => Lens' s a
params ((ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> RequestMessage 'WorkspaceExecuteCommand
-> Const
(Maybe (List Value)) (RequestMessage 'WorkspaceExecuteCommand))
-> ((Maybe (List Value)
-> Const (Maybe (List Value)) (Maybe (List Value)))
-> ExecuteCommandParams
-> Const (Maybe (List Value)) ExecuteCommandParams)
-> Getting
(Maybe (List Value))
(RequestMessage 'WorkspaceExecuteCommand)
(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
arguments of
Just (List (Value
x : [Value]
_)) -> Value
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
Maybe (List Value)
_ -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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
Aeson.fromJSON Value
json of
Aeson.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
:: RequestMessage 'WorkspaceExecuteCommand
-> (Either a Value -> HandlerM b)
-> HandlerM ()
executeLintAndFormat :: RequestMessage 'WorkspaceExecuteCommand
-> (Either a Value -> HandlerM b)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeLintAndFormat RequestMessage 'WorkspaceExecuteCommand
request Either a Value -> HandlerM b
respond = do
Uri
uri_ <- RequestMessage 'WorkspaceExecuteCommand -> HandlerM Uri
forall a.
FromJSON a =>
RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments RequestMessage 'WorkspaceExecuteCommand
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 (LspT ServerConfig 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 (LspT ServerConfig 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
..} <- LspT ServerConfig IO ServerConfig -> HandlerM ServerConfig
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP LspT ServerConfig IO ServerConfig
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig
let numLines :: UInt
numLines = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length Text
txt)
let _newText :: Text
_newText = 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
let _range :: Range
_range = Position -> Position -> Range
LSP.Types.Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
numLines UInt
0)
let _edit :: WorkspaceEdit
_edit =
WorkspaceEdit :: Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
{ $sel:_changes:WorkspaceEdit :: Maybe WorkspaceEditMap
_changes = 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
List [TextEdit :: Range -> Text -> TextEdit
TextEdit{Text
Range
_range :: Range
_newText :: Text
$sel:_range:TextEdit :: Range
$sel:_newText:TextEdit :: Text
..}]))
, $sel:_documentChanges:WorkspaceEdit :: Maybe (List DocumentChange)
_documentChanges = Maybe (List DocumentChange)
forall a. Maybe a
Nothing
, $sel:_changeAnnotations:WorkspaceEdit :: Maybe ChangeAnnotationMap
_changeAnnotations = Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing
}
let _label :: Maybe a
_label = Maybe a
forall a. Maybe a
Nothing
b
_ <- Either a Value -> HandlerM b
respond (Value -> Either a Value
forall a b. b -> Either a b
Right Value
Aeson.Null)
LspId 'WorkspaceApplyEdit
_ <- LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
-> HandlerM (LspId 'WorkspaceApplyEdit)
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ())
-> LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit ApplyWorkspaceEditParams :: Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams{ Maybe Text
forall a. Maybe a
$sel:_label:ApplyWorkspaceEditParams :: Maybe Text
_label :: forall a. Maybe a
_label, WorkspaceEdit
$sel:_edit:ApplyWorkspaceEditParams :: WorkspaceEdit
_edit :: WorkspaceEdit
_edit } Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ()
forall a. a -> LspT ServerConfig IO ()
nullHandler)
()
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
executeAnnotateLet
:: RequestMessage 'WorkspaceExecuteCommand
-> HandlerM ()
executeAnnotateLet :: RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeAnnotateLet RequestMessage 'WorkspaceExecuteCommand
request = do
TextDocumentPositionParams
args <- RequestMessage 'WorkspaceExecuteCommand
-> HandlerM TextDocumentPositionParams
forall a.
FromJSON a =>
RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments RequestMessage 'WorkspaceExecuteCommand
request :: HandlerM TextDocumentPositionParams
let uri_ :: Uri
uri_ = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Uri TextDocumentPositionParams Uri -> 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
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri TextDocumentPositionParams Uri
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
uri
line_ :: Int
line_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting UInt TextDocumentPositionParams UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt TextDocumentPositionParams UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
line)
col_ :: Int
col_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting UInt TextDocumentPositionParams UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt TextDocumentPositionParams UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasCharacter s a => Lens' s a
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 (LspT ServerConfig 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 (LspT ServerConfig 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
..} <- LspT ServerConfig IO ServerConfig -> HandlerM ServerConfig
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP LspT ServerConfig IO ServerConfig
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig
(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 (LspT ServerConfig 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 (LspT ServerConfig 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
LSP.Types.Range (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int
unPos Pos
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int
unPos Pos
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
(UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int
unPos Pos
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int
unPos Pos
y2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
let _newText :: Text
_newText= Maybe CharacterSet -> Expr Src Void -> Text
forall b. Pretty b => Maybe CharacterSet -> Expr Src b -> Text
formatExpr Maybe CharacterSet
chosenCharacterSet Expr Src Void
annotExpr
let _edit :: WorkspaceEdit
_edit = WorkspaceEdit :: Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
{ $sel:_changes:WorkspaceEdit :: Maybe WorkspaceEditMap
_changes = 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
List [TextEdit :: Range -> Text -> TextEdit
TextEdit{Text
Range
_newText :: Text
_range :: Range
$sel:_range:TextEdit :: Range
$sel:_newText:TextEdit :: Text
..}]))
, $sel:_documentChanges:WorkspaceEdit :: Maybe (List DocumentChange)
_documentChanges = Maybe (List DocumentChange)
forall a. Maybe a
Nothing
, $sel:_changeAnnotations:WorkspaceEdit :: Maybe ChangeAnnotationMap
_changeAnnotations = Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing
}
let _label :: Maybe a
_label = Maybe a
forall a. Maybe a
Nothing
LspId 'WorkspaceApplyEdit
_ <- LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
-> HandlerM (LspId 'WorkspaceApplyEdit)
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ())
-> LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit ApplyWorkspaceEditParams :: Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams{ Maybe Text
forall a. Maybe a
_label :: forall a. Maybe a
$sel:_label:ApplyWorkspaceEditParams :: Maybe Text
_label, WorkspaceEdit
_edit :: WorkspaceEdit
$sel:_edit:ApplyWorkspaceEditParams :: WorkspaceEdit
_edit } Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ()
forall a. a -> LspT ServerConfig IO ()
nullHandler)
()
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
executeFreezeAllImports
:: RequestMessage 'WorkspaceExecuteCommand
-> HandlerM ()
executeFreezeAllImports :: RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeFreezeAllImports RequestMessage 'WorkspaceExecuteCommand
request = do
Uri
uri_ <- RequestMessage 'WorkspaceExecuteCommand -> HandlerM Uri
forall a.
FromJSON a =>
RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments RequestMessage 'WorkspaceExecuteCommand
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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
TextEdit)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig IO))
TextEdit)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[TextEdit])
-> ((Import, Range)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
TextEdit)
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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'
let _range :: Range
_range = Position -> Position -> Range
LSP.Types.Range (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y1)) (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x2) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y2))
let _newText :: Text
_newText = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
TextEdit
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
TextEdit
forall (m :: * -> *) a. Monad m => a -> m a
return TextEdit :: Range -> Text -> TextEdit
TextEdit{Text
Range
_newText :: Text
_range :: Range
$sel:_range:TextEdit :: Range
$sel:_newText:TextEdit :: Text
..}
let _edit :: WorkspaceEdit
_edit = WorkspaceEdit :: Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
{ $sel:_changes:WorkspaceEdit :: Maybe WorkspaceEditMap
_changes = 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
List [TextEdit]
edits_))
, $sel:_documentChanges:WorkspaceEdit :: Maybe (List DocumentChange)
_documentChanges = Maybe (List DocumentChange)
forall a. Maybe a
Nothing
, $sel:_changeAnnotations:WorkspaceEdit :: Maybe ChangeAnnotationMap
_changeAnnotations = Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing
}
let _label :: Maybe a
_label = Maybe a
forall a. Maybe a
Nothing
LspId 'WorkspaceApplyEdit
_ <- LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
-> HandlerM (LspId 'WorkspaceApplyEdit)
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ())
-> LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit ApplyWorkspaceEditParams :: Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams{ WorkspaceEdit
_edit :: WorkspaceEdit
$sel:_edit:ApplyWorkspaceEditParams :: WorkspaceEdit
_edit, Maybe Text
forall a. Maybe a
_label :: forall a. Maybe a
$sel:_label:ApplyWorkspaceEditParams :: Maybe Text
_label } Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ()
forall a. a -> LspT ServerConfig IO ()
nullHandler)
()
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
executeFreezeImport
:: RequestMessage 'WorkspaceExecuteCommand
-> HandlerM ()
executeFreezeImport :: RequestMessage 'WorkspaceExecuteCommand
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
executeFreezeImport RequestMessage 'WorkspaceExecuteCommand
request = do
TextDocumentPositionParams
args <- RequestMessage 'WorkspaceExecuteCommand
-> HandlerM TextDocumentPositionParams
forall a.
FromJSON a =>
RequestMessage 'WorkspaceExecuteCommand -> HandlerM a
getCommandArguments RequestMessage 'WorkspaceExecuteCommand
request :: HandlerM TextDocumentPositionParams
let uri_ :: Uri
uri_ = TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting Uri TextDocumentPositionParams Uri -> 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
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> TextDocumentPositionParams
-> Const Uri TextDocumentPositionParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri TextDocumentPositionParams Uri
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
uri
let line_ :: Int
line_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting UInt TextDocumentPositionParams UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt TextDocumentPositionParams UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
line)
let col_ :: Int
col_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TextDocumentPositionParams
args TextDocumentPositionParams
-> Getting UInt TextDocumentPositionParams UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> TextDocumentPositionParams
-> Const UInt TextDocumentPositionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt TextDocumentPositionParams UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasCharacter s a => Lens' s a
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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO)) Range
forall (m :: * -> *) a. Monad m => a -> m a
return Range
range_
Maybe Range
Nothing -> (Severity, Text)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Text)))
-> IO (Either DhallError (Cache, Text))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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'
let _range :: Range
_range = Position -> Position -> Range
LSP.Types.Range (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y1)) (UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x2) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y2))
let _newText :: Text
_newText = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
let _edit :: WorkspaceEdit
_edit = WorkspaceEdit :: Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
{ $sel:_changes:WorkspaceEdit :: Maybe WorkspaceEditMap
_changes = 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
List [TextEdit :: Range -> Text -> TextEdit
TextEdit{Text
Range
_newText :: Text
_range :: Range
$sel:_range:TextEdit :: Range
$sel:_newText:TextEdit :: Text
..}]))
, $sel:_documentChanges:WorkspaceEdit :: Maybe (List DocumentChange)
_documentChanges = Maybe (List DocumentChange)
forall a. Maybe a
Nothing
, $sel:_changeAnnotations:WorkspaceEdit :: Maybe ChangeAnnotationMap
_changeAnnotations = Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing
}
let _label :: Maybe a
_label = Maybe a
forall a. Maybe a
Nothing
LspId 'WorkspaceApplyEdit
_ <- LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
-> HandlerM (LspId 'WorkspaceApplyEdit)
forall a. LspT ServerConfig IO a -> HandlerM a
liftLSP (SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ())
-> LspT ServerConfig IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit ApplyWorkspaceEditParams :: Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams{ WorkspaceEdit
_edit :: WorkspaceEdit
$sel:_edit:ApplyWorkspaceEditParams :: WorkspaceEdit
_edit, Maybe Text
forall a. Maybe a
_label :: forall a. Maybe a
$sel:_label:ApplyWorkspaceEditParams :: Maybe Text
_label } Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT ServerConfig IO ()
forall a. a -> LspT ServerConfig IO ()
nullHandler)
()
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
completionHandler :: Handlers HandlerM
completionHandler :: Handlers HandlerM
completionHandler =
SMethod 'TextDocumentCompletion
-> Handler HandlerM 'TextDocumentCompletion -> Handlers HandlerM
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'TextDocumentCompletion
STextDocumentCompletion \RequestMessage 'TextDocumentCompletion
request Either ResponseError (List CompletionItem |? CompletionList)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond -> do
let uri_ :: Uri
uri_ = RequestMessage 'TextDocumentCompletion
request RequestMessage 'TextDocumentCompletion
-> Getting Uri (RequestMessage 'TextDocumentCompletion) Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const Uri CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const Uri (RequestMessage 'TextDocumentCompletion)
forall s a. HasParams s a => Lens' s a
params ((CompletionParams -> Const Uri CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const Uri (RequestMessage 'TextDocumentCompletion))
-> ((Uri -> Const Uri Uri)
-> CompletionParams -> Const Uri CompletionParams)
-> Getting Uri (RequestMessage 'TextDocumentCompletion) 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
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
uri
line_ :: Int
line_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RequestMessage 'TextDocumentCompletion
request RequestMessage 'TextDocumentCompletion
-> Getting UInt (RequestMessage 'TextDocumentCompletion) UInt
-> UInt
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const UInt CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const UInt (RequestMessage 'TextDocumentCompletion)
forall s a. HasParams s a => Lens' s a
params ((CompletionParams -> Const UInt CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const UInt (RequestMessage 'TextDocumentCompletion))
-> ((UInt -> Const UInt UInt)
-> CompletionParams -> Const UInt CompletionParams)
-> Getting UInt (RequestMessage 'TextDocumentCompletion) UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const UInt Position)
-> CompletionParams -> Const UInt CompletionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> CompletionParams -> Const UInt CompletionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> (UInt -> Const UInt UInt)
-> CompletionParams
-> Const UInt CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
line)
col_ :: Int
col_ = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RequestMessage 'TextDocumentCompletion
request RequestMessage 'TextDocumentCompletion
-> Getting UInt (RequestMessage 'TextDocumentCompletion) UInt
-> UInt
forall s a. s -> Getting a s a -> a
^. (CompletionParams -> Const UInt CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const UInt (RequestMessage 'TextDocumentCompletion)
forall s a. HasParams s a => Lens' s a
params ((CompletionParams -> Const UInt CompletionParams)
-> RequestMessage 'TextDocumentCompletion
-> Const UInt (RequestMessage 'TextDocumentCompletion))
-> ((UInt -> Const UInt UInt)
-> CompletionParams -> Const UInt CompletionParams)
-> Getting UInt (RequestMessage 'TextDocumentCompletion) UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const UInt Position)
-> CompletionParams -> Const UInt CompletionParams
forall s a. HasPosition s a => Lens' s a
position ((Position -> Const UInt Position)
-> CompletionParams -> Const UInt CompletionParams)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> (UInt -> Const UInt UInt)
-> CompletionParams
-> Const UInt CompletionParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasCharacter s a => Lens' s a
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 (LspT ServerConfig IO))
[Completion]
computeCompletions
| Text
"env:" Text -> Text -> Bool
`isPrefixOf` Text
completionPrefix =
IO [Completion]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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
uriToFilePath Uri
uri_ = String
path
| Bool
otherwise = String
"."
IO [Completion]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Completion]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[Completion])
-> IO [Completion]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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''
[Completion]
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig 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 (LspT ServerConfig IO))
(Either DhallError (Cache, Expr Src Void)))
-> IO (Either DhallError (Cache, Expr Src Void))
-> ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig 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
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig 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'
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 (LspT ServerConfig IO))
[Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionContext -> [Completion]
completeFromContext CompletionContext
context_)
[Completion]
completions <- ExceptT
(Severity, Text)
(StateT ServerState (LspT ServerConfig IO))
[Completion]
computeCompletions
let toCompletionItem :: Completion -> CompletionItem
toCompletionItem (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 InsertTextMode
-> Maybe CompletionEdit
-> Maybe (List TextEdit)
-> Maybe (List Text)
-> Maybe Command
-> Maybe Value
-> CompletionItem
CompletionItem {Maybe Bool
Maybe Text
Maybe Value
Maybe CompletionEdit
Maybe InsertTextFormat
Maybe CompletionDoc
Maybe InsertTextMode
Maybe CompletionItemKind
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:_insertTextMode:CompletionItem :: Maybe InsertTextMode
$sel:_textEdit:CompletionItem :: Maybe CompletionEdit
$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
_insertTextMode :: 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
_insertTextMode :: Maybe a
_insertTextMode = 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
let _items :: List CompletionItem
_items = [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ((Completion -> CompletionItem) -> [Completion] -> [CompletionItem]
forall a b. (a -> b) -> [a] -> [b]
map Completion -> CompletionItem
toCompletionItem [Completion]
completions)
let _isIncomplete :: Bool
_isIncomplete = Bool
False
Either ResponseError (List CompletionItem |? CompletionList)
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
respond ((List CompletionItem |? CompletionList)
-> Either ResponseError (List CompletionItem |? CompletionList)
forall a b. b -> Either a b
Right (CompletionList -> List CompletionItem |? CompletionList
forall a b. b -> a |? b
InR CompletionList :: Bool -> List CompletionItem -> CompletionList
CompletionList{Bool
List CompletionItem
$sel:_isIncomplete:CompletionList :: Bool
$sel:_items:CompletionList :: List CompletionItem
_isIncomplete :: Bool
_items :: List CompletionItem
..}))
nullHandler :: a -> LspT ServerConfig IO ()
nullHandler :: a -> LspT ServerConfig IO ()
nullHandler a
_ = () -> LspT ServerConfig IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
didOpenTextDocumentNotificationHandler :: Handlers HandlerM
didOpenTextDocumentNotificationHandler :: Handlers HandlerM
didOpenTextDocumentNotificationHandler =
SMethod 'TextDocumentDidOpen
-> Handler HandlerM 'TextDocumentDidOpen -> Handlers HandlerM
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'TextDocumentDidOpen
STextDocumentDidOpen \NotificationMessage 'TextDocumentDidOpen
notification -> do
let _uri :: Uri
_uri = NotificationMessage 'TextDocumentDidOpen
notificationNotificationMessage 'TextDocumentDidOpen
-> Getting Uri (NotificationMessage 'TextDocumentDidOpen) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^.(DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> NotificationMessage 'TextDocumentDidOpen
-> Const Uri (NotificationMessage 'TextDocumentDidOpen)
forall s a. HasParams s a => Lens' s a
params((DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> NotificationMessage 'TextDocumentDidOpen
-> Const Uri (NotificationMessage 'TextDocumentDidOpen))
-> ((Uri -> Const Uri Uri)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams)
-> Getting Uri (NotificationMessage 'TextDocumentDidOpen) 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
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
uri
Uri
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
diagnosticsHandler Uri
_uri
didSaveTextDocumentNotificationHandler :: Handlers HandlerM
didSaveTextDocumentNotificationHandler :: Handlers HandlerM
didSaveTextDocumentNotificationHandler =
SMethod 'TextDocumentDidSave
-> Handler HandlerM 'TextDocumentDidSave -> Handlers HandlerM
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'TextDocumentDidSave
STextDocumentDidSave \NotificationMessage 'TextDocumentDidSave
notification -> do
let _uri :: Uri
_uri = NotificationMessage 'TextDocumentDidSave
notificationNotificationMessage 'TextDocumentDidSave
-> Getting Uri (NotificationMessage 'TextDocumentDidSave) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^.(DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> NotificationMessage 'TextDocumentDidSave
-> Const Uri (NotificationMessage 'TextDocumentDidSave)
forall s a. HasParams s a => Lens' s a
params((DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> NotificationMessage 'TextDocumentDidSave
-> Const Uri (NotificationMessage 'TextDocumentDidSave))
-> ((Uri -> Const Uri Uri)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams)
-> Getting Uri (NotificationMessage 'TextDocumentDidSave) 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
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
uri
Uri
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) ()
diagnosticsHandler Uri
_uri