fix clientMethodJSON/serverMethodJSON

wz1000 · May 7, 2020 · 0c15553 · 0c15553
1 parent 3f28fb2
commit 0c15553
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 9 deletions.
diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Hover.hs
@@ -146,6 +146,3 @@ data Hover =
     } deriving (Read,Show,Eq)
 
 deriveJSON lspOptions ''Hover
-
-type HoverRequest = RequestMessage ClientMethod TextDocumentPositionParams (Maybe Hover)
-type HoverResponse = ResponseMessage (Maybe Hover)
diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/MessageFuncs.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE PolyKinds           #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Language.Haskell.LSP.Types.MessageFuncs (
   -- * General

diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs
@@ -23,6 +23,7 @@ import           Language.Haskell.LSP.Types.Color
 import           Language.Haskell.LSP.Types.Constants
 import           Language.Haskell.LSP.Types.Completion
 import           Language.Haskell.LSP.Types.FoldingRange
+import           Language.Haskell.LSP.Types.Hover
 import           Language.Haskell.LSP.Types.List
 import           Language.Haskell.LSP.Types.Location
 import           Language.Haskell.LSP.Types.Message
@@ -281,6 +282,11 @@ instance ToJSON (CustomMessage p t) where
   toJSON (ReqMess a) = toJSON a
   toJSON (NotMess a) = toJSON a
 
+instance FromJSON (CustomMessage p Request) where
+  parseJSON v = ReqMess <$> parseJSON v
+instance FromJSON (CustomMessage p Notification) where
+  parseJSON v = NotMess <$> parseJSON v
+
 instance FromJSON (SomeCustomMessage p) where
   parseJSON = withObject "CustomMessage" $ \o -> do
     mid <- o .:? "id"
@@ -508,20 +514,21 @@ type family BaseHandlerFunc (t :: MethodType) (m :: Method p t) :: Type where
 clientResponseJSON :: SClientMethod m -> (ToJSON (ResponseMessage m) => x) -> x
 clientResponseJSON m x = case splitClientMethod m of
   IsClientReq -> x
+  IsClientEither -> x
 
-clientMethodJSON :: SClientMethod m -> ((FromJSON (ClientMessage m),ToJSON (ClientMessage m)) => x) -> x
+clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x
 clientMethodJSON m x =
   case splitClientMethod m of
     IsClientNot -> x
     IsClientReq -> x
-    -- IsClientEither -> x
+    IsClientEither -> x
 
-serverMethodJSON :: SServerMethod m -> ((FromJSON (ServerMessage m),ToJSON (ServerMessage m)) => x) -> x
+serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x
 serverMethodJSON m x =
   case splitServerMethod m of
     IsServerNot -> x
     IsServerReq -> x
-    -- IsServerEither -> x
+    IsServerEither -> x
 
 type HasJSON a = (ToJSON a,FromJSON a,Eq a)
 

diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs
@@ -335,7 +335,23 @@ handlerMap i hm (J.SomeClientMethod c) = case c of
   J.STextDocumentDidChange -> hh c (Just changeFromClientVFS) h
   J.STextDocumentDidClose -> hh c (Just closeVFS) h
   J.SWorkDoneProgressCancel -> helper undefined progressCancelHandler
-  _ -> J.clientMethodJSON c $ hh c nop $ h
+  _ -> \tvar json -> case J.splitClientMethod c of
+    J.IsClientReq -> hh c nop h tvar json
+    J.IsClientNot -> hh c nop h tvar json
+    J.IsClientEither
+      | J.Object v <- json
+      , HM.member "id" v -- Request
+        -> let m' = (J.SCustomMethod m :: J.SMethod (J.CustomMethod :: J.Method J.FromClient J.Request))
+               h' = hm m'
+             in hh m' nop h' tvar json
+      | otherwise -- Notification
+        -> let m' = (J.SCustomMethod m :: J.SMethod (J.CustomMethod :: J.Method J.FromClient J.Notification))
+               h' = hm m'
+             in hh m' nop h' tvar json
+      where
+        J.SCustomMethod m = c
+
+  --J.clientMethodJSON c $ hh c nop $ h
   where h = hm c
 
 -- ---------------------------------------------------------------------
@@ -373,7 +389,7 @@ hh m mVfs mh tvarDat json = do
   where
     isOptionalNotification req
       -- TODO
-      -- | NotCustomClient _ <- req
+      -- -| NotCustomClient _ <- req
       -- , J.Object object <- json
       -- , Just (J.String method) <- HM.lookup "method" object
       -- , "$/" `T.isPrefixOf` method