diff options
| -rw-r--r-- | hie.yaml | 5 | ||||
| -rw-r--r-- | hs-visinter.cabal | 15 | ||||
| -rw-r--r-- | lsp/Main.hs | 101 |
3 files changed, 121 insertions, 0 deletions
@@ -10,6 +10,11 @@ cradle: cradle: cabal: component: "exe:hs-visinter" + - path: "./lsp" + config: + cradle: + cabal: + component: "exe:hs-vis-lsp" - path: "./examples" config: cradle: diff --git a/hs-visinter.cabal b/hs-visinter.cabal index 748355d..0a179fb 100644 --- a/hs-visinter.cabal +++ b/hs-visinter.cabal @@ -32,3 +32,18 @@ executable hs-visinter hs-source-dirs: app default-language: Haskell2010 ghc-options: -Wall -threaded + +executable hs-vis-lsp + main-is: Main.hs + other-modules: + build-depends: + base, + hs-visinter, + lsp ^>= 2.4.0.0, + text, + + -- dependencies of lsp + lens, text-rope + hs-source-dirs: lsp + default-language: Haskell2010 + ghc-options: -Wall -threaded diff --git a/lsp/Main.hs b/lsp/Main.hs new file mode 100644 index 0000000..c3928d6 --- /dev/null +++ b/lsp/Main.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Lens.Operators +import Control.Monad.IO.Class +import Data.List (intercalate) +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope + +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.VFS as L +import Language.LSP.Server + +import qualified HSVIS.Parser as HV + + +parseFile :: NormalizedUri -> T.Text -> [Diagnostic] +parseFile (NormalizedUri _ fpath) source = + case HV.parse (T.unpack fpath) (T.unpack source) of + HV.This errs -> map mkDiag errs + HV.These errs _ -> map mkDiag errs + HV.That _ -> [] + where + mkDiag :: HV.ErrMsg -> Diagnostic + mkDiag msg = Diagnostic + { _range = + let HV.Pos line col = HV.errPos msg + -- TODO: col needs to be UTF-16 based, which this is not + pos = Position (fromIntegral line) (fromIntegral col) + in Range pos pos + , _severity = Just DiagnosticSeverity_Error + , _code = Nothing + , _codeDescription = Nothing + , _source = Just "hs-vis" + , _message = T.pack $ intercalate "\n" $ + HV.errMsg msg : ["In " ++ entry | entry <- reverse (HV.errStk msg)] + , _tags = Nothing + , _relatedInformation = Nothing + , _data_ = Nothing + } + +publishDiagsForUri :: Uri -> LspM () () +publishDiagsForUri fileUri = do + getVirtualFile (toNormalizedUri fileUri) >>= \case + Just vfile -> do + let diags = parseFile (toNormalizedUri fileUri) + (Rope.toText (vfile ^. L.file_text)) + liftIO $ appendFile "/home/tom/hsvislsplog.txt" (" -> publishing diags: " ++ show diags ++ "\n") + sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams + { _uri = fileUri + , _version = Just (vfile ^. L.lsp_version) + , _diagnostics = diags } + Nothing -> pure () + +handlers :: Handlers (LspM ()) +handlers = + mconcat + [ notificationHandler SMethod_Initialized $ \_notif -> do + sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "initialized!") + liftIO $ appendFile "/home/tom/hsvislsplog.txt" "initialized\n" + pure () + , notificationHandler SMethod_TextDocumentDidOpen $ \notif -> do + let fileUri = notif ^. L.params . L.textDocument . L.uri + -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (open): " ++ show fileUri ++ "\n") + publishDiagsForUri fileUri + , notificationHandler SMethod_TextDocumentDidChange $ \notif -> do + let fileUri = notif ^. L.params . L.textDocument . L.uri + -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (change): " ++ show fileUri ++ "\n") + publishDiagsForUri fileUri + pure () + , notificationHandler SMethod_TextDocumentDidClose $ \notif -> do + let fileUri = notif ^. L.params . L.textDocument . L.uri + -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Close: " ++ show fileUri ++ "\n") + publishDiagsForUri fileUri + pure () + ] + +main :: IO Int +main = + runServer $ + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "hs_vis" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + { optTextDocumentSync = Just $ TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Nothing }} + } + |