diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs index a4dcadc9a..8b44cd6a8 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs @@ -7,7 +7,7 @@ import Dhall.Context (Context, empty, insert, toList) import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset) import Dhall.LSP.Backend.Parsing (holeExpr) import Dhall.Parser (Src, exprFromText) -import Dhall.Pretty (UnescapedLabel(..)) +import Dhall.Pretty (UnescapedLabel (..)) import Dhall.TypeCheck (typeOf, typeWithA) import System.Directory (doesDirectoryExist, listDirectory) import System.Environment (getEnvironment) diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs index e7e60df83..280fd486c 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs @@ -28,6 +28,7 @@ import Data.Bifunctor (first) 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 @@ import System.FilePath , 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 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 +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 @@ fileIdentifierFromFilePath path = 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 WellTyped = WellTyped {fromWellTyped :: Expr Src Void} 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 -> Cache -> Cache 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 @@ invalidate (FileIdentifier chained) (Cache dependencies cache) = 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 :: Text -> Either DhallError (Dhall.Header, Expr Src Dhall.Impor 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/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs index 3c19acd73..af20f4c04 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Freezing.hs @@ -7,6 +7,7 @@ module Dhall.LSP.Backend.Freezing ( import Control.Lens (universeOf) import Data.Text (Text) +import Dhall (EvaluateSettings) import Dhall.Core ( Expr (..) , Import (..) @@ -37,16 +38,20 @@ import qualified Data.Text as Text -- | 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/dhall-lsp-server/src/Dhall/LSP/Handlers.hs b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs index 178914b76..1ffdc5bd8 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs @@ -1,14 +1,15 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ViewPatterns #-} +{-# 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 (..) @@ -59,30 +60,43 @@ import Dhall.LSP.Backend.Parsing (binderExprFromText) import Dhall.LSP.Backend.Typing (annotateLet, exprAt, typeAt) import Dhall.LSP.State -import Control.Applicative ((<|>)) -import Control.Lens (assign, modifying, use, (^.)) -import Control.Monad (forM, guard) -import Control.Monad.Trans (lift, liftIO) -import Control.Monad.Trans.Except (catchE, throwE) -import Data.Aeson (FromJSON(..), Value(..)) -import Data.Maybe (maybeToList) -import Data.Text (Text, isPrefixOf) -import Language.LSP.Server (Handlers, LspT) -import Language.LSP.Protocol.Types hiding (Range(..)) -import Language.LSP.Protocol.Message +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 -import System.FilePath -import Text.Megaparsec (SourcePos (..), unPos) - -import qualified Data.Aeson as Aeson -import qualified Data.Map.Strict as Map -import qualified Data.Text.Utf16.Rope as Rope -import qualified Data.Text as Text -import qualified Language.LSP.Server as LSP + ( 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.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.VFS as LSP -import qualified Network.URI as URI -import qualified Network.URI.Encode as URI +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) @@ -95,8 +109,8 @@ readUri uri_ = do 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 @@ -105,7 +119,7 @@ loadFile uri_ = do 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.") @@ -131,8 +145,8 @@ rangeToJSON (Range (x1,y1) (x2,y2)) = (Position (fromIntegral x1) (fromIntegral y1)) (Position (fromIntegral x2) (fromIntegral y2)) -hoverHandler :: Handlers HandlerM -hoverHandler = +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 @@ -142,8 +156,8 @@ hoverHandler = 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 @@ -231,8 +245,8 @@ documentLinkHandler = 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 @@ -243,11 +257,11 @@ diagnosticsHandler _uri = do 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' @@ -315,18 +329,18 @@ documentFormattingHandler = respond (Right (InL [TextEdit{..}])) -executeCommandHandler :: Handlers HandlerM -executeCommandHandler = +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 @@ -383,16 +397,17 @@ executeLintAndFormat request respond = do return () executeAnnotateLet - :: TRequestMessage 'Method_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 @@ -421,9 +436,10 @@ executeAnnotateLet request = do return () executeFreezeAllImports - :: TRequestMessage 'Method_WorkspaceExecuteCommand + :: EvaluateSettings + -> TRequestMessage 'Method_WorkspaceExecuteCommand -> HandlerM () -executeFreezeAllImports request = do +executeFreezeAllImports settings request = do uri_ <- getCommandArguments request fileIdentifier <- fileIdentifierFromUri uri_ @@ -437,7 +453,7 @@ executeFreezeAllImports request = do 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.") @@ -460,9 +476,10 @@ executeFreezeAllImports request = do return () executeFreezeImport - :: TRequestMessage 'Method_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) @@ -486,7 +503,7 @@ executeFreezeImport request = do 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.") @@ -507,8 +524,8 @@ executeFreezeImport request = do return () -completionHandler :: Handlers HandlerM -completionHandler = +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) @@ -535,7 +552,7 @@ completionHandler = fileIdentifier <- fileIdentifierFromUri uri_ cache <- use importCache - loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache + loadedBinders <- liftIO $ load settings fileIdentifier bindersExpr cache (cache', bindersExpr') <- case loadedBinders of @@ -549,7 +566,7 @@ completionHandler = 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'' @@ -562,7 +579,7 @@ completionHandler = 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 @@ -608,17 +625,17 @@ completionHandler = nullHandler :: a -> LspT ServerConfig IO () nullHandler _ = return () -didOpenTextDocumentNotificationHandler :: Handlers HandlerM -didOpenTextDocumentNotificationHandler = +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 = +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. @@ -662,7 +679,9 @@ handleErrorWithDefault respond _default = flip catchE handler Error -> MessageType_Error Warning -> MessageType_Warning Info -> MessageType_Info +#if !MIN_TOOL_VERSION_ghc(9,2,0) Log -> MessageType_Log +#endif liftLSP $ LSP.sendNotification SMethod_WindowShowMessage ShowMessageParams{..} respond (Right _default) diff --git a/dhall-lsp-server/src/Dhall/LSP/Server.hs b/dhall-lsp-server/src/Dhall/LSP/Server.hs index 36f174a96..a8e76152e 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Server.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Server.hs @@ -1,50 +1,64 @@ {-# 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 - -import Colog.Core (LogAction, WithSeverity) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (fromJSON) +module Dhall.LSP.Server ( + run + , runWith + ) where + +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 - , documentDidCloseHandler + , workspaceChangeConfigurationHandler ) import Dhall.LSP.State -import Language.LSP.Server (LspServerLog, Options(..), ServerDefinition(..), type (<~>)(..)) -import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message -import Prettyprinter (Doc, Pretty, pretty, viaShow) -import System.Exit (ExitCode(..)) -import System.IO (stdin, stdout) +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 Colog.Core as Colog -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.Logging as LSP -import qualified Language.LSP.Server as LSP -import qualified System.Exit as Exit +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 = withLogger $ \ioLogger -> do +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 @@ -82,13 +96,13 @@ run = withLogger $ \ioLogger -> do let staticHandlers _clientCapabilities = mconcat - [ hoverHandler - , didOpenTextDocumentNotificationHandler - , didSaveTextDocumentNotificationHandler - , executeCommandHandler + [ hoverHandler settings + , didOpenTextDocumentNotificationHandler settings + , didSaveTextDocumentNotificationHandler settings + , executeCommandHandler settings , documentFormattingHandler , documentLinkHandler - , completionHandler + , completionHandler settings , initializedHandler , workspaceChangeConfigurationHandler , textDocumentChangeHandler @@ -116,7 +130,9 @@ run = withLogger $ \ioLogger -> do Error -> MessageType_Error Warning -> MessageType_Warning Info -> MessageType_Info +#if !MIN_TOOL_VERSION_ghc(9,2,0) Log -> MessageType_Log +#endif LSP.sendNotification SMethod_WindowShowMessage ShowMessageParams{..} liftIO (fail (Text.unpack _message)) diff --git a/dhall-lsp-server/tests/Main.hs b/dhall-lsp-server/tests/Main.hs index 7edbe6971..5bc44361a 100644 --- a/dhall-lsp-server/tests/Main.hs +++ b/dhall-lsp-server/tests/Main.hs @@ -2,9 +2,8 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromJust) -import Language.LSP.Test +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromJust) import Language.LSP.Protocol.Types ( CompletionItem (..) , Diagnostic (..) @@ -15,6 +14,7 @@ import Language.LSP.Protocol.Types , Range (..) , toEither ) +import Language.LSP.Test import Test.Tasty import Test.Tasty.Hspec