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
102
103
104
105
106
107
108
109
110
111
|
{-# 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.Diagnostic as HV
import qualified HSVIS.Parser as HV
import qualified HSVIS.Typecheck as HV
mkDiag :: HV.Diagnostic -> Diagnostic
mkDiag msg = Diagnostic
{ _range =
let -- TODO: col needs to be UTF-16 based, which this is not
mkPos (HV.Pos line col) = Position (fromIntegral line) (fromIntegral col)
HV.Range from to = HV.dRange msg
in Range (mkPos from) (mkPos to)
, _severity = Just DiagnosticSeverity_Error
, _code = Nothing
, _codeDescription = Nothing
, _source = Just "hs-vis"
, _message = T.pack $ intercalate "\n" $
HV.dMsg msg : ["In " ++ entry | entry <- reverse (HV.dStk msg)]
, _tags = Nothing
, _relatedInformation = Nothing
, _data_ = Nothing
}
parseFile :: NormalizedUri -> T.Text -> ([Diagnostic], Maybe HV.PProgram)
parseFile (NormalizedUri _ fpath) source =
let (errs, mpprog) = HV.parse (T.unpack fpath) (T.unpack source)
in (map mkDiag errs, mpprog)
typecheckFile :: NormalizedUri -> T.Text -> HV.PProgram -> ([Diagnostic], HV.TProgram)
typecheckFile (NormalizedUri _ fpath) source pprog =
let (errs, tprog) = HV.typecheck (T.unpack fpath) (T.unpack source) pprog
in (map mkDiag errs, tprog)
publishDiagsForUri :: Uri -> LspM () ()
publishDiagsForUri fileUri = do
let filename = toNormalizedUri fileUri
getVirtualFile filename >>= \case
Just vfile -> do
let source = Rope.toText (vfile ^. L.file_text)
let (diags1, mpprog) = parseFile filename source
let (diags2, _mtprog) = case mpprog of Just pprog -> Just <$> typecheckFile filename source pprog
Nothing -> ([], Nothing)
let diags = diags1 ++ diags2
-- 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 }}
}
|
