{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

module Server.Run
  ( runServe
  ) where

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Lens
import           Control.Monad
import qualified Control.Monad.Catch                   as E
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.STM
import qualified Data.Aeson                            as J
import           Data.Default
import           Data.Monoid
import qualified Data.Text                             as T
import           Descript.Build
import qualified Descript.BasicInj                     as BasicInj
import           Descript.Misc
import qualified Language.Haskell.LSP.Control          as CTRL
import qualified Language.Haskell.LSP.Core             as Core
import           Language.Haskell.LSP.Diagnostics
import           Language.Haskell.LSP.Messages
import qualified Language.Haskell.LSP.Types            as J
import qualified Language.Haskell.LSP.Utility          as U
import           Server.Decode
import           Server.Encode
import           System.Exit
import qualified System.Log.Logger                     as L

runServe :: IO ()
runServe = do
  -- putStrLn "Starting server..."
  serve handleServerStart >>= \case
    0 -> do
      putStrLn "Server stopped"
      exitSuccess
    c -> do
      putStrLn $ "Server stopped with error or interrupt"
      exitWith . ExitFailure $ c

handleServerStart :: IO ()
handleServerStart = do
  -- putStrLn "Server started. Ctrl-C to stop"
  pure ()

-- Derived from Haskell LSP example
-- (https://github.com/alanz/haskell-lsp/blob/master/example/Main.hs)
-- and Haskell IDE Engine implementation
-- (https://github.com/alanz/haskell-ide-engine/blob/master/src/Haskell/Ide/Engine/Transport/LspStdio.hs)
-- ---------------------------------------------------------------------

serve :: IO () -> IO Int
serve dispatcherProc = E.handle finishErr $ do
  rin  <- atomically newTChan :: IO (TChan ReactorInput)
  let dp lf = do
        liftIO $ U.logs $ "main.run:dp entered"
        dispatcherProc
        liftIO $ U.logs $ "main.run:dp after dispatcher"
        _  <- forkIO $ reactor lf rin
        pure Nothing
  Core.setupLogger (Just "/tmp/descript-server.log") [] L.DEBUG
  res <- CTRL.run (getConfig, dp) (lspHandlers rin) lspOptions
  U.logs $ "****** FINISHED WITH CODE: " ++ show res
  finish
  pure res
  where finishErr (e :: E.SomeException) = do
          U.logs $ "****** FINISHED WITH ERROR: " ++ show e
          finish
          pure 1
        finish = L.removeAllHandlers

-- ---------------------------------------------------------------------

-- | Callback from haskell-lsp core to convert the generic message to the
-- specific one for hie
getConfig :: J.DidChangeConfigurationNotification -> Either T.Text Config
getConfig (J.NotificationMessage _ _ (J.DidChangeConfigurationParams p)) =
  case J.fromJSON p of
    J.Success c -> Right c
    J.Error err -> Left $ T.pack err

newtype Config =
  Config
    { maxNumberOfProblems :: Int
    } deriving (Show)

instance J.FromJSON Config where
  parseJSON = J.withObject "Config" $ \v -> do
    s <- v J..: "descript"
    flip (J.withObject "Config.settings") s $ \o -> Config
      <$> o J..: "maxNumberOfProblems"

-- ---------------------------------------------------------------------

-- The reactor is a process that serialises and buffers all requests from the
-- LSP client, so they can be sent to the backend compiler one at a time, and a
-- reply sent.

data ReactorInput
  = HandlerRequest Core.OutMessage
      -- ^ injected into the reactor input by each of the individual callback handlers

-- ---------------------------------------------------------------------

-- | The monad used in the reactor
type R a = ReaderT (Core.LspFuncs Config) IO a

-- ---------------------------------------------------------------------
-- reactor monad functions
-- ---------------------------------------------------------------------

-- Unlike makeResponseMessage, allows for a response for an arbitrary
-- request (without request type).
makeResponseMessage' :: J.LspIdRsp -> resp -> J.ResponseMessage resp
makeResponseMessage' rid result
  = J.ResponseMessage "2.0" rid (Just result) Nothing

-- ---------------------------------------------------------------------

reactorSend :: (J.ToJSON a) => a -> R ()
reactorSend msg = do
  lf <- ask
  liftIO $ Core.sendFunc lf msg

-- ---------------------------------------------------------------------

publishDiagnostics :: J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R ()
publishDiagnostics uri mv diags = do
  lf <- ask
  config <- liftIO $ Core.config lf
  let maxNumProbs
        = case maxNumberOfProblems <$> config of
               Nothing -> maxBound
               Just (-1) -> maxBound
               Just x -> x
  liftIO $ (Core.publishDiagnosticsFunc lf) maxNumProbs uri mv diags

-- ---------------------------------------------------------------------

nextLspReqId :: R J.LspId
nextLspReqId = do
  f <- asks Core.getNextReqId
  liftIO $ f

-- ---------------------------------------------------------------------

-- | The single point that all events flow through, allowing management of state
-- to stitch replies and requests together from the two asynchronous sides: lsp
-- server and backend compiler
reactor :: Core.LspFuncs Config -> TChan ReactorInput -> IO ()
reactor lf inp = flip runReaderT lf $ do
  liftIO $ U.logs $ "reactor:entered"
  cache <- newGlobalCache
  let handlers = [ E.Handler onSomeExcept
                 ]
      onSomeExcept (e :: E.SomeException) = do
        liftIO $ U.logm $ "****** EXCEPTION ******"
        liftIO $ U.logs $ show e
  forever $ (`E.catches` handlers) $ do
    HandlerRequest inval <- liftIO $ atomically $ readTChan inp
    case inval of

      -- Handle any response from a message originating at the server, such as
      -- "workspace/applyEdit"
      Core.RspFromClient rm -> do
        liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm

      -- -------------------------------

      Core.NotInitialized _notification -> do
        liftIO $ U.logm $ "****** reactor: processing Initialized Notification"
        -- Server is ready, register any specific capabilities we need

         {-
         Example:
         {
                 "method": "client/registerCapability",
                 "params": {
                         "registrations": [
                                 {
                                         "id": "79eee87c-c409-4664-8102-e03263673f6f",
                                         "method": "textDocument/willSaveWaitUntil",
                                         "registerOptions": {
                                                 "documentSelector": [
                                                         { "language": "javascript" }
                                                 ]
                                         }
                                 }
                         ]
                 }
         }
        -}
        let registration = J.Registration "descript-server-registered" J.WorkspaceExecuteCommand Nothing
            registrations = J.RegistrationParams $ J.List [registration]
        rid <- nextLspReqId

        reactorSend $ fmServerRegisterCapabilityRequest rid registrations

      -- -------------------------------

      Core.NotDidOpenTextDocument notification -> do
        liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument"
        let doc = notification ^. J.params . J.textDocument
            uri = decodeUri $ doc ^. J.uri
            version = doc ^. J.version
            text = doc ^. J.text
        liftIO $ U.logs $ "********* uri = " ++ show uri
        addFile (inDelegate uri) uri version text cache

      -- -------------------------------

      Core.NotDidCloseTextDocument notification -> do
        liftIO $ U.logm $ "****** reactor: processing NotDidCloseTextDocument"
        let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri
        liftIO $ U.logs $ "********* uri = " ++ show uri
        delFile uri cache

      -- -------------------------------

      Core.NotDidChangeTextDocument notification -> do
        liftIO $ U.logm $ "****** reactor: processing NotDidChangeTextDocument"
        let params = notification ^. J.params
            doc = params ^. J.textDocument
            uri = decodeUri $ doc ^. J.uri
            version = doc ^. J.version
            change = decodeChange $ params ^. J.contentChanges
        liftIO $ U.logs $ "********* uri = " ++ show uri
        changeFile (inDelegate uri) uri version change cache

      -- -------------------------------

      Core.NotDidSaveTextDocument notification -> do
        liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument"
        let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri
        liftIO $ U.logs $ "********* uri = " ++ show uri

      -- -------------------------------

      Core.ReqRename req -> do
        liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req
        let rid = J.responseId $ req ^. J.id
            params = req ^. J.params
            doc = params ^. J.textDocument
            uri = decodeUri $ doc ^. J.uri
            loc = decodeLoc $ params ^. J.position
            newName = T.unpack $ params ^. J.newName
        refactorFile (outDelegate rid uri) uri (BasicInj.renameSymbolAt loc newName) cache

      -- -------------------------------

      Core.ReqHover req -> do
        liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req
        {- let J.TextDocumentPositionParams _doc pos = req ^. J.params

        let ht = J.Hover ms (Just range)
            ms = J.List [J.CodeString $ J.LanguageString "descript" "TYPE INFO" ]
            range = J.Range pos pos
        reactorSend $ Core.makeResponseMessage req ht -}

      -- -------------------------------

      Core.ReqCodeAction req -> do
        liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req
        {- let params = req ^. J.params
            doc = params ^. J.textDocument
            -- fileName = drop (length ("file://"::String)) doc
            -- J.Range from to = J._range (params :: J.CodeActionParams)
            (J.List diags) = params ^. J.context . J.diagnostics

        let
          -- makeCommand only generates commands for diagnostics whose source is us
          makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "descript") _m _l) = [J.Command title cmd cmdparams]
            where
              title = "Apply Descript command:" <> head (T.lines _m)
              -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above
              cmd = "rename"
              -- need 'file' and 'start_pos'
              args = J.Array$ V.fromList
                      [ J.Object $ H.fromList [("file",     J.Object $ H.fromList [("textDocument",J.toJSON doc)])]
                      , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position",    J.toJSON start)])]
                      ]
              cmdparams = Just args
          makeCommand (J.Diagnostic _r _s _c _source _m _l) = []
        let body = J.List $ concatMap makeCommand diags
        reactorSend $ Core.makeResponseMessage req body -}

      -- -------------------------------

      Core.ReqExecuteCommand req -> do
        liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req
        {- let params = req ^. J.params
            margs = params ^. J.arguments

        liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs

        let
          reply v = reactorSend $ Core.makeResponseMessage req v
        -- When we get a RefactorResult or HieDiff, we need to send a
        -- separate WorkspaceEdit Notification
          r = J.List [] :: J.List Int
        liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show r
        case toWorkspaceEdit r of
          Just we -> do
            reply (J.Object mempty)
            lid <- nextLspReqId
            -- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we)
            reactorSend $ fmServerApplyWorkspaceEditRequest lid we
          Nothing ->
            reply (J.Object mempty) -}

      -- -------------------------------

      Core.ReqCompletion req -> do
        liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req
        {- let params = req ^. J.params
            filePath = J.uriToFilePath $ params ^. J.textDocument ^. J.uri
            pos = params ^. J.position

        mprefix <- getPrefixAtPos doc pos

        callback <- hieResponseHelper (req ^. J.id) $ \compls -> do
          let rspMsg = Core.makeResponseMessage req
                         $ J.Completions $ J.List compls
          reactorSend rspMsg
        case mprefix of
          Nothing -> liftIO $ callback $ IdeResponseOk []
          Just prefix -> do
            let hreq = IReq (req ^. J.id) callback
                         $ Hie.getCompletions doc prefix
            makeRequest hreq -}

      Core.ReqCompletionItemResolve req -> do
        liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req
        {- let origCompl = req ^. J.params
            mquery = case J.fromJSON <$> origCompl ^. J.xdata of
                       Just (J.Success q) -> Just q
                       _ -> Nothing
        callback <- hieResponseHelper (req ^. J.id) $ \docs -> do
          let rspMsg = Core.makeResponseMessage req $
                         origCompl & J.documentation .~ docs
          reactorSend rspMsg
        let hreq = GReq Nothing Nothing (Just $ req ^. J.id) callback $ runExceptT $ do
              case mquery of
                Nothing -> return Nothing
                Just query -> do
                  res <- lift $ liftToGhc $ Hoogle.infoCmd' query
                  case res of
                    Right x -> return $ Just x
                    _ -> return Nothing
        makeRequest hreq -}

      -- -------------------------------

      Core.ReqDocumentHighlights req -> do
        liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req
        {- let rid = J.responseId $ req ^. J.id
            params = req ^. J.params
            doc = params ^. J.textDocument
            uri = decodeUri $ doc ^. J.uri
            loc = decodeLoc $ params ^. J.position
        refsRes <- inspectFile uri (BasicInj.refsToSymbolAt loc) cache
        case refsRes of
          Failure err -> do
            let msg = Text.pack $ summary err
                rerr = J.ResponseError J.InvalidRequest msg Nothing
            Core.makeResponseError req rerr
          Just refs -> do
            let erefs = encodeReferences refs
                rsp = Core.makeResponseMessage req erefs
            reactorSend rsp -}

        {- let params = req ^. J.params
            doc = params ^. J.textDocument ^. J.uri
            pos = params ^. J.position
        callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do
          let rspMsg = Core.makeResponseMessage req $ J.List highlights
          reactorSend rspMsg
        let hreq = IReq (req ^. J.id) callback
                 $ Hie.getReferencesInDoc doc pos
        makeRequest hreq -}

      -- -------------------------------

      Core.ReqDefinition req -> do
        liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req
        {- let params = req ^. J.params
            doc = params ^. J.textDocument . J.uri
            pos = params ^. J.position
        callback <- hieResponseHelper (req ^. J.id) $ \loc -> do
            let rspMsg = Core.makeResponseMessage req loc
            reactorSend rspMsg
        let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
                     $ fmap J.MultiLoc <$> Hie.findDef doc pos
        makeRequest hreq -}

      Core.ReqFindReferences req -> do
        liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req
        {- let params = req ^. J.params
            doc = params ^. J.textDocument ^. J.uri
            pos = params ^. J.position
        callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do
          let rspMsg = Core.makeResponseMessage req $ J.List highlights
          reactorSend rspMsg
        let hreq = IReq (req ^. J.id) callback
                 $ fmap (map (J.Location doc . (^. J.range)))
                 <$> Hie.getReferencesInDoc doc pos
        makeRequest hreq -}

      -- -------------------------------

      Core.ReqDocumentFormatting req -> do
        liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
        {- let params = req ^. J.params
            doc = params ^. J.textDocument . J.uri
            tabSize = params ^. J.options . J.tabSize
        callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do
            let rspMsg = Core.makeResponseMessage req $ J.List textEdit
            reactorSend rspMsg
        let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
                     $ Brittany.brittanyCmd tabSize doc Nothing
        makeRequest hreq -}

      -- -------------------------------

      Core.ReqDocumentRangeFormatting req -> do
        liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
        {- let params = req ^. J.params
            doc = params ^. J.textDocument . J.uri
            range = params ^. J.range
            tabSize = params ^. J.options . J.tabSize
        callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do
            let rspMsg = Core.makeResponseMessage req $ J.List textEdit
            reactorSend rspMsg
        let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
                     $ Brittany.brittanyCmd tabSize doc (Just range)
        makeRequest hreq -}

      -- -------------------------------

      Core.ReqDocumentSymbols req -> do
        liftIO $ U.logs $ "reactor:got Document symbol request:" ++ show req
        {- let uri = req ^. J.params . J.textDocument . J.uri
        callback <- hieResponseHelper (req ^. J.id) $ \docSymbols -> do
            let rspMsg = Core.makeResponseMessage req $ J.List docSymbols
            reactorSend rspMsg
        let hreq = IReq (req ^. J.id) callback
                 $ Hie.getSymbols uri
        makeRequest hreq -}

      -- -------------------------------

      Core.NotCancelRequest notif -> do
        liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif
        {- let lid = notif ^. J.params . J.id
        liftIO $ atomically $ do
          wip <- readTVar wipTVar
          when (S.member lid wip) $ do
            modifyTVar' cancelReqTVar (S.insert lid) -}

      -- -------------------------------

      Core.NotDidChangeConfigurationParams notif -> do
        liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif
        {- -- if hlint has been turned off, flush the disgnostics
        diagsOn              <- configVal True hlintOn
        maxDiagnosticsToSend <- configVal 50 maxNumberOfProblems
        liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn
        -- If hlint is off, remove the diags. But make sure they get sent, in
        -- case maxDiagnosticsToSend has changed.
        if diagsOn
          then flushDiagnosticsBySource maxDiagnosticsToSend Nothing
          else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") -}

      -- -------------------------------

      om -> do
        liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om

-- ---------------------------------------------------------------------

inDelegate :: FilePath
           -> CacheDelegate (ReaderT (Core.LspFuncs Config) IO)
inDelegate uri
  = CacheDelegate
  { onUpdateFile = onInUpdateFile uri
  , onWarning = onInWarning
  , onError = onInError uri
  }

outDelegate :: J.LspIdRsp
            -> FilePath
            -> CacheDelegate (ReaderT (Core.LspFuncs Config) IO)
outDelegate rid uri
  = CacheDelegate
  { onUpdateFile = onOutUpdateFile rid uri
  , onWarning = onOutWarning
  , onError = onOutError rid uri
  }

onInUpdateFile :: FilePath
               -> FileUpdate
               -> FileCache
               -> R ()
onInUpdateFile uri (UpdateBasicInj _) x = do
  liftIO $ U.logs $ "********* updating basic"
  let uri' = encodeUri uri
      version = fileVersion x
  let diags = BasicInj.diagnose $ forceGetPhaseCache $ srcBasicInj x
      ediags = partitionBySource $ map encodeDiagnostic diags
  publishDiagnostics uri' (Just version) ediags
onInUpdateFile _ _ _ = pure ()

onOutUpdateFile :: J.LspIdRsp
                -> FilePath
                -> FileUpdate
                -> FileCache
                -> R ()
onOutUpdateFile rid uri (UpdateText new patchOpt) x = do
  liftIO $ U.logs "********* updating text"
  let old = phaseCached $ srcText x
      patchOpt' = patchOpt <|> fmap (`replacePatch` new) old
  case patchOpt' of
    Nothing -> onOutError rid uri CachePatchBeforeText
    Just patch -> do
      let uri' = encodeUri uri
          doc = J.VersionedTextDocumentIdentifier uri' $ fileVersion x
          de = J.TextDocumentEdit doc $ encodePatch patch
          we = J.WorkspaceEdit Nothing $ Just $ J.List [de]
          rspMsg = makeResponseMessage' rid we
      reactorSend rspMsg
onOutUpdateFile _ _ _ _ = pure ()

onInWarning :: CacheWarning
            -> R ()
            -> R ()
onInWarning _ continue = continue

onOutWarning :: CacheWarning
             -> R ()
             -> R ()
onOutWarning (CacheRefactorWarning _ _) continue = continue
  {- do
  let params = J.ShowMessageRequestParams J.MtWarning ...
                     (Just [J.MessageActionItem "Continue", J.MessageActionItem "Cancel"])
  rid <- nextLspReqId

  reactorSend $ fmServerShowMessageRequest rid params -}

onInError :: FilePath
          -> CacheError
          -> R ()
onInError uri (CacheParseError x err) = do
  liftIO $ U.logs "********* got error: CacheParseError"
  let uri' = encodeUri uri
      version = fileVersion x
      eerr = encodeParseError err
      diags = partitionBySource eerr
  publishDiagnostics uri' (Just version) diags
onInError _ err = do
  liftIO $ U.logs $ "******** got unexpected in error: " ++ show err

onOutError :: J.LspIdRsp
           -> FilePath
           -> CacheError
           -> R ()
onOutError rid _ CacheFileNotFound = do
  liftIO $ U.logs "********* got error: CacheFileNotFound"
  let err = J.ResponseError J.InternalError fileNotFoundErrMsg Nothing
      rspMsg = Core.makeResponseError rid err
  reactorSend rspMsg
onOutError rid _ CachePatchBeforeText = do
  liftIO $ U.logs "********* got error: CachePathBeforeText"
  let err = J.ResponseError J.InternalError patchBeforeTextErrMsg Nothing
      rspMsg = Core.makeResponseError rid err
  reactorSend rspMsg
onOutError rid _ CacheRefactorBeforeParse = do
  liftIO $ U.logs "********* got error: CacheRefactorBeforeParse"
  let err = J.ResponseError J.InternalError refactorBeforeParseErrMsg Nothing
      rspMsg = Core.makeResponseError rid err
  reactorSend rspMsg
onOutError rid uri (CacheRefactorError x err) = do
  let file = mkSFile uri $ forceGetPhaseCache $ srcText x
      msg = "Refactor error: " <> T.pack (summaryF file err)
      rerr = J.ResponseError J.InvalidRequest msg Nothing
      rspMsg = Core.makeResponseError rid rerr
  reactorSend rspMsg
onOutError _ _ err = do
  liftIO $ U.logs $ "********* got unexpected out error: " ++ show err

fileNotFoundErrMsg :: T.Text
fileNotFoundErrMsg = "No file cached at this path. Reopen the file to fix."

patchBeforeTextErrMsg :: T.Text
patchBeforeTextErrMsg = "No text cached at this path. Reopen the file to fix."

refactorBeforeParseErrMsg :: T.Text
refactorBeforeParseErrMsg = "Can't refactor because the source isn't parsed."

-- ---------------------------------------------------------------------

-- toWorkspaceEdit :: t -> Maybe J.ApplyWorkspaceEditParams
-- toWorkspaceEdit _ = Nothing

-- ---------------------------------------------------------------------

{- -- | Analyze the file and send any diagnostics to the client in a
-- "textDocument/publishDiagnostics" notification
sendDiagnostics :: J.Uri -> Maybe Int -> R ()
sendDiagnostics fileUri mversion = do
  let
    diags = [J.Diagnostic
              (J.Range (J.Position 0 1) (J.Position 0 5))
              (Just J.DsWarning)  -- severity
              Nothing  -- code
              (Just "descript-server") -- source
              "Example diagnostic message"
              (Just (J.List []))
            ]
  -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r)
  publishDiagnostics 100 fileUri mversion (partitionBySource diags) -}

-- ---------------------------------------------------------------------

syncOptions :: J.TextDocumentSyncOptions
syncOptions = J.TextDocumentSyncOptions
  { J._openClose         = Just True
  , J._change            = Just J.TdSyncIncremental
  , J._willSave          = Just False
  , J._willSaveWaitUntil = Just False
  , J._save              = Just $ J.SaveOptions $ Just False
  }

lspOptions :: Core.Options
lspOptions = def { Core.textDocumentSync = Just syncOptions
                 , Core.completionProvider = Just (J.CompletionOptions (Just True) (Just ["<", ">"]))
                 , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["rename"]))
                 }

lspHandlers :: TChan ReactorInput -> Core.Handlers
lspHandlers rin
  = def { Core.initializedHandler                       = Just $ passHandler rin Core.NotInitialized
        , Core.renameHandler                            = Just $ passHandler rin Core.ReqRename
        , Core.hoverHandler                             = Just $ passHandler rin Core.ReqHover
        , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin Core.NotDidOpenTextDocument
        , Core.didSaveTextDocumentNotificationHandler   = Just $ passHandler rin Core.NotDidSaveTextDocument
        , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument
        , Core.didCloseTextDocumentNotificationHandler  = Just $ passHandler rin Core.NotDidCloseTextDocument
        , Core.cancelNotificationHandler                = Just $ passHandler rin Core.NotCancelRequest
        , Core.responseHandler                          = Just $ responseHandlerCb rin
        , Core.codeActionHandler                        = Just $ passHandler rin Core.ReqCodeAction
        , Core.executeCommandHandler                    = Just $ passHandler rin Core.ReqExecuteCommand
        , Core.completionHandler                        = Just $ passHandler rin Core.ReqCompletion
        , Core.completionResolveHandler                 = Just $ passHandler rin Core.ReqCompletionItemResolve
        , Core.documentHighlightHandler                 = Just $ passHandler rin Core.ReqDocumentHighlights
        , Core.documentFormattingHandler                = Just $ passHandler rin Core.ReqDocumentFormatting
        , Core.documentRangeFormattingHandler           = Just $ passHandler rin Core.ReqDocumentRangeFormatting
        , Core.documentSymbolHandler                    = Just $ passHandler rin Core.ReqDocumentSymbols
        }

-- ---------------------------------------------------------------------

passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a
passHandler rin c notification = do
  atomically $ writeTChan rin (HandlerRequest (c notification))

-- ---------------------------------------------------------------------

responseHandlerCb :: TChan ReactorInput -> Core.Handler J.BareResponseMessage
responseHandlerCb _rin resp = do

  U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp

-- ---------------------------------------------------------------------