1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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 }}
}
|
