From 41ecc7bd7a4c9c92f966562bff4bfc2adbc20cff Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 16 May 2018 13:03:53 -0400 Subject: [PATCH] Initial commit --- .gitignore | 2 + LICENSE | 30 ++++++++ README.md | 2 + Setup.hs | 2 + example/Main.hs | 16 +++++ haskell-lsp-test.cabal | 44 ++++++++++++ src/Capabilities.hs | 43 +++++++++++ src/Compat.hs | 18 +++++ src/Language/Haskell/LSP/Test.hs | 120 +++++++++++++++++++++++++++++++ stack.yaml | 8 +++ 10 files changed, 285 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 example/Main.hs create mode 100644 haskell-lsp-test.cabal create mode 100644 src/Capabilities.hs create mode 100644 src/Compat.hs create mode 100644 src/Language/Haskell/LSP/Test.hs create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5e6993c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work +**/.DS_Store diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..de86d49 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Luke Lau (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Luke Lau nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..b42dfcf --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# haskell-lsp-test +This is the functional testing framework for [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine), and potentially any other Language Server Protocol server. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 index 0000000..9318bcb --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,16 @@ +import Language.Haskell.LSP.Test +import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import qualified Data.Text.IO as T +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import System.Directory +import System.Environment + +main = do + files <- getArgs + forM_ files $ \file -> session $ do + file <- liftIO $ canonicalizePath file + openDocument file + symbols <- documentSymbols file + liftIO $ mapM_ T.putStrLn (symbols ^.. traverse . LSP.name) diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal new file mode 100644 index 0000000..44c0487 --- /dev/null +++ b/haskell-lsp-test.cabal @@ -0,0 +1,44 @@ +name: haskell-lsp-test +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/Bubba/haskell-lsp-test#readme +license: BSD3 +license-file: LICENSE +author: Luke Lau +maintainer: luke_lau@icloud.com +copyright: 2018 Luke Lau +category: Testing +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + hs-source-dirs: src + exposed-modules: Language.Haskell.LSP.Test + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp-client + , haskell-lsp-types + , lens + , text + , transformers + , process + if os(windows) + build-depends: win32 + else + build-depends: unix + other-modules: Compat + Capabilities + ghc-options: -W + +executable example + hs-source-dirs: example + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp-test + , haskell-lsp-types + , lens + , text + , directory diff --git a/src/Capabilities.hs b/src/Capabilities.hs new file mode 100644 index 0000000..f1cc6ee --- /dev/null +++ b/src/Capabilities.hs @@ -0,0 +1,43 @@ +module Capabilities where + +import Language.Haskell.LSP.TH.ClientCapabilities + +capabilities :: ClientCapabilities +capabilities = ClientCapabilities (Just workspaceCapabilities) + (Just textDocumentCapabilities) + Nothing + where + workspaceCapabilities = WorkspaceClientCapabilities + (Just False) + (Just (WorkspaceEditClientCapabilities (Just False))) + (Just (DidChangeConfigurationClientCapabilities (Just False))) + (Just (DidChangeWatchedFilesClientCapabilities (Just False))) + (Just (SymbolClientCapabilities (Just False))) + (Just (ExecuteClientCapabilities (Just False))) + textDocumentCapabilities = TextDocumentClientCapabilities + (Just + (SynchronizationTextDocumentClientCapabilities (Just False) + (Just False) + (Just False) + (Just False) + ) + ) + (Just + (CompletionClientCapabilities + (Just False) + (Just (CompletionItemClientCapabilities (Just False))) + ) + ) + (Just (HoverClientCapabilities (Just False))) + (Just (SignatureHelpClientCapabilities (Just False))) + (Just (ReferencesClientCapabilities (Just False))) + (Just (DocumentHighlightClientCapabilities (Just False))) + (Just (DocumentSymbolClientCapabilities (Just False))) + (Just (FormattingClientCapabilities (Just False))) + (Just (RangeFormattingClientCapabilities (Just False))) + (Just (OnTypeFormattingClientCapabilities (Just False))) + (Just (DefinitionClientCapabilities (Just False))) + (Just (CodeActionClientCapabilities (Just False))) + (Just (CodeLensClientCapabilities (Just False))) + (Just (DocumentLinkClientCapabilities (Just False))) + (Just (RenameClientCapabilities (Just False))) diff --git a/src/Compat.hs b/src/Compat.hs new file mode 100644 index 0000000..23a3ff1 --- /dev/null +++ b/src/Compat.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} + +module Compat where + + +#ifdef mingw32_HOST_OS + +import qualified System.Win32.Process as P (getCurrentProcessId) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getCurrentProcessId + +#else + +import qualified System.Posix.Process as P (getProcessID) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getProcessID + +#endif diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs new file mode 100644 index 0000000..6ee8405 --- /dev/null +++ b/src/Language/Haskell/LSP/Test.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test + ( + -- * Sessions + session + -- * Documents + , openDocument + , documentSymbols + ) where + +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Maybe +import Data.Proxy +import System.Process +import qualified Language.Haskell.LSP.Client as Client +import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import Capabilities +import Compat + +type Session = ReaderT Client.Client IO + +session :: Session a -> IO () +session f = do + (Just hin, Just hout, _, serverProc) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) + { std_in = CreatePipe, std_out = CreatePipe } + client <- Client.start $ Client.Config hin hout notificationHandler requestHandler + + pid <- getProcessID + + let initializeParams :: LSP.InitializeParams + initializeParams = LSP.InitializeParams (Just pid) + Nothing + Nothing + Nothing + capabilities + Nothing + + Client.sendClientRequest client + (Proxy :: Proxy LSP.InitializeRequest) + LSP.Initialize initializeParams + Client.sendClientNotification client + LSP.Initialized + (Just LSP.InitializedParams) + + putStrLn "Session started" + + runReaderT f client + + Client.sendClientRequest client + (Proxy :: Proxy LSP.ShutdownRequest) + LSP.Shutdown Nothing + Client.sendClientNotification client + LSP.Exit + (Just LSP.ExitParams) + + Client.stop client + + -- todo: this interrupts the test server process as well? + -- interruptProcessGroupOf serverProc + -- waitForProcess serverProc + terminateProcess serverProc + + putStrLn "Session ended" + +openDocument :: FilePath -> Session () +openDocument path = do + text <- liftIO $ T.readFile path + + let uri = LSP.filePathToUri path + + client <- ask + liftIO $ Client.sendClientNotification client LSP.TextDocumentDidOpen (Just (LSP.DidOpenTextDocumentParams (LSP.TextDocumentItem uri "haskell" 1 text))) + +documentSymbols :: FilePath -> Session (LSP.List LSP.SymbolInformation) +documentSymbols path = do + let uri = LSP.filePathToUri path + + client <- ask + + liftIO $ do + res <- Client.sendClientRequest client + (Proxy :: Proxy LSP.DocumentSymbolRequest) + LSP.TextDocumentDocumentSymbol (LSP.DocumentSymbolParams (LSP.TextDocumentIdentifier uri)) + return $ case res of + Just (Right syms) -> syms + _ -> error "Failed to get document symbols" + +notificationHandler :: Client.NotificationMessageHandler +notificationHandler = Client.NotificationMessageHandler + (\(LSP.NotificationMessage _ _ (LSP.ShowMessageParams _ msg)) -> print msg) + (\(LSP.NotificationMessage _ _ (LSP.LogMessageParams _ msg)) -> print msg) + (\(LSP.NotificationMessage _ _ json) -> putStrLn $ "Telemetry: " ++ show json) + (\(LSP.NotificationMessage _ _ (LSP.PublishDiagnosticsParams uri diags)) -> + putStrLn $ "Diagnostics at " ++ showUri uri ++ ": " ++ showDiags diags) + + where showDiags :: LSP.List LSP.Diagnostic -> String + showDiags (LSP.List diags) = unlines $ map (T.unpack . (^. LSP.message)) diags + showUri :: LSP.Uri -> String + showUri = fromMaybe "unknown path" . LSP.uriToFilePath + + + +requestHandler :: Client.RequestMessageHandler +requestHandler = Client.RequestMessageHandler + (\m -> emptyRsp m <$ print m) + (\m -> emptyRsp m <$ print m) + (\m -> emptyRsp m <$ print m) + (\m -> emptyRsp m <$ print m) + where emptyRsp :: LSP.RequestMessage m req rsp -> LSP.ResponseMessage a + emptyRsp m = LSP.ResponseMessage (m ^. LSP.jsonrpc) + (lspIdToRspId $ m ^. LSP.id) + Nothing + Nothing + + lspIdToRspId (LSP.IdInt i) = LSP.IdRspInt i + lspIdToRspId (LSP.IdString i) = LSP.IdRspString i diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..d1bf7cc --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +resolver: nightly-2018-04-24 +packages: + - . + +extra-deps: + - github: Bubba/haskell-lsp-client + commit: b7cf14eb48837a73032e867dab90db1708220c66 + - haskell-lsp-types-0.2.2.0 -- 2.30.2