dhall-lsp-server 1.0.18 → 1.1.0
raw patch · 6 files changed
+498/−468 lines, 6 filesdep +lspdep +lsp-typesdep −haskell-lspdep −haskell-lsp-typesdep ~lsp-test
Dependencies added: lsp, lsp-types
Dependencies removed: haskell-lsp, haskell-lsp-types
Dependency ranges changed: lsp-test
Files
- dhall-lsp-server.cabal +8/−8
- src/Dhall/LSP/Backend/Dhall.hs +10/−10
- src/Dhall/LSP/Handlers.hs +372/−354
- src/Dhall/LSP/Server.hs +100/−79
- src/Dhall/LSP/State.hs +6/−15
- tests/Main.hs +2/−2
dhall-lsp-server.cabal view
@@ -1,5 +1,5 @@ name: dhall-lsp-server-Version: 1.0.18+Version: 1.1.0 cabal-version: 1.12 synopsis: Language Server Protocol (LSP) server for Dhall homepage: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-lsp-server#readme@@ -52,7 +52,7 @@ , dhall >= 1.38.0 && < 1.42 , dhall-json >= 1.4 && < 1.8 , filepath >= 1.4.2 && < 1.5- , haskell-lsp >= 0.21.0.0 && < 0.25+ , lsp >= 1.2.0.0 && < 1.5 , rope-utf16-splay >= 0.3.1.0 && < 0.4 , hslogger >= 1.2.10 && < 1.4 , lens >= 4.16.1 && < 5.2@@ -104,11 +104,11 @@ GHC-Options: -Wall Build-Depends: base ,- haskell-lsp-types >= 0.19.0 && < 0.25 ,- hspec >= 2.7 && < 2.10 ,- lsp-test >= 0.9 && < 0.13 ,- tasty >= 0.11.2 && < 1.5 ,- tasty-hspec >= 1.1 && < 1.3 ,- text >= 0.11 && < 1.3+ lsp-types >= 1.2.0.0 && < 1.5 ,+ hspec >= 2.7 && < 2.10 ,+ lsp-test >= 0.13.0.0 && < 0.15 ,+ tasty >= 0.11.2 && < 1.5 ,+ tasty-hspec >= 1.1 && < 1.3 ,+ text >= 0.11 && < 1.3 Build-Tool-Depends: dhall-lsp-server:dhall-lsp-server Default-Language: Haskell2010
src/Dhall/LSP/Backend/Dhall.hs view
@@ -35,17 +35,17 @@ , takeFileName ) -import qualified Data.Graph as Graph-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text as Text-import qualified Dhall.Core as Dhall-import qualified Dhall.Import as Dhall+import qualified Data.Graph as Graph+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Dhall.Core as Dhall+import qualified Dhall.Import as Dhall import qualified Dhall.Map-import qualified Dhall.Parser as Dhall-import qualified Dhall.TypeCheck as Dhall-import qualified Language.Haskell.LSP.Types as LSP.Types-import qualified Network.URI as URI+import qualified Dhall.Parser as Dhall+import qualified Dhall.TypeCheck as Dhall+import qualified Language.LSP.Types as LSP.Types+import qualified Network.URI as URI -- | A @FileIdentifier@ represents either a local file or a remote url.
src/Dhall/LSP/Handlers.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiWayIf #-} module Dhall.LSP.Handlers where @@ -55,104 +58,45 @@ import Dhall.LSP.State import Control.Applicative ((<|>))-import Control.Concurrent.MVar-import Control.Lens (assign, modifying, use, uses, (^.))+import Control.Lens (assign, modifying, use, (^.)) import Control.Monad (forM, guard)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Except (catchE, runExceptT, throwE)-import Control.Monad.Trans.State.Strict (execStateT)-import Data.Default (def)+import 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 J-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map.Strict as Map-import qualified Data.Rope.UTF16 as Rope-import qualified Data.Text as Text-import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as J-import qualified Language.Haskell.LSP.Types.Lens as J-import qualified Language.Haskell.LSP.VFS as LSP-import qualified Network.URI as URI-import qualified Network.URI.Encode as URI----- Workaround to make our single-threaded LSP fit dhall-lsp's API, which--- expects a multi-threaded implementation. Reports errors to the user via the--- LSP `ShowMessage` notification.-wrapHandler- :: MVar ServerState- -> (a -> HandlerM ())- -> a- -> IO ()-wrapHandler vstate handle message =- modifyMVar_ vstate $- execStateT . runExceptT $- catchE (handle message) lspUserMessage--getServerConfig :: HandlerM ServerConfig-getServerConfig = do- lsp <- use lspFuncs- mConfig <- liftIO (LSP.config lsp)- case mConfig of- Just config -> return config- Nothing -> return def--lspUserMessage :: (Severity, Text) -> HandlerM ()-lspUserMessage (Log, text) =- lspSendNotification LSP.NotLogMessage J.WindowLogMessage- $ J.LogMessageParams J.MtLog text-lspUserMessage (severity, text) =- lspSendNotification LSP.NotShowMessage J.WindowShowMessage- $ J.ShowMessageParams severity' text- where severity' = case severity of- Error -> J.MtError- Warning -> J.MtWarning- Info -> J.MtInfo- Log -> J.MtLog---lspSend :: LSP.FromServerMessage -> HandlerM ()-lspSend msg = do- send <- use (lspFuncs . sendFunc)- liftIO $ send msg--lspRespond :: (J.ResponseMessage response -> LSP.FromServerMessage)- -> J.RequestMessage J.ClientMethod request response -> response -> HandlerM ()-lspRespond constructor request response =- lspSend . constructor $ LSP.makeResponseMessage request response--lspSendNotification- :: (J.NotificationMessage J.ServerMethod params -> LSP.FromServerMessage)- -> J.ServerMethod -> params -> HandlerM ()-lspSendNotification constructor method params =- lspSend . constructor $ J.NotificationMessage "2.0" method params+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 -lspRequest- :: (J.RequestMessage J.ServerMethod params response -> LSP.FromServerMessage)- -> J.ServerMethod -> params -> HandlerM ()-lspRequest constructor method params = do- getNextReqId <- uses lspFuncs LSP.getNextReqId- reqId <- liftIO getNextReqId- lspSend . constructor $ J.RequestMessage "2.0" reqId method params+liftLSP :: LspT ServerConfig IO a -> HandlerM a+liftLSP m = lift (lift m) -- | A helper function to query haskell-lsp's VFS.-readUri :: J.Uri -> HandlerM Text-readUri uri = do- getVirtualFileFunc <- uses lspFuncs LSP.getVirtualFileFunc- mVirtualFile <- liftIO $ getVirtualFileFunc (J.toNormalizedUri uri)+readUri :: Uri -> HandlerM Text+readUri uri_ = do+ mVirtualFile <- liftLSP (LSP.getVirtualFile (LSP.Types.toNormalizedUri uri_)) case mVirtualFile of Just (LSP.VirtualFile _ _ rope) -> return (Rope.toText rope)- Nothing -> fail $ "Could not find " <> show uri <> " in VFS."+ Nothing -> throwE (Error, "Could not find " <> Text.pack (show uri_) <> " in VFS.") -loadFile :: J.Uri -> HandlerM (Expr Src Void)-loadFile uri = do- txt <- readUri uri- fileIdentifier <- fileIdentifierFromUri uri+loadFile :: Uri -> HandlerM (Expr Src Void)+loadFile uri_ = do+ txt <- readUri uri_+ fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache expr <- case parse txt of@@ -169,109 +113,124 @@ return expr' -- helper-fileIdentifierFromUri :: J.Uri -> HandlerM FileIdentifier-fileIdentifierFromUri uri =- let mFileIdentifier = fmap fileIdentifierFromFilePath (J.uriToFilePath uri)- <|> (do uri' <- (URI.parseURI . Text.unpack . J.getUri) uri+fileIdentifierFromUri :: Uri -> HandlerM FileIdentifier+fileIdentifierFromUri uri_ =+ let mFileIdentifier = fmap fileIdentifierFromFilePath (uriToFilePath uri_)+ <|> (do uri' <- (URI.parseURI . Text.unpack . getUri) uri_ fileIdentifierFromURI uri') in case mFileIdentifier of Just fileIdentifier -> return fileIdentifier- Nothing -> throwE (Error, J.getUri uri <> " is not a valid name for a dhall file.")+ Nothing -> throwE (Error, getUri uri_ <> " is not a valid name for a dhall file.") -- helper-rangeToJSON :: Range -> J.Range-rangeToJSON (Range (x1,y1) (x2,y2)) = J.Range (J.Position x1 y1) (J.Position x2 y2)+rangeToJSON :: Range -> LSP.Types.Range+rangeToJSON (Range (x1,y1) (x2,y2)) =+ LSP.Types.Range (Position x1 y1) (Position x2 y2) -hoverExplain :: J.HoverRequest -> HandlerM ()-hoverExplain request = do- let uri = request ^. J.params . J.textDocument . J.uri- J.Position line col = request ^. J.params . J.position- mError <- uses errors $ Map.lookup uri- let isHovered (Diagnosis _ (Just (Range left right)) _) =- left <= (line,col) && (line,col) <= right- isHovered _ = False+hoverHandler :: Handlers HandlerM+hoverHandler =+ LSP.requestHandler STextDocumentHover \request respond -> do+ let uri_ = request^.params.textDocument.uri - hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) =- let _range = Just $ J.Range (uncurry J.Position left)- (uncurry J.Position right)- encodedDiag = URI.encode (Text.unpack diagnosis)- command = "[Explain error](dhall-explain:?"- <> Text.pack encodedDiag <> " )"- _contents = J.HoverContents $ J.MarkupContent J.MkMarkdown command- in Just J.Hover { .. }- hoverFromDiagnosis _ = Nothing+ let Position{ _line, _character } = request^.params.position - mHover = do err <- mError- explanation <- explain err- guard (isHovered explanation)- hoverFromDiagnosis explanation- lspRespond LSP.RspHover request mHover+ errorMap <- use errors -hoverType :: J.HoverRequest -> HandlerM ()-hoverType request = do- let uri = request ^. J.params . J.textDocument . J.uri- J.Position line col = request ^. J.params . J.position- expr <- loadFile uri- (welltyped, _) <- case typecheck expr of- Left _ -> throwE (Info, "Can't infer type; code does not type-check.")- Right wt -> return wt- case typeAt (line,col) welltyped of- Left err -> throwE (Error, Text.pack err)- Right (mSrc, typ) ->- let _range = fmap (rangeToJSON . rangeFromDhall) mSrc- _contents = J.HoverContents $ J.MarkupContent J.MkPlainText (pretty typ)- hover = J.Hover{..}- in lspRespond LSP.RspHover request (Just hover)+ case Map.lookup uri_ errorMap of+ Nothing -> do+ expr <- loadFile uri_+ (welltyped, _) <- case typecheck expr of+ Left _ -> throwE (Info, "Can't infer type; code does not type-check.")+ Right wt -> return wt+ case typeAt (_line, _character) welltyped of+ Left err -> throwE (Error, Text.pack err)+ Right (mSrc, typ) -> do+ let _range = fmap (rangeToJSON . rangeFromDhall) mSrc -hoverHandler :: J.HoverRequest -> HandlerM ()-hoverHandler request = do- let uri = request ^. J.params . J.textDocument . J.uri- errorMap <- use errors- case Map.lookup uri errorMap of- Nothing -> hoverType request- _ -> hoverExplain request+ let _contents = HoverContents (MarkupContent MkPlainText (pretty typ))+ respond (Right (Just Hover{ _contents, _range }))+ Just err -> do+ let isHovered (Diagnosis _ (Just (Range left right)) _) =+ left <= (_line, _character) && (_line, _character) <= right+ isHovered _ =+ False + let hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = do+ let _range = Just (rangeToJSON (Range left right))+ encodedDiag = URI.encode (Text.unpack diagnosis) -documentLinkHandler :: J.DocumentLinkRequest -> HandlerM ()-documentLinkHandler req = do- let uri = req ^. J.params . J.textDocument . J.uri- path <- case J.uriToFilePath uri of- Nothing -> throwE (Log, "Could not process document links; failed to convert URI to file path.")- Just p -> return p- txt <- readUri uri- expr <- case parse txt of- Right e -> return e- Left _ -> throwE (Log, "Could not process document links; did not parse.")+ _kind = MkMarkdown - let imports = embedsWithRanges expr :: [(Range, Import)]+ _value =+ "[Explain error](dhall-explain:?"+ <> Text.pack encodedDiag+ <> " )" - let basePath = takeDirectory path+ _contents = HoverContents MarkupContent{..}+ Just Hover{ _contents, _range }+ hoverFromDiagnosis _ =+ Nothing - let go :: (Range, Import) -> IO [J.DocumentLink]- go (range, Import (ImportHashed _ (Local prefix file)) _) = do- filePath <- localToPath prefix file- let filePath' = basePath </> filePath -- absolute file path- let url' = J.filePathToUri filePath'- let _range = rangeToJSON range- let _target = Just (J.getUri url')- return [J.DocumentLink {..}]+ let mHover = do+ explanation <- explain err - go (range, Import (ImportHashed _ (Remote url)) _) = do- let _range = rangeToJSON range- let url' = url { headers = Nothing }- let _target = Just (pretty url')- return [J.DocumentLink {..}]+ guard (isHovered explanation) - go _ = return []+ hoverFromDiagnosis explanation - links <- liftIO $ mapM go imports- lspRespond LSP.RspDocumentLink req (J.List (concat links))+ respond (Right mHover) +documentLinkHandler :: Handlers HandlerM+documentLinkHandler =+ LSP.requestHandler STextDocumentDocumentLink \request respond -> do+ let uri_ = request^.params.textDocument.uri -diagnosticsHandler :: J.Uri -> HandlerM ()-diagnosticsHandler uri = do- txt <- readUri uri- fileIdentifier <- fileIdentifierFromUri uri+ path <- case uriToFilePath uri_ of+ Nothing ->+ throwE (Log, "Could not process document links; failed to convert URI to file path.")+ Just p ->+ return p++ txt <- readUri uri_++ expr <- case parse txt of+ Right e ->+ return e+ Left _ ->+ throwE (Log, "Could not process document links; did not parse.")++ let imports = embedsWithRanges expr :: [(Range, Import)]++ let basePath = takeDirectory path++ let go :: (Range, Import) -> IO [DocumentLink]+ go (range_, Import (ImportHashed _ (Local prefix file)) _) = do+ filePath <- localToPath prefix file+ let filePath' = basePath </> filePath -- absolute file path+ let _range = rangeToJSON range_+ let _target = Just (filePathToUri filePath')+ let _tooltip = Nothing+ let _xdata = Nothing+ return [DocumentLink {..}]++ go (range_, Import (ImportHashed _ (Remote url)) _) = do+ let _range = rangeToJSON range_+ let url' = url { headers = Nothing }+ let _target = Just (Uri (pretty url'))+ let _tooltip = Nothing+ let _xdata = Nothing+ return [DocumentLink {..}]++ go _ = return []++ links <- liftIO $ mapM go imports+ respond (Right (List (concat links)))+++diagnosticsHandler :: Uri -> HandlerM ()+diagnosticsHandler _uri = do+ txt <- readUri _uri+ fileIdentifier <- fileIdentifierFromUri _uri -- make sure we don't keep a stale version around modifying importCache (invalidate fileIdentifier) cache <- use importCache@@ -295,140 +254,178 @@ Right expr -> suggest expr _ -> [] - suggestionToDiagnostic Suggestion {..} =- let _range = rangeToJSON range- _severity = Just J.DsHint+ suggestionToDiagnostic Suggestion { range = range_, .. } =+ let _range = rangeToJSON range_+ _severity = Just DsHint _source = Just "Dhall.Lint" _code = Nothing _message = suggestion _tags = Nothing _relatedInformation = Nothing- in J.Diagnostic {..}+ in Diagnostic {..} - diagnosisToDiagnostic Diagnosis {..} =- let _range = case range of- Just range' ->- rangeToJSON range'- Nothing -> J.Range (J.Position 0 0) (J.Position 0 0)- _severity = Just J.DsError+ diagnosisToDiagnostic Diagnosis { range = range_, .. } =+ let _range = case range_ of+ Just range' -> rangeToJSON range'+ Nothing -> LSP.Types.Range (Position 0 0) (Position 0 0)+ _severity = Just DsError _source = Just doctor _code = Nothing _tags = Nothing _message = diagnosis _relatedInformation = Nothing- in J.Diagnostic {..}+ in Diagnostic {..} - diagnostics = concatMap (map diagnosisToDiagnostic . diagnose) (maybeToList errs)- ++ map suggestionToDiagnostic suggestions+ modifying errors (Map.alter (const errs) _uri) -- cache errors - modifying errors (Map.alter (const errs) uri) -- cache errors- lspSendNotification LSP.NotPublishDiagnostics J.TextDocumentPublishDiagnostics- (J.PublishDiagnosticsParams uri (J.List diagnostics))+ let _version = Nothing+ let _diagnostics =+ List+ ( concatMap (map diagnosisToDiagnostic . diagnose) (maybeToList errs)+ ++ map suggestionToDiagnostic suggestions+ ) -documentFormattingHandler :: J.DocumentFormattingRequest -> HandlerM ()-documentFormattingHandler request = do- let uri = request ^. J.params . J.textDocument . J.uri- txt <- readUri uri+ liftLSP (LSP.sendNotification STextDocumentPublishDiagnostics PublishDiagnosticsParams{ _uri, _version, _diagnostics }) - (header, expr) <- case parseWithHeader txt of- Right res -> return res- _ -> throwE (Warning, "Failed to format dhall code; parse error.")+documentFormattingHandler :: Handlers HandlerM+documentFormattingHandler =+ LSP.requestHandler STextDocumentFormatting \request respond -> do+ let _uri = request^.params.textDocument.uri - ServerConfig {..} <- getServerConfig+ txt <- readUri _uri - let formatted = formatExprWithHeader chosenCharacterSet expr header- numLines = Text.length txt- range = J.Range (J.Position 0 0) (J.Position numLines 0)- edits = J.List [J.TextEdit range formatted]+ (header, expr) <- case parseWithHeader txt of+ Right res -> return res+ _ -> throwE (Warning, "Failed to format dhall code; parse error.") - lspRespond LSP.RspDocumentFormatting request edits+ ServerConfig{..} <- liftLSP LSP.getConfig + let numLines = Text.length txt+ let _newText= formatExprWithHeader chosenCharacterSet expr header+ let _range = LSP.Types.Range (Position 0 0) (Position numLines 0) -executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM ()-executeCommandHandler request- | command == "dhall.server.lint" = executeLintAndFormat request- | command == "dhall.server.annotateLet" = executeAnnotateLet request- | command == "dhall.server.freezeImport" = executeFreezeImport request- | command == "dhall.server.freezeAllImports" = executeFreezeAllImports request- | otherwise = throwE (Warning, "Command '" <> command- <> "' not known; ignored.")- where command = request ^. J.params . J.command+ respond (Right (List [TextEdit{..}])) -getCommandArguments :: J.FromJSON a => J.ExecuteCommandRequest -> HandlerM a+executeCommandHandler :: Handlers HandlerM+executeCommandHandler =+ LSP.requestHandler SWorkspaceExecuteCommand \request respond -> do+ let command_ = request^.params.command+ if | command_ == "dhall.server.lint" ->+ executeLintAndFormat request respond+ | command_ == "dhall.server.annotateLet" ->+ executeAnnotateLet request+ | command_ == "dhall.server.freezeImport" ->+ executeFreezeImport request+ | command_ == "dhall.server.freezeAllImports" ->+ executeFreezeAllImports request+ | otherwise -> do+ throwE+ ( Warning+ , "Command '" <> command_ <> "' not known; ignored."+ )++getCommandArguments+ :: FromJSON a => RequestMessage 'WorkspaceExecuteCommand -> HandlerM a+-- (HasParams s a, FromJSON a) => s -> HandlerM a getCommandArguments request = do- json <- case request ^. J.params . J.arguments of- Just (J.List (x : _)) -> return x+ json <- case request ^. params . arguments of+ Just (List (x : _)) -> return x _ -> throwE (Error, "Failed to execute command; arguments missing.")- case J.fromJSON json of- J.Success args -> return args- _ -> throwE (Error, "Failed to execute command; failed to parse arguments.")-+ case Aeson.fromJSON json of+ Aeson.Success args ->+ return args+ _ ->+ throwE (Error, "Failed to execute command; failed to parse arguments.") -- implements dhall.server.lint-executeLintAndFormat :: J.ExecuteCommandRequest -> HandlerM ()-executeLintAndFormat request = do- uri <- getCommandArguments request- txt <- readUri uri+executeLintAndFormat+ :: RequestMessage 'WorkspaceExecuteCommand+ -> (Either a Value -> HandlerM b)+ -> HandlerM ()+executeLintAndFormat request respond = do+ uri_ <- getCommandArguments request+ txt <- readUri uri_ (header, expr) <- case parseWithHeader txt of Right res -> return res _ -> throwE (Warning, "Failed to lint dhall code; parse error.") - ServerConfig {..} <- getServerConfig+ ServerConfig{..} <- liftLSP LSP.getConfig - let linted = formatExprWithHeader chosenCharacterSet (lint expr) header- numLines = Text.length txt- range = J.Range (J.Position 0 0) (J.Position numLines 0)- edit = J.WorkspaceEdit- (Just (HashMap.singleton uri (J.List [J.TextEdit range linted]))) Nothing+ let numLines = Text.length txt - lspRespond LSP.RspExecuteCommand request J.Null- lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit- (J.ApplyWorkspaceEditParams edit)+ let _newText = formatExprWithHeader chosenCharacterSet (lint expr) header + let _range = LSP.Types.Range (Position 0 0) (Position numLines 0) -executeAnnotateLet :: J.ExecuteCommandRequest -> HandlerM ()+ let _edit =+ WorkspaceEdit+ { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}]))+ , _documentChanges = Nothing+ , _changeAnnotations = Nothing+ }++ let _label = Nothing++ _ <- respond (Right Aeson.Null)++ _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler)++ return ()++executeAnnotateLet+ :: RequestMessage 'WorkspaceExecuteCommand+ -> HandlerM () executeAnnotateLet request = do- args <- getCommandArguments request :: HandlerM J.TextDocumentPositionParams- let uri = args ^. J.textDocument . J.uri- line = args ^. J.position . J.line- col = args ^. J.position . J.character+ args <- getCommandArguments request :: HandlerM TextDocumentPositionParams+ let uri_ = args ^. textDocument . uri+ line_ = args ^. position . line+ col_ = args ^. position . character - expr <- loadFile uri+ expr <- loadFile uri_ (welltyped, _) <- case typecheck expr of Left _ -> throwE (Warning, "Failed to annotate let binding; not well-typed.") Right e -> return e - ServerConfig {..} <- getServerConfig+ ServerConfig{..} <- liftLSP LSP.getConfig (Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _, annotExpr)- <- case annotateLet (line, col) welltyped of+ <- case annotateLet (line_, col_) welltyped of Right x -> return x Left msg -> throwE (Warning, Text.pack msg) - let range = J.Range (J.Position (unPos x1 - 1) (unPos y1 - 1))- (J.Position (unPos x2 - 1) (unPos y2 - 1))- txt = formatExpr chosenCharacterSet annotExpr- edit = J.WorkspaceEdit- (Just (HashMap.singleton uri (J.List [J.TextEdit range txt]))) Nothing+ let _range = LSP.Types.Range (Position (unPos x1 - 1) (unPos y1 - 1))+ (Position (unPos x2 - 1) (unPos y2 - 1)) - lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit- (J.ApplyWorkspaceEditParams edit)+ let _newText= formatExpr chosenCharacterSet annotExpr + let _edit = WorkspaceEdit+ { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}]))+ , _documentChanges = Nothing+ , _changeAnnotations = Nothing+ } -executeFreezeAllImports :: J.ExecuteCommandRequest -> HandlerM ()+ let _label = Nothing++ _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler)++ return ()++executeFreezeAllImports+ :: RequestMessage 'WorkspaceExecuteCommand+ -> HandlerM () executeFreezeAllImports request = do- uri <- getCommandArguments request+ uri_ <- getCommandArguments request - fileIdentifier <- fileIdentifierFromUri uri- txt <- readUri uri+ fileIdentifier <- fileIdentifierFromUri uri_+ txt <- readUri uri_ expr <- case parse txt of Right e -> return e Left _ -> throwE (Warning, "Could not freeze imports; did not parse.") let importRanges = getAllImportsWithHashPositions expr- edits <- forM importRanges $ \(import_, Range (x1, y1) (x2, y2)) -> do+ edits_ <- forM importRanges $ \(import_, Range (x1, y1) (x2, y2)) -> do cache <- use importCache let importExpr = Embed (stripHash import_) @@ -438,37 +435,46 @@ Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") assign importCache cache' - let range = J.Range (J.Position x1 y1) (J.Position x2 y2)- return (J.TextEdit range (" " <> hash))+ let _range = LSP.Types.Range (Position x1 y1) (Position x2 y2)+ let _newText = " " <> hash+ return TextEdit{..} - let workspaceEdit = J.WorkspaceEdit- (Just (HashMap.singleton uri (J.List edits))) Nothing- lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit- (J.ApplyWorkspaceEditParams workspaceEdit)+ let _edit = WorkspaceEdit+ { _changes = Just (HashMap.singleton uri_ (List edits_))+ , _documentChanges = Nothing+ , _changeAnnotations = Nothing+ } + let _label = Nothing -executeFreezeImport :: J.ExecuteCommandRequest -> HandlerM ()+ _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler)++ return ()++executeFreezeImport+ :: RequestMessage 'WorkspaceExecuteCommand+ -> HandlerM () executeFreezeImport request = do- args <- getCommandArguments request :: HandlerM J.TextDocumentPositionParams- let uri = args ^. J.textDocument . J.uri- line = args ^. J.position . J.line- col = args ^. J.position . J.character+ args <- getCommandArguments request :: HandlerM TextDocumentPositionParams+ let uri_ = args ^. textDocument . uri+ let line_ = args ^. position . line+ let col_ = args ^. position . character - txt <- readUri uri+ txt <- readUri uri_ expr <- case parse txt of Right e -> return e Left _ -> throwE (Warning, "Could not freeze import; did not parse.") (src, import_)- <- case exprAt (line, col) expr of+ <- case exprAt (line_, col_) expr of Just (Note src (Embed i)) -> return (src, i) _ -> throwE (Warning, "You weren't pointing at an import!") Range (x1, y1) (x2, y2) <- case getImportHashPosition src of- Just range -> return range+ Just range_ -> return range_ Nothing -> throwE (Error, "Failed to re-parse import!") - fileIdentifier <- fileIdentifierFromUri uri+ fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache let importExpr = Embed (stripHash import_) @@ -478,116 +484,128 @@ Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") assign importCache cache' - let range = J.Range (J.Position x1 y1) (J.Position x2 y2)- edit = J.WorkspaceEdit- (Just (HashMap.singleton uri (J.List [J.TextEdit range (" " <> hash)]))) Nothing+ let _range = LSP.Types.Range (Position x1 y1) (Position x2 y2)+ let _newText = " " <> hash - lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit- (J.ApplyWorkspaceEditParams edit)+ let _edit = WorkspaceEdit+ { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}]))+ , _documentChanges = Nothing+ , _changeAnnotations = Nothing+ } -completionHandler :: J.CompletionRequest -> HandlerM ()-completionHandler request = do- let uri = request ^. J.params . J.textDocument . J.uri- line = request ^. J.params . J.position . J.line- col = request ^. J.params . J.position . J.character+ let _label = Nothing - txt <- readUri uri- let (completionLeadup, completionPrefix) = completionQueryAt txt (line, col)+ _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler) - let computeCompletions- -- environment variable- | "env:" `isPrefixOf` completionPrefix =- liftIO completeEnvironmentImport+ return () - -- local import- | any (`isPrefixOf` completionPrefix) [ "/", "./", "../", "~/" ] = do- let relativeTo | Just path <- J.uriToFilePath uri = path+completionHandler :: Handlers HandlerM+completionHandler =+ LSP.requestHandler STextDocumentCompletion \request respond -> do+ let uri_ = request ^. params . textDocument . uri+ line_ = request ^. params . position . line+ col_ = request ^. params . position . character++ txt <- readUri uri_+ let (completionLeadup, completionPrefix) = completionQueryAt txt (line_, col_)++ let computeCompletions+ -- environment variable+ | "env:" `isPrefixOf` completionPrefix =+ liftIO completeEnvironmentImport++ -- local import+ | any (`isPrefixOf` completionPrefix) [ "/", "./", "../", "~/" ] = do+ let relativeTo | Just path <- uriToFilePath uri_ = path | otherwise = "."- liftIO $ completeLocalImport relativeTo (Text.unpack completionPrefix)+ liftIO $ completeLocalImport relativeTo (Text.unpack completionPrefix) - -- record projection / union constructor- | (target, _) <- Text.breakOnEnd "." completionPrefix- , not (Text.null target) = do- let bindersExpr = binderExprFromText completionLeadup+ -- record projection / union constructor+ | (target_, _) <- Text.breakOnEnd "." completionPrefix+ , not (Text.null target_) = do+ let bindersExpr = binderExprFromText completionLeadup - fileIdentifier <- fileIdentifierFromUri uri- cache <- use importCache- loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache+ fileIdentifier <- fileIdentifierFromUri uri_+ cache <- use importCache+ loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache - (cache', bindersExpr') <-- case loadedBinders of- Right (cache', binders) ->- return (cache', binders)- Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")+ (cache', bindersExpr') <-+ case loadedBinders of+ Right (cache', binders) ->+ return (cache', binders)+ Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.") - let completionContext = buildCompletionContext bindersExpr'+ let completionContext = buildCompletionContext bindersExpr' - targetExpr <- case parse (Text.dropEnd 1 target) of- Right e -> return e- Left _ -> throwE (Log, "Could not complete projection; prefix did not parse.")+ targetExpr <- case parse (Text.dropEnd 1 target_) of+ Right e -> return e+ Left _ -> throwE (Log, "Could not complete projection; prefix did not parse.") - loaded' <- liftIO $ load fileIdentifier targetExpr cache'- case loaded' of- Right (cache'', targetExpr') -> do- assign importCache cache''- return (completeProjections completionContext targetExpr')- Left _ -> return []+ loaded' <- liftIO $ load fileIdentifier targetExpr cache'+ case loaded' of+ Right (cache'', targetExpr') -> do+ assign importCache cache''+ return (completeProjections completionContext targetExpr')+ Left _ -> return [] - -- complete identifiers in scope- | otherwise = do- let bindersExpr = binderExprFromText completionLeadup+ -- complete identifiers in scope+ | otherwise = do+ let bindersExpr = binderExprFromText completionLeadup - fileIdentifier <- fileIdentifierFromUri uri- cache <- use importCache -- todo save cache afterwards- loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache+ fileIdentifier <- fileIdentifierFromUri uri_+ cache <- use importCache -- todo save cache afterwards+ loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache - bindersExpr' <-- case loadedBinders of- Right (cache', binders) -> do- assign importCache cache'- return binders- Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")+ bindersExpr' <-+ case loadedBinders of+ Right (cache', binders) -> do+ assign importCache cache'+ return binders+ Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.") - let context = buildCompletionContext bindersExpr'- return (completeFromContext context)+ let context_ = buildCompletionContext bindersExpr' - completions <- computeCompletions+ return (completeFromContext context_) - let item (Completion {..}) = J.CompletionItem {..}- where- _label = completeText- _kind = Nothing- _tags = mempty- _detail = fmap pretty completeType- _documentation = Nothing- _deprecated = Nothing- _preselect = Nothing- _sortText = Nothing- _filterText = Nothing- _insertText = Nothing- _insertTextFormat = Nothing- _textEdit = Nothing- _additionalTextEdits = Nothing- _commitCharacters = Nothing- _command = Nothing- _xdata = Nothing- lspRespond LSP.RspCompletion request $ J.Completions (J.List (map item completions))+ completions <- computeCompletions + let toCompletionItem (Completion {..}) = CompletionItem {..}+ where+ _label = completeText+ _kind = Nothing+ _tags = mempty+ _detail = fmap pretty completeType+ _documentation = Nothing+ _deprecated = Nothing+ _preselect = Nothing+ _sortText = Nothing+ _filterText = Nothing+ _insertText = Nothing+ _insertTextFormat = Nothing+ _insertTextMode = Nothing+ _textEdit = Nothing+ _additionalTextEdits = Nothing+ _commitCharacters = Nothing+ _command = Nothing+ _xdata = Nothing --- handler that doesn't do anything. Useful for example to make haskell-lsp shut--- up about unhandled DidChangeTextDocument notifications (which are already--- handled haskell-lsp itself).-nullHandler :: a -> HandlerM ()+ let _items = List (map toCompletionItem completions)++ let _isIncomplete = False++ respond (Right (InR CompletionList{..}))++nullHandler :: a -> LspT ServerConfig IO () nullHandler _ = return () -didOpenTextDocumentNotificationHandler- :: J.DidOpenTextDocumentNotification -> HandlerM ()-didOpenTextDocumentNotificationHandler notification = do- let uri = notification ^. J.params . J.textDocument . J.uri- diagnosticsHandler uri+didOpenTextDocumentNotificationHandler :: Handlers HandlerM+didOpenTextDocumentNotificationHandler =+ LSP.notificationHandler STextDocumentDidOpen \notification -> do+ let _uri = notification^.params.textDocument.uri+ diagnosticsHandler _uri -didSaveTextDocumentNotificationHandler- :: J.DidSaveTextDocumentNotification -> HandlerM ()-didSaveTextDocumentNotificationHandler notification = do- let uri = notification ^. J.params . J.textDocument . J.uri- diagnosticsHandler uri+didSaveTextDocumentNotificationHandler :: Handlers HandlerM+didSaveTextDocumentNotificationHandler =+ LSP.notificationHandler STextDocumentDidSave \notification -> do+ let _uri = notification^.params.textDocument.uri+ diagnosticsHandler _uri
src/Dhall/LSP/Server.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE RecordWildCards #-} {-| This is the entry point for the LSP server. -} module Dhall.LSP.Server(run) where -import Control.Concurrent.MVar-import Control.Lens ((^.))-import Data.Aeson (Result (Success), fromJSON)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (fromJSON) import Data.Default-import Data.Text (Text) import Dhall.LSP.Handlers ( completionHandler , didOpenTextDocumentNotificationHandler@@ -16,101 +16,122 @@ , documentLinkHandler , executeCommandHandler , hoverHandler- , nullHandler- , wrapHandler ) import Dhall.LSP.State+import Language.LSP.Server (Options(..), ServerDefinition(..), type (<~>)(..))+import Language.LSP.Types+import System.Exit (ExitCode(..)) -import qualified Language.Haskell.LSP.Control as LSP.Control-import qualified Language.Haskell.LSP.Core as LSP.Core-import qualified Language.Haskell.LSP.Types as J-import qualified Language.Haskell.LSP.Types.Lens as J+import qualified Control.Concurrent.MVar as MVar+import qualified Control.Monad.Trans.Except as Except+import qualified Control.Monad.Trans.State.Strict as State+import qualified Data.Aeson as Aeson+import qualified Data.Text as Text+import qualified Language.LSP.Server as LSP+import qualified System.Exit as Exit import qualified System.Log.Logger -- | The main entry point for the LSP server. run :: Maybe FilePath -> IO () run mlog = do setupLogger mlog- state <- newEmptyMVar - let onInitialConfiguration :: J.InitializeRequest -> Either Text ServerConfig- onInitialConfiguration req- | Just initOpts <- req ^. J.params . J.initializationOptions- , Success config <- fromJSON initOpts- = Right config- onInitialConfiguration _ = Right def+ state <- MVar.newMVar initialState - let onConfigurationChange :: J.DidChangeConfigurationNotification -> Either Text ServerConfig- onConfigurationChange notification- | preConfig <- notification ^. J.params . J.settings- , Success config <- fromJSON preConfig- = Right config- onConfigurationChange _ = Right def+ let defaultConfig = def - -- Callback that is called when the LSP server is started; makes the lsp- -- state (LspFuncs) available to the message handlers through the `state` MVar.- let onStartup :: LSP.Core.LspFuncs ServerConfig -> IO (Maybe J.ResponseError)- onStartup lsp = do- putMVar state (initialState lsp)- return Nothing+ let onConfigurationChange _oldConfig json =+ case fromJSON json of+ Aeson.Success config -> Right config+ Aeson.Error string -> Left (Text.pack string) - _ <- LSP.Control.run (LSP.Core.InitializeCallbacks {..})- (lspHandlers state)- lspOptions- Nothing- return ()+ let doInitialize environment _request = do+ return (Right environment) + let options = def+ { LSP.textDocumentSync = Just syncOptions++ , completionTriggerCharacters = Just [':', '.', '/']++ -- Note that this registers the dhall.server.lint command+ -- with VSCode, which means that our plugin can't expose a+ -- command of the same name. In the case of dhall.lint we+ -- name the server-side command dhall.server.lint to work+ -- around this peculiarity.+ , executeCommandCommands =+ Just+ [ "dhall.server.lint",+ "dhall.server.annotateLet",+ "dhall.server.freezeImport",+ "dhall.server.freezeAllImports"+ ]+ }++ let staticHandlers =+ mconcat+ [ hoverHandler+ , didOpenTextDocumentNotificationHandler+ , didSaveTextDocumentNotificationHandler+ , executeCommandHandler+ , documentFormattingHandler+ , documentLinkHandler+ , completionHandler+ ]++ let interpretHandler environment = Iso{..}+ where+ forward :: HandlerM a -> IO a+ forward handler =+ MVar.modifyMVar state \oldState -> do+ LSP.runLspT environment do+ (e, newState) <- State.runStateT (Except.runExceptT handler) oldState+ result <- case e of+ Left (Log, _message) -> do+ let _xtype = MtLog++ LSP.sendNotification SWindowLogMessage LogMessageParams{..}++ liftIO (fail (Text.unpack _message))++ Left (severity_, _message) -> do+ let _xtype = case severity_ of+ Error -> MtError+ Warning -> MtWarning+ Info -> MtInfo+ Log -> MtLog++ LSP.sendNotification SWindowShowMessage ShowMessageParams{..}+ liftIO (fail (Text.unpack _message))+ Right a -> do+ return a++ return (newState, result)++ backward = liftIO++ exitCode <- LSP.runServer ServerDefinition{..}++ case exitCode of+ 0 -> return ()+ n -> Exit.exitWith (ExitFailure n)+ -- | sets the output logger. -- | if no filename is provided then logger is disabled, if input is string `[OUTPUT]` then log goes to stderr, -- | which then redirects inside VSCode to the output pane of the plugin. setupLogger :: Maybe FilePath -> IO () -- TODO: ADD verbosity-setupLogger Nothing = pure ()-setupLogger (Just "[OUTPUT]") = LSP.Core.setupLogger Nothing [] System.Log.Logger.DEBUG-setupLogger file = LSP.Core.setupLogger file [] System.Log.Logger.DEBUG+setupLogger Nothing = pure ()+setupLogger (Just "[OUTPUT]") = LSP.setupLogger Nothing [] System.Log.Logger.DEBUG+setupLogger file = LSP.setupLogger file [] System.Log.Logger.DEBUG -- Tells the LSP client to notify us about file changes. Handled behind the -- scenes by haskell-lsp (in Language.Haskell.LSP.VFS); we don't handle the -- corresponding notifications ourselves.-syncOptions :: J.TextDocumentSyncOptions-syncOptions = J.TextDocumentSyncOptions- { J._openClose = Just True- , J._change = Just J.TdSyncIncremental- , J._willSave = Just False- , J._willSaveWaitUntil = Just False- , J._save = Just $ J.SaveOptions $ Just False+syncOptions :: TextDocumentSyncOptions+syncOptions = TextDocumentSyncOptions+ { _openClose = Just True+ , _change = Just TdSyncIncremental+ , _willSave = Just False+ , _willSaveWaitUntil = Just False+ , _save = Just (InR (SaveOptions (Just False))) }---- Server capabilities. Tells the LSP client that we can execute commands etc.-lspOptions :: LSP.Core.Options-lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions- , LSP.Core.completionTriggerCharacters = Just [':', '.', '/']- -- Note that this registers the dhall.server.lint command- -- with VSCode, which means that our plugin can't expose a- -- command of the same name. In the case of dhall.lint we- -- name the server-side command dhall.server.lint to work- -- around this peculiarity.- , LSP.Core.executeCommandCommands =- Just- [ "dhall.server.lint",- "dhall.server.annotateLet",- "dhall.server.freezeImport",- "dhall.server.freezeAllImports"- ]- }--lspHandlers :: MVar ServerState -> LSP.Core.Handlers-lspHandlers state- = def { LSP.Core.initializedHandler = Just $ wrapHandler state nullHandler- , LSP.Core.hoverHandler = Just $ wrapHandler state hoverHandler- , LSP.Core.didOpenTextDocumentNotificationHandler = Just $ wrapHandler state didOpenTextDocumentNotificationHandler- , LSP.Core.didChangeTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler- , LSP.Core.didSaveTextDocumentNotificationHandler = Just $ wrapHandler state didSaveTextDocumentNotificationHandler- , LSP.Core.didCloseTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler- , LSP.Core.cancelNotificationHandler = Just $ wrapHandler state nullHandler- , LSP.Core.responseHandler = Just $ wrapHandler state nullHandler- , LSP.Core.executeCommandHandler = Just $ wrapHandler state executeCommandHandler- , LSP.Core.documentFormattingHandler = Just $ wrapHandler state documentFormattingHandler- , LSP.Core.documentLinkHandler = Just $ wrapHandler state documentLinkHandler- , LSP.Core.completionHandler = Just $ wrapHandler state completionHandler- }
src/Dhall/LSP/State.hs view
@@ -4,7 +4,6 @@ module Dhall.LSP.State where import Control.Lens.TH (makeLenses)-import Control.Lens.Type (LensLike') import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.State.Strict (StateT) import Data.Aeson@@ -20,16 +19,15 @@ import Data.Text (Text) import Dhall.LSP.Backend.Dhall (Cache, DhallError, emptyCache) import Dhall.Pretty (CharacterSet)--import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as J+import Language.LSP.Server (LspT) +import qualified Language.LSP.Types as J -- Inside a handler we have access to the ServerState. The exception layer -- allows us to fail gracefully, displaying a message to the user via the -- "ShowMessage" mechanism of the lsp standard.-type HandlerM = ExceptT (Severity, Text) (StateT ServerState IO)+type HandlerM =+ ExceptT (Severity, Text) (StateT ServerState (LspT ServerConfig IO)) data Severity = Error -- ^ Error displayed to the user.@@ -60,20 +58,13 @@ , _errors :: Map J.Uri DhallError -- ^ Map from dhall files to their errors , _httpManager :: Maybe Dynamic -- ^ The http manager used by dhall's import infrastructure- , _lspFuncs :: LSP.LspFuncs ServerConfig- -- ^ Access to the lsp functions supplied by haskell-lsp } makeLenses ''ServerState -sendFunc :: Functor f =>- LensLike' f (LSP.LspFuncs ServerConfig) (LSP.FromServerMessage -> IO ())-sendFunc k s = fmap (\x -> s {LSP.sendFunc = x}) (k (LSP.sendFunc s))--initialState :: LSP.LspFuncs ServerConfig -> ServerState-initialState lsp = ServerState {..}+initialState :: ServerState+initialState = ServerState {..} where _importCache = emptyCache _errors = empty _httpManager = Nothing- _lspFuncs = lsp
tests/Main.hs view
@@ -4,8 +4,8 @@ import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromJust)-import Language.Haskell.LSP.Test-import Language.Haskell.LSP.Types+import Language.LSP.Test+import Language.LSP.Types ( CompletionItem (..) , Diagnostic (..) , DiagnosticSeverity (..)