content: {-# language LambdaCase #-}
  {-# language TemplateHaskell #-}
  {-# language OverloadedStrings #-}
  {-# language MultiParamTypeClasses #-}
  {-# language FunctionalDependencies #-}
  {-# language FlexibleContexts #-}
  {-# language FlexibleInstances #-}
  {-# language DeriveGeneric #-}
  {-# language DeriveDataTypeable #-}
  {-# language UndecidableInstances #-}
  {-# language TypeFamilies #-}
  
  --------------------------------------------------------------------
  -- |
  -- Copyright :  (c) Edward Kmett 2017-2018
  -- License   :  BSD-2-Clause OR Apache-2.0
  -- Maintainer:  Edward Kmett <ekmett@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable
  --
  --------------------------------------------------------------------
  
  module Server
    ( server
    , logMessage
    , telemetryEvent
    , showMessage
    ) where
  
  import Control.Applicative
  import Control.Monad.IO.Class
  import Control.Monad.State
  import Control.Monad.Reader
  import Control.Lens hiding ((.=))
  import Data.Aeson
  import Data.ByteString.Lazy as Lazy
  import Data.Text as Text
  import Language.Server.Builder
  import Language.Server.Protocol
  import Language.Server.Parser
  import System.Exit
  import System.IO
  
  import Server.Options
  import Syntax.Document
  
  --------------------------------------------------------------------------------
  -- Logging
  --------------------------------------------------------------------------------
  
  putError :: MonadIO m => Maybe Id -> ErrorCode -> Text -> m ()
  putError i c t = -- do
    putMessage $ Response i Nothing (Just (ResponseError c t Nothing))
  
  --------------------------------------------------------------------------------
  -- State
  --------------------------------------------------------------------------------
  
  data ServerState = ServerState
    { _shutdownRequested :: Bool
    , _documents :: Documents
    } deriving Show
  
  makeFieldsNoPrefix ''ServerState
  
  class (HasShutdownRequested t Bool, HasDocuments t Documents) => HasServerState t
  instance (HasShutdownRequested t Bool, HasDocuments t Documents) => HasServerState t
  
  --------------------------------------------------------------------------------
  -- Listening
  --------------------------------------------------------------------------------
  
  eitherDecodeRequest :: Lazy.ByteString -> Either String (Either [Request] Request)
  eitherDecodeRequest bs
      = Left  <$> eitherDecode' bs
    <|> Right <$> eitherDecode' bs
  
  listen :: (MonadIO m, MonadState s m, HasServerState s) => m (Either [Request] Request)
  listen = liftIO (parse parseMessage stdin) >>= \case
    Left e -> do
      putError Nothing InvalidRequest (Text.pack e)
      liftIO $ do
        hFlush stdout
        hFlush stderr
        exitWith $ ExitFailure 1
    Right v -> case eitherDecodeRequest v of
      Left s -> do
        putError Nothing ParseError (Text.pack s)
        listen
      Right e -> do
        liftIO $ do
          Lazy.hPutStr stderr $ encode e
          hPutChar stderr '\n'
          hFlush stderr
        return e
  
  --------------------------------------------------------------------------------
  -- Server -> Client Notifications
  --------------------------------------------------------------------------------
  
  logMessage :: MonadIO m => Severity -> Text -> m ()
  logMessage s t = putMessage $ LogMessage s t
  
  showMessage :: MonadIO m => Severity -> Text -> m ()
  showMessage s t = putMessage $ ShowMessage s t
  
  telemetryEvent :: MonadIO m => Value -> m ()
  telemetryEvent v = putMessage $ TelemetryEvent v
  
  --------------------------------------------------------------------------------
  -- Server
  --------------------------------------------------------------------------------
  
  server :: ServerOptions -> IO ()
  server opts = do
    hSetBuffering stdin NoBuffering
    hSetEncoding stdin char8
    hSetBuffering stdout NoBuffering
    hSetEncoding stdout char8
    hFlush stdout
    runReaderT ?? opts $ evalStateT ?? ServerState False mempty $ do
      initializeServer
      loop
  
  ok :: (MonadIO m, ToJSON a) => Id -> a -> m ()
  ok i p = liftIO $ putMessage $ Response (Just i) (Just (toJSON p)) Nothing
  
  initializeServer :: (MonadState s m, HasServerState s, MonadReader e m, HasServerOptions e, MonadIO m) => m ()
  initializeServer = listen >>= \case
    Right (Initialize i _ip) ->
      ok i $ object
        [ "capabilities" .= object
          [ "textDocumentSync" .= object
            [ "openClose" .= toJSON True
            , "change" .= toJSON (2 :: Int) -- incremental content sync
            , "save" .= object [ "includeText" .= toJSON False ]
            ]
          ]
        ]
    Right Shutdown -> do
      assign shutdownRequested True
      initializeServer
    Right Exit ->
      use shutdownRequested >>= \b -> liftIO $ do
        hFlush stdout
        hFlush stderr
        exitWith $ if b then ExitSuccess else ExitFailure 1
    Right (Request _ m _)
      | Text.isPrefixOf "$/" m -> initializeServer -- ignore extensions
    Right (Request Nothing _ _) -> initializeServer               -- ignore notifications
    Right (Request (Just i) _ _) -> do
      putError (Just i) ServerNotInitialized "waiting for initialization"
      initializeServer
    Left _ -> do
      putError Nothing InternalError "batch commands not yet implemented"
      initializeServer
  
  loop :: (MonadState s m, HasServerState s, MonadReader e m, HasServerOptions e, MonadIO m) => m ()
  loop = listen >>= \case
    Right (DidClose tdi) -> didClose tdi >> loop
    Right (DidChange ps) -> didChange ps >> loop
    Right (DidChangeConfiguration _) -> loop
    Right (DidOpen tdi) -> didOpen tdi >> loop
    Right (DidSave ps) -> didSave ps >> loop
    Right Exit ->
      use shutdownRequested >>= \b -> liftIO $ do
        hFlush stdout
        hFlush stderr
        exitWith $ if b then ExitSuccess else ExitFailure 1
    Right Initialized -> loop -- we can now tell the client to do stuff
    Right Shutdown -> assign shutdownRequested True >> loop
  
    Right (Request _ m _) | Text.isPrefixOf "$/" m -> loop -- ignore extensions for now
    Right (Request (Just i) _ _) -> do
      putError (Just i) InvalidRequest "unsupported request"
      loop
    Right (Request _ m _) -> do
      liftIO $ hPrint stderr m
      logMessage Information m
      loop
    Left _ -> do
      putError Nothing InternalError "batch commands not yet implemented"
      loop
  