From 62dfd1cc691012ae17b39fc3f251d1472a41d1e5 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Mon, 4 Nov 2024 11:32:44 -0800 Subject: [PATCH] server: delete old Haskell implementation --- cn-lsp/server-hs/.gitignore | 4 - cn-lsp/server-hs/README.md | 23 --- cn-lsp/server-hs/app/Main.hs | 27 --- cn-lsp/server-hs/bin/debug-server | 6 - cn-lsp/server-hs/cabal.project.freeze | 169 ------------------ cn-lsp/server-hs/cn-lsp-server.cabal | 77 -------- cn-lsp/server-hs/install.sh | 12 -- cn-lsp/server-hs/src/CN.hs | 127 ------------- cn-lsp/server-hs/src/Handlers.hs | 63 ------- cn-lsp/server-hs/src/Handlers/Custom/RunCN.hs | 105 ----------- cn-lsp/server-hs/src/Handlers/Initialized.hs | 17 -- .../src/Handlers/TextDocument/DidChange.hs | 30 ---- .../src/Handlers/TextDocument/DidClose.hs | 27 --- .../src/Handlers/TextDocument/DidOpen.hs | 27 --- .../src/Handlers/TextDocument/DidSave.hs | 35 ---- .../Workspace/DidChangeConfiguration.hs | 25 --- cn-lsp/server-hs/src/Log.hs | 86 --------- cn-lsp/server-hs/src/Monad.hs | 55 ------ cn-lsp/server-hs/src/Server.hs | 94 ---------- cn-lsp/server-hs/src/Util.hs | 20 --- cn-lsp/server-hs/test/Main.hs | 4 - 21 files changed, 1033 deletions(-) delete mode 100644 cn-lsp/server-hs/.gitignore delete mode 100644 cn-lsp/server-hs/README.md delete mode 100644 cn-lsp/server-hs/app/Main.hs delete mode 100755 cn-lsp/server-hs/bin/debug-server delete mode 100644 cn-lsp/server-hs/cabal.project.freeze delete mode 100644 cn-lsp/server-hs/cn-lsp-server.cabal delete mode 100755 cn-lsp/server-hs/install.sh delete mode 100644 cn-lsp/server-hs/src/CN.hs delete mode 100644 cn-lsp/server-hs/src/Handlers.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/Custom/RunCN.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/Initialized.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/TextDocument/DidChange.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/TextDocument/DidClose.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/TextDocument/DidOpen.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/TextDocument/DidSave.hs delete mode 100644 cn-lsp/server-hs/src/Handlers/Workspace/DidChangeConfiguration.hs delete mode 100644 cn-lsp/server-hs/src/Log.hs delete mode 100644 cn-lsp/server-hs/src/Monad.hs delete mode 100644 cn-lsp/server-hs/src/Server.hs delete mode 100644 cn-lsp/server-hs/src/Util.hs delete mode 100644 cn-lsp/server-hs/test/Main.hs diff --git a/cn-lsp/server-hs/.gitignore b/cn-lsp/server-hs/.gitignore deleted file mode 100644 index b173d6f..0000000 --- a/cn-lsp/server-hs/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -dist-newstyle/ -bin/cn-lsp-server -bin/inputs.txt -bin/outputs.txt diff --git a/cn-lsp/server-hs/README.md b/cn-lsp/server-hs/README.md deleted file mode 100644 index cc6522b..0000000 --- a/cn-lsp/server-hs/README.md +++ /dev/null @@ -1,23 +0,0 @@ -# Building and Running - -This application should be buildable with `cabal` version 3.10.3.0 and `ghc` -version 9.6.4. The easiest way to install these tools locally is via -[GHCup](https://www.haskell.org/ghcup/). - -Run `install.sh` to build and install the application executable. This will make -the executable available in two places: -- In `bin/cn-lsp-server` -- In `~/.cabal/bin` - -You should add `~/.cabal/bin` to your `$PATH` - this is the easiest way to let -installed clients locate find the executable they need. See [our client's -README](../client/README.md) for details on how it searches for a server -executable. - -If all goes well, running the client should automatically start the server as a -child process. - -The server requires a `cn` executable be available, and will fail to start -without one. If the environment variable `CN` is set, the server will treat its -contents as the path to a `cn` executable. If `CN` isn't set, it will look for -the first thing named `cn` on the user's `PATH`. diff --git a/cn-lsp/server-hs/app/Main.hs b/cn-lsp/server-hs/app/Main.hs deleted file mode 100644 index ba3439c..0000000 --- a/cn-lsp/server-hs/app/Main.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Main where - -import GHC.IO.Encoding (setLocaleEncoding) -import Language.LSP.Server qualified as LSP -import Server (mkServer) -import System.Environment (getArgs) -import System.IO (IOMode (WriteMode), utf8, withFile) - -main :: IO Int -main = - do - -- We set this explicitly because the default encoding can sometimes/somehow - -- end up as ASCII when this is run as a child process by a language client. - -- This leads to errors when decoding CN output, because CN prints - -- characters outside the ASCII range. - setLocaleEncoding utf8 - args <- getArgs - case args of - [logFile] -> runServer logFile - _ -> error ("unexpected arguments: " <> show args) - -runServer :: FilePath -> IO Int -runServer logFile = - withFile - logFile - WriteMode - (\hdl -> LSP.runServer (mkServer hdl)) diff --git a/cn-lsp/server-hs/bin/debug-server b/cn-lsp/server-hs/bin/debug-server deleted file mode 100755 index 9c2f442..0000000 --- a/cn-lsp/server-hs/bin/debug-server +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -HERE=$(dirname $0) -LOGFILE=$1 - -tee $HERE/inputs.txt | $HERE/cn-lsp-server $LOGFILE | tee $HERE/outputs.txt diff --git a/cn-lsp/server-hs/cabal.project.freeze b/cn-lsp/server-hs/cabal.project.freeze deleted file mode 100644 index b883b0e..0000000 --- a/cn-lsp/server-hs/cabal.project.freeze +++ /dev/null @@ -1,169 +0,0 @@ -active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.10.1.0, - any.Cabal-syntax ==3.10.1.0, - any.Diff ==0.5, - any.OneTuple ==0.4.2, - any.QuickCheck ==2.14.3, - QuickCheck -old-random +templatehaskell, - any.StateVar ==1.2.2, - any.adjunctions ==4.4.2, - any.aeson ==2.2.2.0, - aeson +ordered-keymap, - any.array ==0.5.6.0, - any.assoc ==1.1.1, - assoc -tagged, - any.async ==2.2.5, - async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.base ==4.18.2.0, - any.base-compat ==0.14.0, - any.base-orphans ==0.9.2, - any.bifunctors ==5.6.2, - bifunctors +tagged, - any.binary ==0.8.9.1, - any.boring ==0.2.2, - boring +tagged, - any.bytestring ==0.11.5.3, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.character-ps ==0.1, - any.clock ==0.8.4, - clock -llvm, - any.co-log-core ==0.3.2.2, - any.comonad ==5.0.8, - comonad +containers +distributive +indexed-traversable, - any.constraints ==0.14.2, - any.containers ==0.6.7, - any.contravariant ==1.5.5, - contravariant +semigroups +statevar +tagged, - any.cryptohash-md5 ==0.11.101.0, - any.cryptohash-sha1 ==0.11.101.0, - any.data-default ==0.7.1.1, - any.data-default-class ==0.1.2.0, - any.data-default-instances-containers ==0.0.1, - any.data-default-instances-dlist ==0.0.1, - any.data-default-instances-old-locale ==0.0.1, - any.data-fix ==0.3.3, - any.deepseq ==1.4.8.1, - any.directory ==1.3.8.1, - any.distributive ==0.6.2.1, - distributive +semigroups +tagged, - any.dlist ==1.0, - dlist -werror, - any.entropy ==0.4.1.10, - entropy -donotgetentropy, - any.exceptions ==0.10.7, - any.extra ==1.7.16, - any.file-embed ==0.0.16.0, - any.filepath ==1.4.200.1, - any.free ==5.2, - any.generic-arbitrary ==1.0.1, - any.generic-lens ==2.2.2.0, - any.generic-lens-core ==2.2.1.0, - any.generically ==0.1.1, - any.ghc-bignum ==1.3, - any.ghc-boot-th ==9.6.4, - any.ghc-prim ==0.10.0, - any.hashable ==1.4.4.0, - hashable +integer-gmp -random-initial-seed, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.indexed-profunctors ==0.1.1.1, - any.indexed-traversable ==0.1.4, - any.indexed-traversable-instances ==0.1.2, - any.integer-conversion ==0.1.1, - any.integer-logarithms ==1.0.3.1, - integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.6.3, - any.kan-extensions ==5.2.6, - any.lens ==5.3.2, - lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.lens-aeson ==1.2.3, - any.lsp ==2.6.0.0, - lsp -demo, - any.lsp-types ==2.2.0.0, - lsp-types -force-ospath, - any.mod ==0.2.0.1, - mod +semirings +vector, - any.mtl ==2.3.1, - any.network-info ==0.2.1, - any.network-uri ==2.6.4.2, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.4, - any.os-string ==2.0.2.2, - any.parallel ==3.2.2.0, - any.parsec ==3.1.16.1, - any.pretty ==1.1.3.6, - any.prettyprinter ==1.7.1, - prettyprinter -buildreadme +text, - any.primitive ==0.9.0.0, - any.process ==1.6.17.0, - any.profunctors ==5.6.2, - any.quickcheck-instances ==0.3.30, - quickcheck-instances -bytestring-builder, - any.random ==1.2.1.2, - any.reflection ==2.1.8, - reflection -slow +template-haskell, - any.regex ==1.1.0.2, - any.regex-base ==0.94.0.2, - any.regex-pcre-builtin ==0.95.2.3.8.44, - any.regex-tdfa ==1.3.2.2, - regex-tdfa +doctest -force-o2, - any.row-types ==1.0.1.2, - any.rts ==1.0.2, - any.safe ==0.3.21, - any.safe-exceptions ==0.1.7.4, - any.scientific ==0.3.8.0, - scientific -integer-simple, - any.semialign ==1.3.1, - semialign +semigroupoids, - any.semigroupoids ==6.0.1, - semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, - any.semigroups ==0.20, - semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, - any.semirings ==0.7, - semirings +containers +unordered-containers, - any.some ==1.0.6, - some +newtype-unsafe, - any.sorted-list ==0.2.2.0, - any.splitmix ==0.1.0.5, - splitmix -optimised-mixer, - any.stm ==2.5.1.0, - any.strict ==0.5, - any.tagged ==0.8.8, - tagged +deepseq +transformers, - any.template-haskell ==2.20.0.0, - any.text ==2.0.2, - any.text-iso8601 ==0.1.1, - any.text-rope ==0.2, - text-rope -debug, - any.text-short ==0.1.6, - text-short -asserts, - any.th-abstraction ==0.7.0.0, - any.th-compat ==0.1.5, - any.these ==1.2.1, - any.time ==1.12.2, - any.time-compat ==1.9.7, - any.time-locale-compat ==0.1.1.5, - time-locale-compat -old-locale, - any.transformers ==0.6.1.0, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.2, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.unix ==2.8.4.0, - any.unliftio ==0.2.25.0, - any.unliftio-core ==0.2.1.0, - any.unordered-containers ==0.2.20, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.uuid ==1.3.15, - any.uuid-types ==1.0.5.1, - any.vector ==0.13.1.0, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-stream ==0.1.0.1, - any.void ==0.7.3, - void -safe, - any.witherable ==0.5 -index-state: hackage.haskell.org 2024-05-23T23:25:02Z diff --git a/cn-lsp/server-hs/cn-lsp-server.cabal b/cn-lsp/server-hs/cn-lsp-server.cabal deleted file mode 100644 index ebcc10f..0000000 --- a/cn-lsp/server-hs/cn-lsp-server.cabal +++ /dev/null @@ -1,77 +0,0 @@ -cabal-version: 3.0 - -author: Sam Cowger -build-type: Simple -category: Language -license: NONE -maintainer: sam@galois.com -name: cn-lsp-server -version: 0.0.1 - - -common basis - ghc-options: - -Wall - -Wextra - -Wunticked-promoted-constructors - - default-language: GHC2021 - - default-extensions: - BlockArguments - ExplicitNamespaces - LambdaCase - RecordWildCards - - build-depends: - base >=4.16.0.0 && <15, - aeson ^>=2.2.1.0, - co-log-core ^>=0.3.2.1, - lsp ^>=2.6.0.0, - lsp-types ^>=2.2.0.0, - mtl ^>=2.3.1, - process ^>=1.6.17.0, - text ^>=2.0.2, - unliftio-core ^>=0.2.1.0, - vector ^>=0.13.1.0, - -library - import: basis - - hs-source-dirs: src - - exposed-modules: - CN - Handlers - Handlers.Custom.RunCN - Handlers.Initialized - Handlers.TextDocument.DidChange - Handlers.TextDocument.DidClose - Handlers.TextDocument.DidOpen - Handlers.TextDocument.DidSave - Handlers.Workspace.DidChangeConfiguration - Log - Monad - Server - Util - - -executable cn-lsp-server - import: basis - - hs-source-dirs: app - main-is: Main.hs - - build-depends: - cn-lsp-server, - - -test-suite cn-lsp-server-test - import: basis - - hs-source-dirs: test - main-is: Main.hs - type: exitcode-stdio-1.0 - - build-depends: - cn-lsp-server, diff --git a/cn-lsp/server-hs/install.sh b/cn-lsp/server-hs/install.sh deleted file mode 100755 index 740a7c8..0000000 --- a/cn-lsp/server-hs/install.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env bash - -set -ex - -BIN_NAME=cn-lsp-server -LOCAL_INSTALL_DIR=bin - -cabal build exe:$BIN_NAME - -mkdir -p $LOCAL_INSTALL_DIR -cabal install --overwrite-policy=always exe:$BIN_NAME -cabal install --overwrite-policy=always --installdir=$LOCAL_INSTALL_DIR exe:$BIN_NAME diff --git a/cn-lsp/server-hs/src/CN.hs b/cn-lsp/server-hs/src/CN.hs deleted file mode 100644 index 7fd2fa3..0000000 --- a/cn-lsp/server-hs/src/CN.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CN where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON (parseJSON), withArray, withObject, (.:)) -import Data.Aeson qualified as Aeson -import Data.Text (Text) -import Data.Vector qualified as V -import Language.LSP.Protocol.Types qualified as LSP -import System.Environment (lookupEnv) -import System.Exit (ExitCode (..)) -import System.Process (readProcessWithExitCode) -import Util (LSPPosition (lspPosition), LSPRange (lspRange)) - -newtype CNExecutable = CNExecutable FilePath - --- | Look for a CN executable in one of two places --- --- - First, in the `CN` environment variable --- - Failing that, on the user's `PATH` -getCN :: (MonadIO m) => m (Maybe CNExecutable) -getCN = liftIO $ - do - envCN <- lookupEnv "CN" - case envCN of - Just cn -> pure (Just (CNExecutable cn)) - Nothing -> - do - (code, out, _err) <- readProcessWithExitCode "which" ["cn"] mempty - case (code, lines out) of - (ExitSuccess, pathCN : _) -> pure (Just (CNExecutable pathCN)) - (ExitSuccess, _) -> error "`which` succeeded but found nothing?" - (ExitFailure _, _) -> pure Nothing - -runCN :: (MonadIO m) => CNExecutable -> FilePath -> m (ExitCode, String, String) -runCN (CNExecutable cn) filePath = - liftIO (readProcessWithExitCode cn ["--json", filePath] mempty) - -cnPath :: CNExecutable -> FilePath -cnPath (CNExecutable f) = f - -data CNError = CNError - { cneLoc :: CNLoc, - cneShort :: Text, - cneDescription :: Maybe Text, - cneStateFile :: Maybe FilePath - } - -instance FromJSON CNError where - parseJSON = withObject "CNError" $ \obj -> - do - loc <- obj .: "loc" - short <- obj .: "short" - descr <- obj .: "descr" - state <- obj .: "state" - pure - CNError - { cneLoc = loc, - cneShort = short, - cneDescription = descr, - cneStateFile = state - } - -data CNLoc - = Region CNRegion - | Point CNPoint - -instance LSPRange CNLoc where - lspRange cnLoc = - case cnLoc of - Region cnRegion -> lspRange cnRegion - Point cnPoint -> lspRange cnPoint - -instance FromJSON CNLoc where - parseJSON = withArray "loc" $ \arr -> - case (arr V.!? 0, arr V.!? 1) of - (Just (Aeson.String "Region"), Just reg) -> Region <$> parseJSON reg - (Just (Aeson.String "Point"), Just pt) -> Point <$> parseJSON pt - _ -> fail "" - -data CNRegion = CNRegion - { cnrStart :: CNPoint, - cnrEnd :: CNPoint - } - -instance LSPRange CNRegion where - lspRange CNRegion {..} = - LSP.Range - { _start = lspPosition cnrStart, - _end = lspPosition cnrEnd - } - -instance FromJSON CNRegion where - parseJSON = withObject "region" $ \obj -> - do - start <- obj .: "region_start" - end <- obj .: "region_end" - pure $ CNRegion {cnrStart = start, cnrEnd = end} - -data CNPoint = CNPoint - { cnpFile :: FilePath, - cnpLine :: Int, - cnpChar :: Int - } - -instance LSPRange CNPoint where - lspRange cnPoint = - LSP.Range - { _start = lspPosition cnPoint, - _end = lspPosition cnPoint - } - -instance LSPPosition CNPoint where - lspPosition CNPoint {..} = - LSP.Position - { _line = fromIntegral cnpLine - 1, - _character = fromIntegral cnpChar - } - -instance FromJSON CNPoint where - parseJSON = withObject "position" $ \obj -> - do - file <- obj .: "file" - line <- obj .: "line" - char <- obj .: "char" - pure $ CNPoint {cnpFile = file, cnpLine = line, cnpChar = char} diff --git a/cn-lsp/server-hs/src/Handlers.hs b/cn-lsp/server-hs/src/Handlers.hs deleted file mode 100644 index 87b06c5..0000000 --- a/cn-lsp/server-hs/src/Handlers.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Redundant lambda" #-} - -module Handlers (mkHandlers) where - -import Data.Aeson.Text qualified as Aeson -import Data.Text.Lazy qualified as Text -import Handlers.Custom.RunCN qualified -import Handlers.Initialized qualified -import Handlers.TextDocument.DidChange qualified -import Handlers.TextDocument.DidClose qualified -import Handlers.TextDocument.DidOpen qualified -import Handlers.TextDocument.DidSave qualified -import Handlers.Workspace.DidChangeConfiguration qualified -import Language.LSP.Protocol.Message - ( MessageDirection (..), - MessageKind (..), - Method, - TNotificationMessage (..), - TRequestMessage (..), - ) -import Language.LSP.Protocol.Types (ClientCapabilities) -import Language.LSP.Server (Handler, Handlers, mapHandlers) -import Log (sDebug) -import Monad (ServerM) - -mkHandlers :: ClientCapabilities -> Handlers ServerM -mkHandlers _ = - mapHandlers - logRequest - logNotification - ( mconcat - [ Handlers.Custom.RunCN.handler, - Handlers.Initialized.handler, - Handlers.TextDocument.DidChange.handler, - Handlers.TextDocument.DidClose.handler, - Handlers.TextDocument.DidOpen.handler, - Handlers.TextDocument.DidSave.handler, - Handlers.Workspace.DidChangeConfiguration.handler - ] - ) - -logNotification :: - forall (m :: Method 'ClientToServer 'Notification). - Handler ServerM m -> - Handler ServerM m -logNotification handler = \notif -> - do - sDebug $ "Handling notification " <> Text.toStrict (Aeson.encodeToLazyText notif._method) - handler notif - -logRequest :: - forall (m :: Method 'ClientToServer 'Request). - Handler ServerM m -> - Handler ServerM m -logRequest handler = \request response -> - do - sDebug $ "Handling request " <> Text.toStrict (Aeson.encodeToLazyText request._method) - handler request response diff --git a/cn-lsp/server-hs/src/Handlers/Custom/RunCN.hs b/cn-lsp/server-hs/src/Handlers/Custom/RunCN.hs deleted file mode 100644 index 8948db1..0000000 --- a/cn-lsp/server-hs/src/Handlers/Custom/RunCN.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Handlers.Custom.RunCN where - -import CN (CNError, runCN) -import CN qualified -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader.Class (asks) -import Data.Aeson qualified as Aeson -import Data.Aeson.Types qualified as Aeson -import Data.Data (Proxy (Proxy)) -import Data.Maybe (maybeToList) -import Data.Text (Text) -import Data.Text qualified as Text -import GHC.Generics (Generic) -import Language.LSP.Diagnostics (partitionBySource) -import Language.LSP.Protocol.Message (Method (..), ResponseError, SMethod (..), TRequestMessage (..)) -import Language.LSP.Protocol.Types qualified as LSP -import Language.LSP.Server (Handlers, publishDiagnostics, requestHandler) -import Log (cDebug, cError, cInfoW) -import Monad (ServerM, seCN) -import System.Exit (ExitCode (..)) -import Util (LSPRange (lspRange)) - -data RunCNParams = RunCNParams - { textDocument :: LSP.TextDocumentIdentifier, - text :: Maybe Text - } - deriving (Generic) - -instance Aeson.FromJSON RunCNParams - -handler :: Handlers ServerM -handler = requestHandler (SMethod_CustomMethod (Proxy @"$/runCN")) doRunCN - -doRunCN :: - TRequestMessage ('Method_CustomMethod "$/runCN") -> - (Either ResponseError Aeson.Value -> ServerM ()) -> - ServerM () -doRunCN request _responder = - case requestParams >>= getFilePath of - Left err -> cError (Text.pack err) - Right filePath -> doCNDiagnostics filePath - where - requestParams :: Either String RunCNParams - requestParams = Aeson.parseEither Aeson.parseJSON request._params - -getFilePath :: RunCNParams -> Either String FilePath -getFilePath RunCNParams {..} = - case LSP.uriToFilePath uri of - Nothing -> Left $ "Couldn't resolve URI: " <> show uri - Just p -> Right p - where - uri = textDocument._uri - --- | Run CN on the given file and publish whatever diagnostics result -doCNDiagnostics :: FilePath -> ServerM () -doCNDiagnostics filePath = - do - let nUri = LSP.normalizedFilePathToUri (LSP.toNormalizedFilePath filePath) - publishDiagnostics 0 nUri Nothing mempty - cn <- asks seCN - (code, out, err) <- liftIO (runCN cn filePath) - cDebug $ "CN exit: " <> Text.pack (show code) - cDebug $ "CN stdout: " <> if null out then "" else Text.pack out - cDebug $ "CN stderr: " <> if null err then "" else Text.pack err - case code of - ExitSuccess -> cInfoW $ "No errors in " <> Text.pack filePath - ExitFailure _ -> - case Aeson.eitherDecodeStrictText (Text.pack err) of - Left e -> - cError $ Text.unlines ["Unable to interpret CN output", Text.pack e] - Right cnError -> - let (errNUri, diag) = mkErrorDiag cnError - in publishDiagnostics 100 errNUri Nothing (partitionBySource [diag]) - --- | Create an error diagnostic from the provided `CNError`. When sent to the --- client, this will result in a "red squiggle" at the relevant range in the --- relevant file (which may be different than the file on which CN was run to --- get the error), which will show the error's message as a tooltip if the user --- hovers over it. -mkErrorDiag :: CNError -> (LSP.NormalizedUri, LSP.Diagnostic) -mkErrorDiag cnError = (nuri, diag) - where - diag = - LSP.Diagnostic - { _range = lspRange range, - _severity = Just LSP.DiagnosticSeverity_Error, - _code = Nothing, - _codeDescription = Nothing, - _source = Just "CN", - _message = msg, - _tags = Nothing, - _relatedInformation = Nothing, - _data_ = Nothing - } - range = cnError.cneLoc - msg = Text.unlines (cnError.cneShort : maybeToList cnError.cneDescription) - nuri = LSP.toNormalizedUri (LSP.filePathToUri file) - file = - case range of - CN.Region r -> r.cnrStart.cnpFile - CN.Point p -> p.cnpFile diff --git a/cn-lsp/server-hs/src/Handlers/Initialized.hs b/cn-lsp/server-hs/src/Handlers/Initialized.hs deleted file mode 100644 index 5035bc3..0000000 --- a/cn-lsp/server-hs/src/Handlers/Initialized.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Handlers.Initialized (handler) where - -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage) -import Language.LSP.Server (Handlers, notificationHandler) -import Log (cInfo) -import Monad (ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_Initialized doInitialized - -doInitialized :: TNotificationMessage 'Method_Initialized -> ServerM () -doInitialized _notif = - do - cInfo "Server initialized" diff --git a/cn-lsp/server-hs/src/Handlers/TextDocument/DidChange.hs b/cn-lsp/server-hs/src/Handlers/TextDocument/DidChange.hs deleted file mode 100644 index 02623fc..0000000 --- a/cn-lsp/server-hs/src/Handlers/TextDocument/DidChange.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Handlers.TextDocument.DidChange where - -import Data.Aeson.Text qualified as Aeson -import Data.Text.Lazy qualified as Text -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage (..)) -import Language.LSP.Protocol.Types (DidChangeTextDocumentParams) -import Language.LSP.Server (Handlers, notificationHandler) -import Log (sDebug) -import Monad (ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_TextDocumentDidChange doDidChange - --- | A no-op to prevent noisy error messages appearing in the client every time --- a document is changed. Regardless of our preferences for document change --- notifications, per the spec, if we support the `textDocument/did{Open,Close}` --- methods, we also must support this method - see --- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_synchronization -doDidChange :: - TNotificationMessage 'Method_TextDocumentDidChange -> - ServerM () -doDidChange notif = - do - sDebug $ Text.toStrict (Aeson.encodeToLazyText params) - where - params :: DidChangeTextDocumentParams - params = notif._params diff --git a/cn-lsp/server-hs/src/Handlers/TextDocument/DidClose.hs b/cn-lsp/server-hs/src/Handlers/TextDocument/DidClose.hs deleted file mode 100644 index 985eab2..0000000 --- a/cn-lsp/server-hs/src/Handlers/TextDocument/DidClose.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Handlers.TextDocument.DidClose where - -import Data.Aeson.Text qualified as Aeson -import Data.Text.Lazy qualified as Text -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage (..)) -import Language.LSP.Protocol.Types (DidCloseTextDocumentParams) -import Language.LSP.Server (Handlers, notificationHandler) -import Log (sDebug) -import Monad (ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_TextDocumentDidClose doDidClose - --- | A no-op to prevent noisy error messages appearing in the client every time --- a document is closed -doDidClose :: - TNotificationMessage 'Method_TextDocumentDidClose -> - ServerM () -doDidClose notif = - do - sDebug $ Text.toStrict (Aeson.encodeToLazyText params) - where - params :: DidCloseTextDocumentParams - params = notif._params diff --git a/cn-lsp/server-hs/src/Handlers/TextDocument/DidOpen.hs b/cn-lsp/server-hs/src/Handlers/TextDocument/DidOpen.hs deleted file mode 100644 index cb5e84b..0000000 --- a/cn-lsp/server-hs/src/Handlers/TextDocument/DidOpen.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Handlers.TextDocument.DidOpen where - -import Data.Aeson.Text qualified as Aeson -import Data.Text.Lazy qualified as Text -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage (..)) -import Language.LSP.Protocol.Types (DidOpenTextDocumentParams) -import Language.LSP.Server (Handlers, notificationHandler) -import Log (sDebug) -import Monad (ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_TextDocumentDidOpen doDidOpen - --- | A no-op to prevent noisy error messages appearing in the client every time --- a document is opened -doDidOpen :: - TNotificationMessage 'Method_TextDocumentDidOpen -> - ServerM () -doDidOpen notif = - do - sDebug $ Text.toStrict (Aeson.encodeToLazyText params) - where - params :: DidOpenTextDocumentParams - params = notif._params diff --git a/cn-lsp/server-hs/src/Handlers/TextDocument/DidSave.hs b/cn-lsp/server-hs/src/Handlers/TextDocument/DidSave.hs deleted file mode 100644 index ca69823..0000000 --- a/cn-lsp/server-hs/src/Handlers/TextDocument/DidSave.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Handlers.TextDocument.DidSave where - -import Control.Monad (when) -import Data.Text qualified as Text -import Handlers.Custom.RunCN qualified as RunCN -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage (..)) -import Language.LSP.Protocol.Types qualified as LSP -import Language.LSP.Server (Handlers, getConfig, notificationHandler) -import Log (cError) -import Monad (Config (..), ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_TextDocumentDidSave doDidSave - -doDidSave :: - TNotificationMessage 'Method_TextDocumentDidSave -> - ServerM () -doDidSave notif = - do - Config {..} <- getConfig - when cfgRunCNOnSave $ - case getFilePath notif of - Left err -> cError (Text.pack err) - Right filePath -> RunCN.doCNDiagnostics filePath - -getFilePath :: TNotificationMessage 'Method_TextDocumentDidSave -> Either String FilePath -getFilePath notif = - case LSP.uriToFilePath uri of - Nothing -> Left $ "Couldn't resolve URI: " <> show uri - Just p -> Right p - where - uri = notif._params._textDocument._uri diff --git a/cn-lsp/server-hs/src/Handlers/Workspace/DidChangeConfiguration.hs b/cn-lsp/server-hs/src/Handlers/Workspace/DidChangeConfiguration.hs deleted file mode 100644 index 44082a5..0000000 --- a/cn-lsp/server-hs/src/Handlers/Workspace/DidChangeConfiguration.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Handlers.Workspace.DidChangeConfiguration (handler) where - -import Data.Aeson.Text qualified as Aeson -import Data.Text.Lazy qualified as Text -import Language.LSP.Protocol.Message (Method (..), SMethod (..), TNotificationMessage (..)) -import Language.LSP.Protocol.Types (DidChangeConfigurationParams) -import Language.LSP.Server (Handlers, notificationHandler) -import Log (sDebug) -import Monad (ServerM) - -handler :: Handlers ServerM -handler = notificationHandler SMethod_WorkspaceDidChangeConfiguration doDidChangeConfiguration - -doDidChangeConfiguration :: - TNotificationMessage 'Method_WorkspaceDidChangeConfiguration -> - ServerM () -doDidChangeConfiguration notif = - do - sDebug $ Text.toStrict (Aeson.encodeToLazyText params) - where - params :: DidChangeConfigurationParams - params = notif._params diff --git a/cn-lsp/server-hs/src/Log.hs b/cn-lsp/server-hs/src/Log.hs deleted file mode 100644 index 953d48e..0000000 --- a/cn-lsp/server-hs/src/Log.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Log - ( cInfoW, - cDebug, - cInfo, - cWarn, - cError, - sDebug, - sInfo, - sWarn, - sError, - ) -where - -import Colog.Core.Action ((<&)) -import Colog.Core.Severity (WithSeverity (..)) -import Colog.Core.Severity qualified as Colog -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader.Class (asks) -import Data.Text (Text) -import Data.Text qualified as Text -import Language.LSP.Logging (logToLogMessage, logToShowMessage) -import Monad (ServerEnv (seLogHdl), ServerM) -import System.IO (hFlush, hPutStrLn) - -cInfoW :: Text -> ServerM () -cInfoW = clientWindow Colog.Info - --- | Send the client a debug-level message -cDebug :: Text -> ServerM () -cDebug = clientLog Colog.Debug - --- | Send the client an info-level message -cInfo :: Text -> ServerM () -cInfo = clientLog Colog.Info - --- | Send the client a warning-level message -cWarn :: Text -> ServerM () -cWarn = clientLog Colog.Warning - --- | Send the client an error-level message -cError :: Text -> ServerM () -cError = clientLog Colog.Error - --- | Log a debug-level message within the server -sDebug :: Text -> ServerM () -sDebug = serverLog Colog.Debug - --- | Log an info-level message within the server -sInfo :: Text -> ServerM () -sInfo = serverLog Colog.Info - --- | Log a warning-level message within the server -sWarn :: Text -> ServerM () -sWarn = serverLog Colog.Warning - --- | Log an error-level message within the server -sError :: Text -> ServerM () -sError = serverLog Colog.Error - -clientWindow :: Colog.Severity -> Text -> ServerM () -clientWindow severity msg = logToShowMessage <& msg `WithSeverity` severity - --- | Send the client a log message with the specified severity -clientLog :: Colog.Severity -> Text -> ServerM () -clientLog severity msg = logToLogMessage <& msg `WithSeverity` severity - --- | Log a message within the server at the specified severity -serverLog :: Colog.Severity -> Text -> ServerM () -serverLog severity msg = - do - logHdl <- asks seLogHdl - let str = formatMessage (msg `WithSeverity` severity) - liftIO (hPutStrLn logHdl str >> hFlush logHdl) - --- | Pretty-print a log message -formatMessage :: WithSeverity Text -> String -formatMessage ws = unwords [severity, msg] - where - severity = - case getSeverity ws of - Colog.Debug -> "[DEBUG]" - Colog.Info -> "[INFO] " - Colog.Warning -> "[WARN] " - Colog.Error -> "[ERROR]" - - msg = Text.unpack (getMsg ws) diff --git a/cn-lsp/server-hs/src/Monad.hs b/cn-lsp/server-hs/src/Monad.hs deleted file mode 100644 index 84d8694..0000000 --- a/cn-lsp/server-hs/src/Monad.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Monad where - -import CN (CNExecutable) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.Reader.Class (MonadReader, asks) -import Data.Aeson (FromJSON (parseJSON), withObject, (.:)) -import Language.LSP.Server (LanguageContextEnv, LspM, MonadLsp (..), runLspT) -import System.IO (Handle) - -data Config = Config - { cfgRunCNOnSave :: Bool - } - --- | This instance recognizes field names as defined in the language client's --- `package.json`, specifically the "configuration" section of "contributes". -instance FromJSON Config where - parseJSON = withObject "Config" $ \obj -> - do - cfgRunCNOnSave <- obj .: "runOnSave" - pure Config {..} - --- | Our default configuration -defConfig :: Config -defConfig = - Config - { cfgRunCNOnSave = False - } - -data ServerEnv = ServerEnv - { seCtxEnv :: LanguageContextEnv Config, - seLogHdl :: Handle, - seCN :: CNExecutable - } - -newtype ServerM a = ServerM {unServerM :: ReaderT ServerEnv (LspM Config) a} - deriving - ( Applicative, - Functor, - Monad, - MonadIO, - MonadReader ServerEnv, - MonadUnliftIO - ) - -instance MonadLsp Config ServerM where - getLspEnv = asks seCtxEnv - -runServerM :: ServerEnv -> ServerM a -> IO a -runServerM serverEnv (ServerM rdrAction) = - let lspAction = runReaderT rdrAction serverEnv - in runLspT (seCtxEnv serverEnv) lspAction diff --git a/cn-lsp/server-hs/src/Server.hs b/cn-lsp/server-hs/src/Server.hs deleted file mode 100644 index 8e88743..0000000 --- a/cn-lsp/server-hs/src/Server.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Server where - -import CN (getCN) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (Value, (.=)) -import Data.Aeson qualified as Aeson -import Data.Aeson.Types qualified as Aeson -import Data.Bifunctor (Bifunctor (first)) -import Data.Text (Text) -import Data.Text qualified as Text -import Handlers (mkHandlers) -import Language.LSP.Protocol.Message qualified as LSP -import Language.LSP.Protocol.Types qualified as LSP -import Language.LSP.Server (LanguageContextEnv, type (<~>) (Iso)) -import Language.LSP.Server qualified as LSP -import Monad (Config, ServerEnv (..), ServerM, defConfig, runServerM) -import System.IO (Handle) - -mkServer :: Handle -> LSP.ServerDefinition Config -mkServer logHdl = LSP.ServerDefinition {..} - where - defaultConfig :: Config - defaultConfig = defConfig - - configSection :: Text - configSection = "CN" - - parseConfig :: Config -> Value -> Either Text Config - parseConfig _oldCfg newCfg = - first Text.pack $ - Aeson.parseEither Aeson.parseJSON newCfg - - onConfigChange :: Config -> ServerM () - onConfigChange _ = pure () - - doInitialize :: - LanguageContextEnv Config -> - LSP.TRequestMessage 'LSP.Method_Initialize -> - IO (Either LSP.ResponseError ServerEnv) - doInitialize ctxEnv _ = - getCN >>= \case - Just cn -> - let env = - ServerEnv - { seCtxEnv = ctxEnv, - seLogHdl = logHdl, - seCN = cn - } - in pure (Right env) - Nothing -> - let err = - LSP.ResponseError - (LSP.InR LSP.ErrorCodes_InternalError) - "No CN executable found on path" - -- This tells the client to offer the user a chance to retry - -- server initialization - see - -- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#initializeError. - -- - -- I believe `retry` is the only allowed field here, and I - -- would expect that to be codified at the type level, rather - -- than allowing this to be a bare `Value` - see - -- https://github.com/haskell/lsp/issues/586. - (Just (Aeson.object ["retry" .= True])) - in pure (Left err) - - staticHandlers :: LSP.ClientCapabilities -> LSP.Handlers ServerM - staticHandlers = mkHandlers - - interpretHandler :: ServerEnv -> ServerM <~> IO - interpretHandler serverEnv = Iso (runServerM serverEnv) liftIO - - options :: LSP.Options - options = serverOptions - -serverOptions :: LSP.Options -serverOptions = - LSP.defaultOptions - { LSP.optTextDocumentSync = - Just - LSP.TextDocumentSyncOptions - { -- Don't send notifications of documents being opened or closed - _openClose = Just False, - -- Don't send any updates as the text of a document changes - _change = Just LSP.TextDocumentSyncKind_None, - _willSave = Just False, - _willSaveWaitUntil = Just False, - -- Do send notifications of documents being saved, but don't - -- include the text - _save = Just (LSP.InR (LSP.SaveOptions {_includeText = Just False})) - } - } diff --git a/cn-lsp/server-hs/src/Util.hs b/cn-lsp/server-hs/src/Util.hs deleted file mode 100644 index c064491..0000000 --- a/cn-lsp/server-hs/src/Util.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Util where - -import Language.LSP.Protocol.Types qualified as LSP - --- | Things that can be interpreted as an `LSP.Range` -class LSPRange a where - lspRange :: a -> LSP.Range - -instance LSPRange LSP.Range where - lspRange = id - --- | Things that can be interpreted as an `LSP.Position` -class LSPPosition a where - lspPosition :: a -> LSP.Position - -instance LSPRange LSP.Position where - lspRange p = LSP.Range p p - -instance LSPPosition LSP.Position where - lspPosition = id diff --git a/cn-lsp/server-hs/test/Main.hs b/cn-lsp/server-hs/test/Main.hs deleted file mode 100644 index 3e2059e..0000000 --- a/cn-lsp/server-hs/test/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main (main) where - -main :: IO () -main = putStrLn "Test suite not yet implemented."