+updateState _ = return ()
+
+sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
+sendMessage msg = do
+ h <- serverIn <$> ask
+ logMsg LogClient msg
+ liftIO $ B.hPut h (addHeader $ encode msg)
+
+-- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
+-- after duration seconds. This will override the global timeout
+-- for waiting for messages to arrive defined in 'SessionConfig'.
+withTimeout :: Int -> Session a -> Session a
+withTimeout duration f = do
+ chan <- asks messageChan
+ timeoutId <- getCurTimeoutId
+ modify $ \s -> s { overridingTimeout = True }
+ liftIO $ forkIO $ do
+ threadDelay (duration * 1000000)
+ writeChan chan (TimeoutMessage timeoutId)
+ res <- f
+ bumpTimeoutId timeoutId
+ modify $ \s -> s { overridingTimeout = False }
+ return res
+
+-- TODO: add a shouldTimeout helper. need to add exceptions within Session
+data LogMsgType = LogServer | LogClient
+ deriving Eq
+
+-- | Logs the message if the config specified it
+logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
+ => LogMsgType -> a -> m ()
+logMsg t msg = do
+ shouldLog <- asks $ logMessages . config
+ shouldColor <- asks $ logColor . config
+ liftIO $ when shouldLog $ do
+ when shouldColor $ setSGR [SetColor Foreground Dull color]
+ putStrLn $ arrow ++ showPretty msg
+ when shouldColor $ setSGR [Reset]
+
+ where arrow
+ | t == LogServer = "<-- "
+ | otherwise = "--> "
+ color
+ | t == LogServer = Magenta
+ | otherwise = Cyan
+
+ showPretty = B.unpack . encodePretty
+
+-- File watching
+
+processFileWatchRegistration :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+ => T.Text -> Registration -> m ()
+processFileWatchRegistration regId reg = do
+ mgr <- asks watchManager
+ let mOpts = do
+ regOpts <- reg ^. registerOptions
+ case fromJSON regOpts of
+ Error _ -> Nothing
+ Success x -> Just x
+ case mOpts of
+ Nothing -> pure ()
+ Just (DidChangeWatchedFilesRegistrationOptions (List ws)) ->
+ forM_ ws $ \(FileSystemWatcher pat' watchKind) -> do
+ pat <- liftIO $ canonicalizePath pat'
+ let glob = compile pat
+ -- the root-most dir before any globbing stuff happens
+ dir = fst $ commonDirectory glob
+ pred = match glob . eventPath
+ -- If no watchKind specified, spec defaults to all true
+ WatchKind wkC wkM wkD = fromMaybe (WatchKind True True True) watchKind
+ handle <- asks serverIn
+ unwatch <- liftIO $ watchTree mgr dir pred $ \event -> do
+ let fe = FileEvent (filePathToUri (eventPath event)) typ
+ typ = case event of
+ FS.Added _ _ _ -> FcCreated
+ FS.Modified _ _ _ -> FcChanged
+ FS.Removed _ _ _ -> FcDeleted
+ -- This is a bit of a guess
+ FS.Unknown _ _ _ -> FcChanged
+ matches = case typ of
+ FcCreated -> wkC
+ FcChanged -> wkM
+ FcDeleted -> wkD
+ params = DidChangeWatchedFilesParams (List [fe])
+ msg = fmClientDidChangeWatchedFilesNotification params
+ liftIO $ when matches $ B.hPut handle (addHeader $ encode msg)
+ modify $ \s ->
+ s { unwatchers = Map.insertWith (++) regId [unwatch] (unwatchers s) }
+
+processFileWatchUnregistrations :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+ => [T.Text] -> m ()
+processFileWatchUnregistrations regIds =
+ forM_ regIds $ \regId -> modifyM $ \s -> do
+ let fs = fromMaybe [] (Map.lookup regId (unwatchers s))
+ liftIO $ sequence fs
+ return $ s { unwatchers = Map.delete regId (unwatchers s) }