diff --git a/dhall-lsp-server.cabal b/dhall-lsp-server.cabal --- a/dhall-lsp-server.cabal +++ b/dhall-lsp-server.cabal @@ -1,5 +1,5 @@ name: dhall-lsp-server -Version: 1.1.3 +Version: 1.1.4 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 @@ -42,27 +42,27 @@ src default-extensions: RecordWildCards OverloadedStrings build-depends: - aeson >= 1.3.1.1 && < 2.2 + aeson >= 1.3.1.1 && < 2.3 , aeson-pretty >= 0.8.7 && < 0.9 , base >= 4.11 && < 5 - , bytestring >= 0.10.8.2 && < 0.12 - , containers >= 0.5.11.0 && < 0.7 + , bytestring >= 0.10.8.2 && < 0.13 + , co-log-core >= 0.3.1.0 && < 0.4 + , containers >= 0.5.11.0 && < 0.8 , data-default >= 0.7.1.1 && < 0.8 , directory >= 1.2.2.0 && < 1.4 , dhall >= 1.38.0 && < 1.43 , dhall-json >= 1.4 && < 1.8 - , filepath >= 1.4.2 && < 1.5 - , lsp >= 1.2.0.0 && < 1.5 - , rope-utf16-splay >= 0.3.1.0 && < 0.5 - , hslogger >= 1.2.10 && < 1.4 - , lens >= 4.16.1 && < 5.2 + , filepath >= 1.4.2 && < 1.6 + , lsp >= 2.1.0.0 && < 2.2 + , lens >= 4.16.1 && < 5.4 -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 , megaparsec >= 7.0.2 && < 10 - , mtl >= 2.2.2 && < 2.3 + , mtl >= 2.2.2 && < 2.4 , network-uri >= 2.6.1.0 && < 2.7 , prettyprinter >= 1.7.0 && < 1.8 - , text >= 1.2.3.0 && < 2.1 - , transformers >= 0.5.5.0 && < 0.6 + , text >= 1.2.3.0 && < 2.2 + , text-rope >= 0.2 && < 0.4 + , transformers >= 0.5.5.0 && < 0.7 , unordered-containers >= 0.2.9.0 && < 0.3 , uri-encode >= 1.5.0.5 && < 1.6 default-language: Haskell2010 @@ -77,7 +77,7 @@ default-extensions: RecordWildCards OverloadedStrings ghc-options: -rtsopts build-depends: - base + base >= 4.11 && < 5 , dhall-lsp-server , optparse-applicative default-language: Haskell2010 @@ -89,10 +89,10 @@ Main-Is: Main.hs GHC-Options: -Wall Build-Depends: - base , - directory >= 1.3.1.5 && < 1.4 , - filepath < 1.5 , - doctest >= 0.7.0 , + base >= 4.11 && < 5 , + directory >= 1.3.1.5 && < 1.4, + filepath < 1.6, + doctest >= 0.7.0 , QuickCheck Other-Extensions: OverloadedStrings RecordWildCards Default-Language: Haskell2010 @@ -103,12 +103,12 @@ Main-Is: Main.hs GHC-Options: -Wall Build-Depends: - base , - lsp-types >= 1.2.0.0 && < 1.5 , - hspec >= 2.7 && < 2.11 , - lsp-test >= 0.13.0.0 && < 0.15 , - tasty >= 0.11.2 && < 1.5 , - tasty-hspec >= 1.1 && < 1.3 , - text >= 0.11 && < 2.1 + base >= 4.11 && < 5 , + lsp-types >= 2.0.1 && < 2.1 , + hspec >= 2.7 && < 2.12, + lsp-test >= 0.15.0.0 && < 0.16, + tasty >= 0.11.2 && < 1.6 , + tasty-hspec >= 1.1 && < 1.3 , + text >= 0.11 && < 2.2 Build-Tool-Depends: dhall-lsp-server:dhall-lsp-server Default-Language: Haskell2010 diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -1,23 +1,26 @@ -module Main where +module Main (main) where import System.FilePath (()) import qualified GHC.IO.Encoding import qualified System.Directory +import qualified System.Environment import qualified System.IO import qualified Test.DocTest main :: IO () main = do - GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 - pwd <- System.Directory.getCurrentDirectory + args <- System.Environment.getArgs + pwd <- System.Directory.getCurrentDirectory prefix <- System.Directory.makeAbsolute pwd + let src = prefix "src" - Test.DocTest.doctest + Test.DocTest.doctest $ [ "--fast" , "-XOverloadedStrings" , "-XRecordWildCards" - , "-i" <> (prefix "src") - , prefix "src/Dhall/LSP/Backend/Diagnostics.hs" + ] <> args <> + [ "-i" <> src + , src "Dhall/LSP/Backend/Diagnostics.hs" ] diff --git a/src/Dhall/LSP/Backend/Completion.hs b/src/Dhall/LSP/Backend/Completion.hs --- a/src/Dhall/LSP/Backend/Completion.hs +++ b/src/Dhall/LSP/Backend/Completion.hs @@ -7,6 +7,7 @@ import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset) import Dhall.LSP.Backend.Parsing (holeExpr) import Dhall.Parser (Src, exprFromText) +import Dhall.Pretty (UnescapedLabel (..)) import Dhall.TypeCheck (typeOf, typeWithA) import System.Directory (doesDirectoryExist, listDirectory) import System.Environment (getEnvironment) @@ -186,9 +187,9 @@ -- complete a union constructor by inspecting the union value completeUnion _A (Union m) = let constructor (k, Nothing) = - Completion (Dhall.Pretty.escapeLabel True k) (Just _A) + Completion (Dhall.Pretty.escapeLabel AnyLabelOrSome k) (Just _A) constructor (k, Just v) = - Completion (Dhall.Pretty.escapeLabel True k) (Just (Pi mempty k v _A)) + Completion (Dhall.Pretty.escapeLabel AnyLabelOrSome k) (Just (Pi mempty k v _A)) in map constructor (Dhall.Map.toList m) completeUnion _ _ = [] @@ -197,5 +198,5 @@ completeRecord (Record m) = map toCompletion (Dhall.Map.toList $ recordFieldValue <$> m) where toCompletion (name, typ) = - Completion (Dhall.Pretty.escapeLabel True name) (Just typ) + Completion (Dhall.Pretty.escapeLabel AnyLabel name) (Just typ) completeRecord _ = [] diff --git a/src/Dhall/LSP/Backend/Dhall.hs b/src/Dhall/LSP/Backend/Dhall.hs --- a/src/Dhall/LSP/Backend/Dhall.hs +++ b/src/Dhall/LSP/Backend/Dhall.hs @@ -28,6 +28,7 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text (Text) import Data.Void (Void) +import Dhall (EvaluateSettings) import Network.URI (URI) import System.FilePath ( splitDirectories @@ -35,21 +36,22 @@ , 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 +import qualified Dhall.Core as Dhall +import qualified Dhall.Import as Import import qualified Dhall.Map -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 +import qualified Dhall.Parser as Dhall +import qualified Dhall.TypeCheck as Dhall +import qualified Language.LSP.Protocol.Types as LSP.Types +import qualified Network.URI as URI -- | A @FileIdentifier@ represents either a local file or a remote url. -newtype FileIdentifier = FileIdentifier Dhall.Chained +newtype FileIdentifier = FileIdentifier Import.Chained -- | Construct a FileIdentifier from a local file path. fileIdentifierFromFilePath :: FilePath -> FileIdentifier @@ -58,7 +60,7 @@ directory = takeDirectory path components = map Text.pack . reverse . splitDirectories $ directory file = Dhall.File (Dhall.Directory components) filename - in FileIdentifier $ Dhall.chainedFromLocalHere Dhall.Absolute file Dhall.Code + in FileIdentifier $ Import.chainedFromLocalHere Dhall.Absolute file Dhall.Code -- | Construct a FileIdentifier from a given URI. Supports only "file:" URIs. fileIdentifierFromURI :: URI -> Maybe FileIdentifier @@ -76,11 +78,11 @@ newtype Normal = Normal {fromNormal :: Expr Src Void} -- An import graph, represented by list of import dependencies. -type ImportGraph = [Dhall.Depends] +type ImportGraph = [Import.Depends] -- | A cache maps Dhall imports to fully normalised expressions. By reusing -- caches we can speeds up diagnostics etc. significantly! -data Cache = Cache ImportGraph (Dhall.Map.Map Dhall.Chained Dhall.ImportSemantics) +data Cache = Cache ImportGraph (Dhall.Map.Map Import.Chained Import.ImportSemantics) -- | The initial cache. emptyCache :: Cache @@ -94,11 +96,11 @@ invalidate (FileIdentifier chained) (Cache dependencies cache) = Cache dependencies' $ Dhall.Map.withoutKeys cache invalidImports where - imports = map Dhall.parent dependencies ++ map Dhall.child dependencies + imports = map Import.parent dependencies ++ map Import.child dependencies adjacencyLists = foldr -- add reversed edges to adjacency lists - (\(Dhall.Depends parent child) -> Map.adjust (parent :) child) + (\(Import.Depends parent child) -> Map.adjust (parent :) child) -- starting from the discrete graph (Map.fromList [ (i,[]) | i <- imports]) dependencies @@ -112,18 +114,18 @@ do vertex <- vertexFromImport import_ return (Graph.reachable graph vertex) - codeImport = Dhall.chainedChangeMode Dhall.Code chained - textImport = Dhall.chainedChangeMode Dhall.RawText chained + codeImport = Import.chainedChangeMode Dhall.Code chained + textImport = Import.chainedChangeMode Dhall.RawText chained invalidImports = Set.fromList $ codeImport : reachableImports codeImport ++ textImport : reachableImports textImport - dependencies' = filter (\(Dhall.Depends parent child) -> Set.notMember parent invalidImports + dependencies' = filter (\(Import.Depends parent child) -> Set.notMember parent invalidImports && Set.notMember child invalidImports) dependencies -- | A Dhall error. Covers parsing, resolving of imports, typechecking and -- normalisation. data DhallError = ErrorInternal SomeException - | ErrorImportSourced (Dhall.SourcedException Dhall.MissingImports) + | ErrorImportSourced (Dhall.SourcedException Import.MissingImports) | ErrorTypecheck (Dhall.TypeError Src Void) | ErrorParse Dhall.ParseError @@ -137,38 +139,50 @@ parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText "" -- | Resolve all imports in an expression. -load :: FileIdentifier -> Expr Src Dhall.Import -> Cache -> - IO (Either DhallError (Cache, Expr Src Void)) -load (FileIdentifier chained) expr (Cache graph cache) = do - let emptyStatus = Dhall.emptyStatus "" - status = -- reuse cache and import graph - set Dhall.cache cache . - set Dhall.graph graph . +load + :: EvaluateSettings + -> FileIdentifier + -> Expr Src Dhall.Import + -> Cache + -> IO (Either DhallError (Cache, Expr Src Void)) +load settings (FileIdentifier chained) expr (Cache graph cache) = do + let emptyStatus = + set Import.substitutions (view Dhall.substitutions settings) + . set Import.normalizer (view Dhall.normalizer settings) + . set Import.startingContext (view Dhall.startingContext settings) + $ Import.emptyStatusWithManager (view Dhall.newManager settings) "" + + let status = -- reuse cache and import graph + set Import.cache cache . + set Import.graph graph . -- set "root import" - set Dhall.stack (chained :| []) + set Import.stack (chained :| []) $ emptyStatus - (do (expr', status') <- runStateT (Dhall.loadWith expr) status - let cache' = view Dhall.cache status' - graph' = view Dhall.graph status' + (do (expr', status') <- runStateT (Import.loadWith expr) status + let cache' = view Import.cache status' + graph' = view Import.graph status' return . Right $ (Cache graph' cache', expr')) `catch` (\e -> return . Left $ ErrorImportSourced e) `catch` (\e -> return . Left $ ErrorInternal e) -- | Typecheck a fully resolved expression. Returns a certification that the -- input was well-typed along with its (well-typed) type. -typecheck :: Expr Src Void -> Either DhallError (WellTyped, WellTyped) -typecheck expr = case Dhall.typeOf expr of +typecheck + :: EvaluateSettings + -> Expr Src Void + -> Either DhallError (WellTyped, WellTyped) +typecheck settings expr = case Dhall.typeWith (view Dhall.startingContext settings) expr of Left err -> Left $ ErrorTypecheck err Right typ -> Right (WellTyped expr, WellTyped typ) -- | Normalise a well-typed expression. -normalize :: WellTyped -> Normal -normalize (WellTyped expr) = Normal $ Dhall.normalize expr +normalize :: EvaluateSettings -> WellTyped -> Normal +normalize settings (WellTyped expr) = Normal $ Dhall.normalizeWith (view Dhall.normalizer settings) expr -- | Given a normal expression compute the hash (using the default standard -- version) of its alpha-normal form. Returns the hash in the format used in -- Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded). hashNormalToCode :: Normal -> Text hashNormalToCode (Normal expr) = - Dhall.hashExpressionToCode (Dhall.denote alphaNormal) + Import.hashExpressionToCode (Dhall.denote alphaNormal) where alphaNormal = Dhall.alphaNormalize expr diff --git a/src/Dhall/LSP/Backend/Freezing.hs b/src/Dhall/LSP/Backend/Freezing.hs --- a/src/Dhall/LSP/Backend/Freezing.hs +++ b/src/Dhall/LSP/Backend/Freezing.hs @@ -7,6 +7,7 @@ import Control.Lens (universeOf) import Data.Text (Text) +import Dhall (EvaluateSettings) import Dhall.Core ( Expr (..) , Import (..) @@ -37,16 +38,20 @@ -- | Given an expression (potentially still containing imports) compute its -- 'semantic' hash in the textual representation used to freeze Dhall imports. -computeSemanticHash :: FileIdentifier -> Expr Src Import -> Cache -> - IO (Either DhallError (Cache, Text)) -computeSemanticHash fileid expr cache = do - loaded <- load fileid expr cache +computeSemanticHash + :: EvaluateSettings + -> FileIdentifier + -> Expr Src Import + -> Cache + -> IO (Either DhallError (Cache, Text)) +computeSemanticHash settings fileid expr cache = do + loaded <- load settings fileid expr cache case loaded of Left err -> return (Left err) - Right (cache', expr') -> case typecheck expr' of + Right (cache', expr') -> case typecheck settings expr' of Left err -> return (Left err) Right (wt,_) -> - return (Right (cache', hashNormalToCode (normalize wt))) + return (Right (cache', hashNormalToCode (normalize settings wt))) stripHash :: Import -> Import stripHash (Import (ImportHashed _ importType) mode) = diff --git a/src/Dhall/LSP/Handlers.hs b/src/Dhall/LSP/Handlers.hs --- a/src/Dhall/LSP/Handlers.hs +++ b/src/Dhall/LSP/Handlers.hs @@ -1,13 +1,15 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Dhall.LSP.Handlers where import Data.Void (Void) +import Dhall (EvaluateSettings) import Dhall.Core ( Expr (Embed, Note) , Import (..) @@ -58,30 +60,43 @@ 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 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.Protocol.Lens + ( arguments + , character + , command + , line + , params + , position + , textDocument + , uri + ) +import Language.LSP.Protocol.Message + ( Method (..) + , SMethod (..) + , TRequestMessage + ) +import Language.LSP.Protocol.Types hiding (Range (..)) +import Language.LSP.Server (Handlers, LspT) +import System.FilePath (takeDirectory, ()) +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 +import qualified Data.Aeson as Aeson +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Utf16.Rope as Rope +import qualified Language.LSP.Protocol.Types as LSP.Types +import qualified Language.LSP.Server as LSP +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 m = lift (lift m) @@ -94,8 +109,8 @@ Just (LSP.VirtualFile _ _ rope) -> return (Rope.toText rope) Nothing -> throwE (Error, "Could not find " <> Text.pack (show uri_) <> " in VFS.") -loadFile :: Uri -> HandlerM (Expr Src Void) -loadFile uri_ = do +loadFile :: EvaluateSettings -> Uri -> HandlerM (Expr Src Void) +loadFile settings uri_ = do txt <- readUri uri_ fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache @@ -104,7 +119,7 @@ Right e -> return e _ -> throwE (Error, "Failed to parse Dhall file.") - loaded <- liftIO $ load fileIdentifier expr cache + loaded <- liftIO $ load settings fileIdentifier expr cache (cache', expr') <- case loaded of Right x -> return x _ -> throwE (Error, "Failed to resolve imports.") @@ -130,9 +145,9 @@ (Position (fromIntegral x1) (fromIntegral y1)) (Position (fromIntegral x2) (fromIntegral y2)) -hoverHandler :: Handlers HandlerM -hoverHandler = - LSP.requestHandler STextDocumentHover \request respond -> handleErrorWithDefault respond Nothing do +hoverHandler :: EvaluateSettings -> Handlers HandlerM +hoverHandler settings = + LSP.requestHandler SMethod_TextDocumentHover \request respond -> handleErrorWithDefault respond (InR LSP.Types.Null) do let uri_ = request^.params.textDocument.uri let Position{ _line = fromIntegral -> _line, _character = fromIntegral -> _character } = request^.params.position @@ -141,8 +156,8 @@ case Map.lookup uri_ errorMap of Nothing -> do - expr <- loadFile uri_ - (welltyped, _) <- case typecheck expr of + expr <- loadFile settings uri_ + (welltyped, _) <- case typecheck settings expr of Left _ -> throwE (Info, "Can't infer type; code does not type-check.") Right wt -> return wt case typeAt (_line, _character) welltyped of @@ -150,8 +165,8 @@ Right (mSrc, typ) -> do let _range = fmap (rangeToJSON . rangeFromDhall) mSrc - let _contents = HoverContents (MarkupContent MkPlainText (pretty typ)) - respond (Right (Just Hover{ _contents, _range })) + let _contents = InL (mkPlainText (pretty typ)) + respond (Right (InL Hover{ _contents, _range })) Just err -> do let isHovered (Diagnosis _ (Just (Range left right)) _) = left <= (_line, _character) && (_line, _character) <= right @@ -162,14 +177,14 @@ let _range = Just (rangeToJSON (Range left right)) encodedDiag = URI.encode (Text.unpack diagnosis) - _kind = MkMarkdown + _kind = MarkupKind_Markdown _value = "[Explain error](dhall-explain:?" <> Text.pack encodedDiag <> " )" - _contents = HoverContents MarkupContent{..} + _contents = InL MarkupContent{..} Just Hover{ _contents, _range } hoverFromDiagnosis _ = Nothing @@ -181,11 +196,11 @@ hoverFromDiagnosis explanation - respond (Right mHover) + respond (Right (maybeToNull mHover)) documentLinkHandler :: Handlers HandlerM documentLinkHandler = - LSP.requestHandler STextDocumentDocumentLink \request respond -> handleErrorWithDefault respond (List []) do + LSP.requestHandler SMethod_TextDocumentDocumentLink \request respond -> handleErrorWithDefault respond (InL []) do let uri_ = request^.params.textDocument.uri path <- case uriToFilePath uri_ of @@ -211,27 +226,27 @@ filePath <- localToPath prefix file let filePath' = basePath filePath -- absolute file path let _range = rangeToJSON range_ - let _target = Just (filePathToUri filePath') + let _target = Just (getUri (filePathToUri filePath')) let _tooltip = Nothing - let _xdata = Nothing + let _data_ = 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 _target = Just (pretty url') let _tooltip = Nothing - let _xdata = Nothing + let _data_ = Nothing return [DocumentLink {..}] go _ = return [] links <- liftIO $ mapM go imports - respond (Right (List (concat links))) + respond (Right (InL (concat links))) -diagnosticsHandler :: Uri -> HandlerM () -diagnosticsHandler _uri = do +diagnosticsHandler :: EvaluateSettings -> Uri -> HandlerM () +diagnosticsHandler settings _uri = do txt <- readUri _uri fileIdentifier <- fileIdentifierFromUri _uri -- make sure we don't keep a stale version around @@ -242,11 +257,11 @@ expr <- case parse txt of Right e -> return e Left err -> throwE err - loaded <- liftIO $ load fileIdentifier expr cache + loaded <- liftIO $ load settings fileIdentifier expr cache (cache', expr') <- case loaded of Right x -> return x Left err -> throwE err - _ <- case typecheck expr' of + _ <- case typecheck settings expr' of Right (wt, _typ) -> return wt Left err -> throwE err assign importCache cache' @@ -259,41 +274,44 @@ suggestionToDiagnostic Suggestion { range = range_, .. } = let _range = rangeToJSON range_ - _severity = Just DsHint + _severity = Just DiagnosticSeverity_Hint _source = Just "Dhall.Lint" _code = Nothing + _codeDescription = Nothing _message = suggestion _tags = Nothing _relatedInformation = Nothing + _data_ = Nothing in Diagnostic {..} 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 + _severity = Just DiagnosticSeverity_Error _source = Just doctor _code = Nothing + _codeDescription = Nothing _tags = Nothing _message = diagnosis _relatedInformation = Nothing + _data_ = Nothing in Diagnostic {..} modifying errors (Map.alter (const errs) _uri) -- cache errors let _version = Nothing let _diagnostics = - List ( concatMap (map diagnosisToDiagnostic . diagnose) (maybeToList errs) ++ map suggestionToDiagnostic suggestions ) - liftLSP (LSP.sendNotification STextDocumentPublishDiagnostics PublishDiagnosticsParams{ _uri, _version, _diagnostics }) + liftLSP (LSP.sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams{ _uri, _version, _diagnostics }) documentFormattingHandler :: Handlers HandlerM documentFormattingHandler = - LSP.requestHandler STextDocumentFormatting \request respond -> handleErrorWithDefault respond (List []) do + LSP.requestHandler SMethod_TextDocumentFormatting \request respond -> handleErrorWithDefault respond (InL []) do let _uri = request^.params.textDocument.uri txt <- readUri _uri @@ -308,21 +326,21 @@ let _newText= formatExprWithHeader chosenCharacterSet expr header let _range = LSP.Types.Range (Position 0 0) (Position numLines 0) - respond (Right (List [TextEdit{..}])) + respond (Right (InL [TextEdit{..}])) -executeCommandHandler :: Handlers HandlerM -executeCommandHandler = - LSP.requestHandler SWorkspaceExecuteCommand \request respond -> handleErrorWithDefault respond Aeson.Null do +executeCommandHandler :: EvaluateSettings -> Handlers HandlerM +executeCommandHandler settings = + LSP.requestHandler SMethod_WorkspaceExecuteCommand \request respond -> handleErrorWithDefault respond (InL Aeson.Null) do let command_ = request^.params.command if | command_ == "dhall.server.lint" -> executeLintAndFormat request respond | command_ == "dhall.server.annotateLet" -> - executeAnnotateLet request + executeAnnotateLet settings request | command_ == "dhall.server.freezeImport" -> - executeFreezeImport request + executeFreezeImport settings request | command_ == "dhall.server.freezeAllImports" -> - executeFreezeAllImports request + executeFreezeAllImports settings request | otherwise -> do throwE ( Warning @@ -330,11 +348,11 @@ ) getCommandArguments - :: FromJSON a => RequestMessage 'WorkspaceExecuteCommand -> HandlerM a + :: FromJSON a => TRequestMessage 'Method_WorkspaceExecuteCommand -> HandlerM a -- (HasParams s a, FromJSON a) => s -> HandlerM a getCommandArguments request = do json <- case request ^. params . arguments of - Just (List (x : _)) -> return x + Just (x : _) -> return x _ -> throwE (Error, "Failed to execute command; arguments missing.") case Aeson.fromJSON json of Aeson.Success args -> @@ -344,8 +362,8 @@ -- implements dhall.server.lint executeLintAndFormat - :: RequestMessage 'WorkspaceExecuteCommand - -> (Either a Value -> HandlerM b) + :: TRequestMessage 'Method_WorkspaceExecuteCommand + -> (Either a (Value |? Null) -> HandlerM b) -> HandlerM () executeLintAndFormat request respond = do uri_ <- getCommandArguments request @@ -365,30 +383,31 @@ let _edit = WorkspaceEdit - { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}])) + { _changes = Just (Map.singleton uri_ [TextEdit{..}]) , _documentChanges = Nothing , _changeAnnotations = Nothing } let _label = Nothing - _ <- respond (Right Aeson.Null) + _ <- respond (Right (InL Aeson.Null)) - _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler) + _ <- liftLSP (LSP.sendRequest SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler) return () executeAnnotateLet - :: RequestMessage 'WorkspaceExecuteCommand + :: EvaluateSettings + -> TRequestMessage 'Method_WorkspaceExecuteCommand -> HandlerM () -executeAnnotateLet request = do +executeAnnotateLet settings request = do args <- getCommandArguments request :: HandlerM TextDocumentPositionParams let uri_ = args ^. textDocument . uri line_ = fromIntegral (args ^. position . line) col_ = fromIntegral (args ^. position . character) - expr <- loadFile uri_ - (welltyped, _) <- case typecheck expr of + expr <- loadFile settings uri_ + (welltyped, _) <- case typecheck settings expr of Left _ -> throwE (Warning, "Failed to annotate let binding; not well-typed.") Right e -> return e @@ -405,21 +424,22 @@ let _newText= formatExpr chosenCharacterSet annotExpr let _edit = WorkspaceEdit - { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}])) + { _changes = Just (Map.singleton uri_ [TextEdit{..}]) , _documentChanges = Nothing , _changeAnnotations = Nothing } let _label = Nothing - _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler) + _ <- liftLSP (LSP.sendRequest SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams{ _label, _edit } nullHandler) return () executeFreezeAllImports - :: RequestMessage 'WorkspaceExecuteCommand + :: EvaluateSettings + -> TRequestMessage 'Method_WorkspaceExecuteCommand -> HandlerM () -executeFreezeAllImports request = do +executeFreezeAllImports settings request = do uri_ <- getCommandArguments request fileIdentifier <- fileIdentifierFromUri uri_ @@ -433,7 +453,7 @@ cache <- use importCache let importExpr = Embed (stripHash import_) - hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + hashResult <- liftIO $ computeSemanticHash settings fileIdentifier importExpr cache (cache', hash) <- case hashResult of Right (c, t) -> return (c, t) Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") @@ -444,21 +464,22 @@ return TextEdit{..} let _edit = WorkspaceEdit - { _changes = Just (HashMap.singleton uri_ (List edits_)) + { _changes = Just (Map.singleton uri_ edits_) , _documentChanges = Nothing , _changeAnnotations = Nothing } let _label = Nothing - _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler) + _ <- liftLSP (LSP.sendRequest SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler) return () executeFreezeImport - :: RequestMessage 'WorkspaceExecuteCommand + :: EvaluateSettings + -> TRequestMessage 'Method_WorkspaceExecuteCommand -> HandlerM () -executeFreezeImport request = do +executeFreezeImport settings request = do args <- getCommandArguments request :: HandlerM TextDocumentPositionParams let uri_ = args ^. textDocument . uri let line_ = fromIntegral (args ^. position . line) @@ -482,7 +503,7 @@ cache <- use importCache let importExpr = Embed (stripHash import_) - hashResult <- liftIO $ computeSemanticHash fileIdentifier importExpr cache + hashResult <- liftIO $ computeSemanticHash settings fileIdentifier importExpr cache (cache', hash) <- case hashResult of Right (c, t) -> return (c, t) Left _ -> throwE (Error, "Could not freeze import; failed to evaluate import.") @@ -492,20 +513,20 @@ let _newText = " " <> hash let _edit = WorkspaceEdit - { _changes = Just (HashMap.singleton uri_ (List [TextEdit{..}])) + { _changes = Just (Map.singleton uri_ [TextEdit{..}]) , _documentChanges = Nothing , _changeAnnotations = Nothing } let _label = Nothing - _ <- liftLSP (LSP.sendRequest SWorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler) + _ <- liftLSP (LSP.sendRequest SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams{ _edit, _label } nullHandler) return () -completionHandler :: Handlers HandlerM -completionHandler = - LSP.requestHandler STextDocumentCompletion \request respond -> handleErrorWithDefault respond (InR (CompletionList False (List []))) do +completionHandler :: EvaluateSettings -> Handlers HandlerM +completionHandler settings = + LSP.requestHandler SMethod_TextDocumentCompletion \request respond -> handleErrorWithDefault respond (InR (InL (CompletionList False Nothing []))) do let uri_ = request ^. params . textDocument . uri line_ = fromIntegral (request ^. params . position . line) col_ = fromIntegral (request ^. params . position . character) @@ -531,7 +552,7 @@ fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache - loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache + loadedBinders <- liftIO $ load settings fileIdentifier bindersExpr cache (cache', bindersExpr') <- case loadedBinders of @@ -545,7 +566,7 @@ Right e -> return e Left _ -> throwE (Log, "Could not complete projection; prefix did not parse.") - loaded' <- liftIO $ load fileIdentifier targetExpr cache' + loaded' <- liftIO $ load settings fileIdentifier targetExpr cache' case loaded' of Right (cache'', targetExpr') -> do assign importCache cache'' @@ -558,7 +579,7 @@ fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache -- todo save cache afterwards - loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache + loadedBinders <- liftIO $ load settings fileIdentifier bindersExpr cache bindersExpr' <- case loadedBinders of @@ -576,6 +597,7 @@ let toCompletionItem (Completion {..}) = CompletionItem {..} where _label = completeText + _labelDetails = Nothing _kind = Nothing _tags = mempty _detail = fmap pretty completeType @@ -588,70 +610,78 @@ _insertTextFormat = Nothing _insertTextMode = Nothing _textEdit = Nothing + _textEditText = Nothing _additionalTextEdits = Nothing _commitCharacters = Nothing _command = Nothing - _xdata = Nothing - - let _items = List (map toCompletionItem completions) + _data_ = Nothing + let _items = (map toCompletionItem completions) + let _itemDefaults = Nothing let _isIncomplete = False - respond (Right (InR CompletionList{..})) + respond (Right (InR (InL CompletionList{..}))) nullHandler :: a -> LspT ServerConfig IO () nullHandler _ = return () -didOpenTextDocumentNotificationHandler :: Handlers HandlerM -didOpenTextDocumentNotificationHandler = - LSP.notificationHandler STextDocumentDidOpen \notification -> do +didOpenTextDocumentNotificationHandler :: EvaluateSettings -> Handlers HandlerM +didOpenTextDocumentNotificationHandler settings = + LSP.notificationHandler SMethod_TextDocumentDidOpen \notification -> do let _uri = notification^.params.textDocument.uri - diagnosticsHandler _uri + diagnosticsHandler settings _uri -didSaveTextDocumentNotificationHandler :: Handlers HandlerM -didSaveTextDocumentNotificationHandler = - LSP.notificationHandler STextDocumentDidSave \notification -> do +didSaveTextDocumentNotificationHandler :: EvaluateSettings -> Handlers HandlerM +didSaveTextDocumentNotificationHandler settings = + LSP.notificationHandler SMethod_TextDocumentDidSave \notification -> do let _uri = notification^.params.textDocument.uri - diagnosticsHandler _uri + diagnosticsHandler settings _uri -- this handler is a stab to prevent `lsp:no handler for:` messages. initializedHandler :: Handlers HandlerM -initializedHandler = - LSP.notificationHandler SInitialized \_ -> return () +initializedHandler = + LSP.notificationHandler SMethod_Initialized \_ -> return () -- this handler is a stab to prevent `lsp:no handler for:` messages. workspaceChangeConfigurationHandler :: Handlers HandlerM -workspaceChangeConfigurationHandler = - LSP.notificationHandler SWorkspaceDidChangeConfiguration \_ -> return () +workspaceChangeConfigurationHandler = + LSP.notificationHandler SMethod_WorkspaceDidChangeConfiguration \_ -> return () -- this handler is a stab to prevent `lsp:no handler for:` messages. textDocumentChangeHandler :: Handlers HandlerM textDocumentChangeHandler = - LSP.notificationHandler STextDocumentDidChange \_ -> return () + LSP.notificationHandler SMethod_TextDocumentDidChange \_ -> return () -- this handler is a stab to prevent `lsp:no handler for:` messages. cancelationHandler :: Handlers HandlerM cancelationHandler = - LSP.notificationHandler SCancelRequest \_ -> return () + LSP.notificationHandler SMethod_CancelRequest \_ -> return () +-- This handler is a stub to prevent `lsp:no handler for:` messages. +documentDidCloseHandler :: Handlers HandlerM +documentDidCloseHandler = + LSP.notificationHandler SMethod_TextDocumentDidClose \_ -> return () + handleErrorWithDefault :: (Either a1 b -> HandlerM a2) -> b -> HandlerM a2 -> HandlerM a2 -handleErrorWithDefault respond _default = flip catchE handler +handleErrorWithDefault respond _default = flip catchE handler where handler (Log, _message) = do - let _xtype = MtLog - liftLSP $ LSP.sendNotification SWindowLogMessage LogMessageParams{..} + let _type_ = MessageType_Log + liftLSP $ LSP.sendNotification SMethod_WindowLogMessage LogMessageParams{..} respond (Right _default) handler (severity_, _message) = do - let _xtype = case severity_ of - Error -> MtError - Warning -> MtWarning - Info -> MtInfo - Log -> MtLog + let _type_ = case severity_ of + Error -> MessageType_Error + Warning -> MessageType_Warning + Info -> MessageType_Info +#if !MIN_TOOL_VERSION_ghc(9,2,0) + Log -> MessageType_Log +#endif - liftLSP $ LSP.sendNotification SWindowShowMessage ShowMessageParams{..} + liftLSP $ LSP.sendNotification SMethod_WindowShowMessage ShowMessageParams{..} respond (Right _default) diff --git a/src/Dhall/LSP/Server.hs b/src/Dhall/LSP/Server.hs --- a/src/Dhall/LSP/Server.hs +++ b/src/Dhall/LSP/Server.hs @@ -1,45 +1,68 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-| This is the entry point for the LSP server. -} -module Dhall.LSP.Server(run) where +module Dhall.LSP.Server ( + run + , runWith + ) where -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (fromJSON) +import Colog.Core (LogAction, WithSeverity) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (fromJSON) import Data.Default +import Dhall (EvaluateSettings, defaultEvaluateSettings) import Dhall.LSP.Handlers - ( completionHandler + ( cancelationHandler + , completionHandler , didOpenTextDocumentNotificationHandler , didSaveTextDocumentNotificationHandler + , documentDidCloseHandler , documentFormattingHandler , documentLinkHandler , executeCommandHandler , hoverHandler , initializedHandler - , workspaceChangeConfigurationHandler , textDocumentChangeHandler - , cancelationHandler + , workspaceChangeConfigurationHandler ) import Dhall.LSP.State -import Language.LSP.Server (Options(..), ServerDefinition(..), type (<~>)(..)) -import Language.LSP.Types -import System.Exit (ExitCode(..)) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server + ( LspServerLog + , Options (..) + , ServerDefinition (..) + , type (<~>) (..) + ) +import Prettyprinter (Doc, Pretty, pretty, viaShow) +import System.Exit (ExitCode (..)) +import System.IO (stdin, stdout) -import qualified Control.Concurrent.MVar as MVar -import qualified Control.Monad.Trans.Except as Except +import qualified Colog.Core as Colog +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 +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified Language.LSP.Logging as LSP +import qualified Language.LSP.Server as LSP +import qualified System.Exit as Exit -- | The main entry point for the LSP server. run :: Maybe FilePath -> IO () -run mlog = do - setupLogger mlog +run = runWith defaultEvaluateSettings +-- | The main entry point for the LSP server. +runWith :: EvaluateSettings -> Maybe FilePath -> IO () +runWith settings = withLogger $ \ioLogger -> do + let clientLogger = Colog.cmap (fmap (Text.pack . show . pretty)) LSP.defaultClientLogger + + let lspLogger = clientLogger <> Colog.hoistLogAction liftIO ioLogger + state <- MVar.newMVar initialState let defaultConfig = def @@ -53,16 +76,16 @@ return (Right environment) let options = def - { LSP.textDocumentSync = Just syncOptions + { LSP.optTextDocumentSync = Just syncOptions - , completionTriggerCharacters = Just [':', '.', '/'] + , optCompletionTriggerCharacters = 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 = + , optExecuteCommandCommands = Just [ "dhall.server.lint", "dhall.server.annotateLet", @@ -71,19 +94,20 @@ ] } - let staticHandlers = + let staticHandlers _clientCapabilities = mconcat - [ hoverHandler - , didOpenTextDocumentNotificationHandler - , didSaveTextDocumentNotificationHandler - , executeCommandHandler + [ hoverHandler settings + , didOpenTextDocumentNotificationHandler settings + , didSaveTextDocumentNotificationHandler settings + , executeCommandHandler settings , documentFormattingHandler , documentLinkHandler - , completionHandler + , completionHandler settings , initializedHandler , workspaceChangeConfigurationHandler , textDocumentChangeHandler , cancelationHandler + , documentDidCloseHandler ] let interpretHandler environment = Iso{..} @@ -95,20 +119,22 @@ (e, newState) <- State.runStateT (Except.runExceptT handler) oldState result <- case e of Left (Log, _message) -> do - let _xtype = MtLog + let _type_ = MessageType_Log - LSP.sendNotification SWindowLogMessage LogMessageParams{..} + LSP.sendNotification SMethod_WindowLogMessage LogMessageParams{..} liftIO (fail (Text.unpack _message)) Left (severity_, _message) -> do - let _xtype = case severity_ of - Error -> MtError - Warning -> MtWarning - Info -> MtInfo - Log -> MtLog + let _type_ = case severity_ of + Error -> MessageType_Error + Warning -> MessageType_Warning + Info -> MessageType_Info +#if !MIN_TOOL_VERSION_ghc(9,2,0) + Log -> MessageType_Log +#endif - LSP.sendNotification SWindowShowMessage ShowMessageParams{..} + LSP.sendNotification SMethod_WindowShowMessage ShowMessageParams{..} liftIO (fail (Text.unpack _message)) Right a -> do return a @@ -117,20 +143,26 @@ backward = liftIO - exitCode <- LSP.runServer ServerDefinition{..} + exitCode <- LSP.runServerWithHandles ioLogger lspLogger stdin stdout 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.setupLogger Nothing [] System.Log.Logger.DEBUG -setupLogger file = LSP.setupLogger file [] System.Log.Logger.DEBUG +-- | Retrieve the output logger. +-- If no filename is provided then logger is disabled, if input is the string +-- `[OUTPUT]` then we log to stderr. +-- TODO: ADD verbosity +withLogger :: (LogAction IO (WithSeverity LspServerLog) -> IO ()) -> Maybe FilePath -> IO () +withLogger k = \case + Nothing -> k (Colog.LogAction (const (pure ()))) + Just "[OUTPUT]" -> k' Colog.logStringStderr + Just fp -> Colog.withLogStringFile fp k' + where + k' = k . Colog.cmap (show . prettyMsg) + prettyMsg :: Pretty a => WithSeverity a -> Doc ann + prettyMsg l = "[" <> viaShow (Colog.getSeverity l) <> "] " <> pretty (Colog.getMsg l) -- 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 @@ -138,7 +170,7 @@ syncOptions :: TextDocumentSyncOptions syncOptions = TextDocumentSyncOptions { _openClose = Just True - , _change = Just TdSyncIncremental + , _change = Just TextDocumentSyncKind_Incremental , _willSave = Just False , _willSaveWaitUntil = Just False , _save = Just (InR (SaveOptions (Just False))) diff --git a/src/Dhall/LSP/State.hs b/src/Dhall/LSP/State.hs --- a/src/Dhall/LSP/State.hs +++ b/src/Dhall/LSP/State.hs @@ -21,7 +21,7 @@ import Dhall.Pretty (CharacterSet) import Language.LSP.Server (LspT) -import qualified Language.LSP.Types as J +import qualified Language.LSP.Protocol.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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -2,19 +2,19 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromJust) -import Language.LSP.Test -import Language.LSP.Types +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromJust) +import Language.LSP.Protocol.Types ( CompletionItem (..) , Diagnostic (..) , DiagnosticSeverity (..) , Hover (..) - , HoverContents (..) , MarkupContent (..) , Position (..) , Range (..) + , toEither ) +import Language.LSP.Test import Test.Tasty import Test.Tasty.Hspec @@ -37,13 +37,13 @@ docId <- openDoc "Types.dhall" "dhall" let typePos = Position 0 5 functionPos = Position 2 7 - extractContents = _contents . fromJust + extractContents = toEither . _contents . fromJust getValue = T.unpack . _value typeHover <- getHover docId typePos funcHover <- getHover docId functionPos liftIO $ do case (extractContents typeHover, extractContents funcHover) of - (HoverContents typeContent, HoverContents functionContent) -> do + (Left typeContent, Left functionContent) -> do getValue typeContent `shouldBe` "Type" getValue functionContent `shouldBe` "\8704(_isAdmin : Bool) \8594 { home : Text, name : Text }" _ -> error "test failed" @@ -65,24 +65,28 @@ {_start = Position { _line = 2, _character = 10 } , _end = Position { _line = 2, _character = 36 } } - , _severity = Just DsHint + , _severity = Just DiagnosticSeverity_Hint , _code = Nothing + , _codeDescription = Nothing , _source = Just "Dhall.Lint" , _message = "Unused let binding 'bob'" , _tags = Nothing , _relatedInformation = Nothing + , _data_ = Nothing } , Diagnostic { _range = Range { _start = Position { _line = 4, _character = 11 } , _end = Position { _line = 4, _character = 38 } } - , _severity = Just DsHint + , _severity = Just DiagnosticSeverity_Hint , _code = Nothing + , _codeDescription = Nothing , _source = Just "Dhall.Lint" , _message = "Unused let binding 'carl'" , _tags = Nothing , _relatedInformation = Nothing + , _data_ = Nothing } ] @@ -96,9 +100,9 @@ let diag1 = head diags diag2 = diags !! 1 liftIO $ do - _severity diag1 `shouldBe` Just DsHint + _severity diag1 `shouldBe` Just DiagnosticSeverity_Hint T.unpack (_message diag1) `shouldContain` "Superfluous 'in'" - _severity diag2 `shouldBe` Just DsHint + _severity diag2 `shouldBe` Just DiagnosticSeverity_Hint T.unpack (_message diag2) `shouldContain` "Unused let binding" codeCompletionSpec :: FilePath -> Spec @@ -163,7 +167,7 @@ _ <- openDoc "UnboundVar.dhall" "dhall" [diag] <- waitForDiagnosticsSource "Dhall.TypeCheck" liftIO $ do - _severity diag `shouldBe` Just DsError + _severity diag `shouldBe` Just DiagnosticSeverity_Error T.unpack (_message diag) `shouldContain` "Unbound variable" it "reports wrong type" $ runSession "dhall-lsp-server" fullCaps fixtureDir @@ -171,7 +175,7 @@ _ <- openDoc "WrongType.dhall" "dhall" [diag] <- waitForDiagnosticsSource "Dhall.TypeCheck" liftIO $ do - _severity diag `shouldBe` Just DsError + _severity diag `shouldBe` Just DiagnosticSeverity_Error T.unpack (_message diag) `shouldContain` "Expression doesn't match annotation" describe "Dhall.Import" $ do it "reports invalid imports" @@ -180,7 +184,7 @@ _ <- openDoc "InvalidImport.dhall" "dhall" [diag] <- waitForDiagnosticsSource "Dhall.Import" liftIO $ do - _severity diag `shouldBe` Just DsError + _severity diag `shouldBe` Just DiagnosticSeverity_Error T.unpack (_message diag) `shouldContain` "Invalid input" it "reports missing imports" $ runSession "dhall-lsp-server" fullCaps fixtureDir @@ -188,7 +192,7 @@ _ <- openDoc "MissingImport.dhall" "dhall" [diag] <- waitForDiagnosticsSource "Dhall.Import" liftIO $ do - _severity diag `shouldBe` Just DsError + _severity diag `shouldBe` Just DiagnosticSeverity_Error T.unpack (_message diag) `shouldContain` "Missing file" describe "Dhall.Parser" $ it "reports invalid syntax" @@ -196,7 +200,7 @@ $ do _ <- openDoc "InvalidSyntax.dhall" "dhall" [diag] <- waitForDiagnosticsSource "Dhall.Parser" - liftIO $ _severity diag `shouldBe` Just DsError + liftIO $ _severity diag `shouldBe` Just DiagnosticSeverity_Error main :: IO () main = do