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