dhall-lsp-server 1.1.3 → 1.1.4
raw patch · 9 files changed
+340/−251 lines, 9 filesdep +co-log-coredep +text-ropedep −hsloggerdep −rope-utf16-splaydep ~basedep ~containersdep ~data-default
Dependencies added: co-log-core, text-rope
Dependencies removed: hslogger, rope-utf16-splay
Dependency ranges changed: base, containers, data-default, hspec, lens, lsp, lsp-test, lsp-types, mtl, transformers
Files
- dhall-lsp-server.cabal +24/−24
- doctest/Main.hs +9/−6
- src/Dhall/LSP/Backend/Completion.hs +4/−3
- src/Dhall/LSP/Backend/Dhall.hs +50/−36
- src/Dhall/LSP/Backend/Freezing.hs +11/−6
- src/Dhall/LSP/Handlers.hs +145/−115
- src/Dhall/LSP/Server.hs +76/−44
- src/Dhall/LSP/State.hs +1/−1
- tests/Main.hs +20/−16
dhall-lsp-server.cabal view
@@ -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
doctest/Main.hs view
@@ -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" ]
src/Dhall/LSP/Backend/Completion.hs view
@@ -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 _ = []
src/Dhall/LSP/Backend/Dhall.hs view
@@ -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
src/Dhall/LSP/Backend/Freezing.hs view
@@ -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) =
src/Dhall/LSP/Handlers.hs view
@@ -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)
src/Dhall/LSP/Server.hs view
@@ -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)))
src/Dhall/LSP/State.hs view
@@ -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
tests/Main.hs view
@@ -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