-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0


{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module Development.IDE.LSP.Server
  ( WithMessage(..)
  , PartialHandlers(..)
  ) where


import Data.Default

import           Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Core as LSP
import qualified Language.Haskell.LSP.Messages as LSP
import Development.IDE.Core.Service

data WithMessage c = WithMessage
    {WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
withResponse :: forall m req resp . (Show m, Show req) =>
        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

        Maybe (LSP.Handler (RequestMessage m req resp))
    ,WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
withNotification :: forall m req . (Show m, Show req) =>
        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

        (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work

        Maybe (LSP.Handler (NotificationMessage m req))
    ,WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

        Maybe (LSP.Handler (RequestMessage m req resp))
    , WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
                     -> Maybe (LSP.Handler InitializeRequest)
    }

newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

instance Default (PartialHandlers c) where
    def :: PartialHandlers c
def = (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c)
-> (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall a b. (a -> b) -> a -> b
$ \WithMessage c
_ Handlers
x -> Handlers -> IO Handlers
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handlers
x

instance Semigroup (PartialHandlers c) where
    PartialHandlers WithMessage c -> Handlers -> IO Handlers
a <> :: PartialHandlers c -> PartialHandlers c -> PartialHandlers c
<> PartialHandlers WithMessage c -> Handlers -> IO Handlers
b = (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c)
-> (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall a b. (a -> b) -> a -> b
$ \WithMessage c
w Handlers
x -> WithMessage c -> Handlers -> IO Handlers
a WithMessage c
w Handlers
x IO Handlers -> (Handlers -> IO Handlers) -> IO Handlers
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WithMessage c -> Handlers -> IO Handlers
b WithMessage c
w

instance Monoid (PartialHandlers c) where
    mempty :: PartialHandlers c
mempty = PartialHandlers c
forall a. Default a => a
def