{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-- 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(..)
  , HasTracing(..)
  ,setUriAnd) where


import Control.Lens ((^.))
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 Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri))
import Development.IDE.Core.Service
import Data.Aeson (Value)
import Development.IDE.Core.Tracing (otSetUri)
import OpenTelemetry.Eventlog (SpanInFlight)

data WithMessage c = WithMessage
    {WithMessage c
-> forall m req resp.
   (Show m, Show req, HasTracing 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, HasTracing 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, HasTracing req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
withNotification :: forall m req . (Show m, Show req, HasTracing 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,
    HasTracing req) =>
   (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, HasTracing req) =>
        (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

class HasTracing a where
  traceWithSpan :: SpanInFlight -> a -> IO ()
  traceWithSpan SpanInFlight
_ a
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
  traceWithSpan :: SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp a
a = SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (a
a a -> Getting Uri a Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (doc -> Const Uri doc) -> a -> Const Uri a
forall s a. HasTextDocument s a => Lens' s a
textDocument ((doc -> Const Uri doc) -> a -> Const Uri a)
-> ((Uri -> Const Uri Uri) -> doc -> Const Uri doc)
-> Getting Uri a Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri) -> doc -> Const Uri doc
forall s a. HasUri s a => Lens' s a
uri)

instance HasTracing Value
instance HasTracing ExecuteCommandParams
instance HasTracing DidChangeWatchedFilesParams
instance HasTracing DidChangeWorkspaceFoldersParams
instance HasTracing DidChangeConfigurationParams
instance HasTracing InitializeParams
instance HasTracing (Maybe InitializedParams)

setUriAnd ::
  (HasTextDocument params a, HasUri a Uri) =>
  (lspFuncs -> ide -> params -> IO res) ->
  lspFuncs ->
  SpanInFlight ->
  ide ->
  params ->
  IO res
setUriAnd :: (lspFuncs -> ide -> params -> IO res)
-> lspFuncs -> SpanInFlight -> ide -> params -> IO res
setUriAnd lspFuncs -> ide -> params -> IO res
k lspFuncs
lf SpanInFlight
sp ide
ide params
params = do
  SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (params
params params -> Getting Uri params Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (a -> Const Uri a) -> params -> Const Uri params
forall s a. HasTextDocument s a => Lens' s a
textDocument ((a -> Const Uri a) -> params -> Const Uri params)
-> ((Uri -> Const Uri Uri) -> a -> Const Uri a)
-> Getting Uri params Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri) -> a -> Const Uri a
forall s a. HasUri s a => Lens' s a
uri)
  lspFuncs -> ide -> params -> IO res
k lspFuncs
lf ide
ide params
params