test/dummy-server/Main.hs

   1 {-# LANGUAGE TypeInType #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3
   4 import Control.Monad
   5 import Control.Monad.Reader
   6 import Data.Aeson hiding (defaultOptions)
   7 import qualified Data.HashMap.Strict as HM
   8 import Data.List (isSuffixOf)
   9 import Language.LSP.Server
  10 import Language.LSP.Types
  11 import System.Directory
  12 import System.FilePath
  13 import UnliftIO
  14 import UnliftIO.Concurrent
  15
  16 main = do
  17   handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
  18   runServer $ ServerDefinition
  19     { doInitialize = \env _req -> pure $ Right env,
  20       onConfigurationChange = const $ pure $ Right (),
  21       staticHandlers = handlers,
  22       interpretHandler = \env ->
  23         Iso
  24           (\m -> runLspT env (runReaderT m handlerEnv))
  25           liftIO,
  26       options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}
  27     }
  28
  29 data HandlerEnv = HandlerEnv
  30   { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),
  31     absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)
  32   }
  33
  34 handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
  35 handlers =
  36   mconcat
  37     [ notificationHandler SInitialized $
  38         \_noti ->
  39           sendNotification SWindowLogMessage $
  40             LogMessageParams MtLog "initialized"
  41     , requestHandler STextDocumentHover $
  42         \_req responder ->
  43           responder $
  44             Right $
  45               Just $
  46                 Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing
  47     , requestHandler STextDocumentDocumentSymbol $
  48         \_req responder ->
  49           responder $
  50             Right $
  51               InL $
  52                 List
  53                   [ DocumentSymbol
  54                       "foo"
  55                       Nothing
  56                       SkObject
  57                       Nothing
  58                       (mkRange 0 0 3 6)
  59                       (mkRange 0 0 3 6)
  60                       Nothing
  61                   ]
  62      , notificationHandler STextDocumentDidOpen $
  63         \noti -> do
  64           let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
  65               TextDocumentItem uri _ _ _ = doc
  66               Just fp = uriToFilePath uri
  67               diag =
  68                 Diagnostic
  69                   (mkRange 0 0 0 1)
  70                   (Just DsWarning)
  71                   (Just (InL 42))
  72                   (Just "dummy-server")
  73                   "Here's a warning"
  74                   Nothing
  75                   Nothing
  76           withRunInIO $
  77             \runInIO -> do
  78               when (".hs" `isSuffixOf` fp) $
  79                 void $
  80                   forkIO $
  81                     do
  82                       threadDelay (2 * 10 ^ 6)
  83                       runInIO $
  84                         sendNotification STextDocumentPublishDiagnostics $
  85                           PublishDiagnosticsParams uri Nothing (List [diag])
  86               -- also act as a registerer for workspace/didChangeWatchedFiles
  87               when (".register" `isSuffixOf` fp) $
  88                 do
  89                   let regOpts =
  90                         DidChangeWatchedFilesRegistrationOptions $
  91                           List
  92                             [ FileSystemWatcher
  93                                 "*.watch"
  94                                 (Just (WatchKind True True True))
  95                             ]
  96                   Just token <- runInIO $
  97                     registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
  98                       \_noti ->
  99                         sendNotification SWindowLogMessage $
 100                           LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
 101                   runInIO $ asks relRegToken >>= \v -> putMVar v token
 102               when (".register.abs" `isSuffixOf` fp) $
 103                 do
 104                   curDir <- getCurrentDirectory
 105                   let regOpts =
 106                         DidChangeWatchedFilesRegistrationOptions $
 107                           List
 108                             [ FileSystemWatcher
 109                                 (curDir </> "*.watch")
 110                                 (Just (WatchKind True True True))
 111                             ]
 112                   Just token <- runInIO $
 113                     registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
 114                       \_noti ->
 115                         sendNotification SWindowLogMessage $
 116                           LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
 117                   runInIO $ asks absRegToken >>= \v -> putMVar v token
 118               -- also act as an unregisterer for workspace/didChangeWatchedFiles
 119               when (".unregister" `isSuffixOf` fp) $
 120                 do
 121                   Just token <- runInIO $ asks relRegToken >>= tryReadMVar
 122                   runInIO $ unregisterCapability token
 123               when (".unregister.abs" `isSuffixOf` fp) $
 124                 do
 125                   Just token <- runInIO $ asks absRegToken >>= tryReadMVar
 126                   runInIO $ unregisterCapability token
 127      , requestHandler SWorkspaceExecuteCommand $ \req resp -> do
 128         let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
 129             Success docUri = fromJSON val
 130             edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
 131             params =
 132               ApplyWorkspaceEditParams (Just "Howdy edit") $
 133                 WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing
 134         resp $ Right Null
 135         void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))
 136      , requestHandler STextDocumentCodeAction $ \req resp -> do
 137         let RequestMessage _ _ _ params = req
 138             CodeActionParams _ _ _ _ cactx = params
 139             CodeActionContext diags _ = cactx
 140             codeActions = fmap diag2ca diags
 141             diag2ca d =
 142               CodeAction
 143                 "Delete this"
 144                 Nothing
 145                 (Just (List [d]))
 146                 Nothing
 147                 Nothing
 148                 Nothing
 149                 (Just (Command "" "deleteThis" Nothing))
 150         resp $ Right $ InR <$> codeActions
 151      , requestHandler STextDocumentCompletion $ \_req resp -> do
 152         let res = CompletionList True (List [item])
 153             item =
 154               CompletionItem
 155                 "foo"
 156                 (Just CiConstant)
 157                 (Just (List []))
 158                 Nothing
 159                 Nothing
 160                 Nothing
 161                 Nothing
 162                 Nothing
 163                 Nothing
 164                 Nothing
 165                 Nothing
 166                 Nothing
 167                 Nothing
 168                 Nothing
 169                 Nothing
 170                 Nothing
 171         resp $ Right $ InR res
 172     ]