test/dummy-server/Main.hs

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