From f2c617c1eb5c1bd83e12b2b4baee0f81dacb839d Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 8 May 2020 13:07:43 +0530 Subject: [PATCH] Split out IxMap into new module --- haskell-lsp-types/haskell-lsp-types.cabal | 1 + haskell-lsp-types/src/Data/IxMap.hs | 40 +++++++++ .../Haskell/LSP/Types/DataTypesJSON.hs | 2 - .../src/Language/Haskell/LSP/Types/Message.hs | 83 ++++--------------- src/Language/Haskell/LSP/Core.hs | 19 +++-- 5 files changed, 66 insertions(+), 79 deletions(-) create mode 100644 haskell-lsp-types/src/Data/IxMap.hs diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index a098e689c..b5f3fb891 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -23,6 +23,7 @@ library , Language.Haskell.LSP.Types.Lens , Language.Haskell.LSP.Types.MessageFuncs , Language.Haskell.LSP.Types.Utils + , Data.IxMap other-modules: Language.Haskell.LSP.Types.ClientCapabilities , Language.Haskell.LSP.Types.CodeAction , Language.Haskell.LSP.Types.Color diff --git a/haskell-lsp-types/src/Data/IxMap.hs b/haskell-lsp-types/src/Data/IxMap.hs new file mode 100644 index 000000000..729dabf26 --- /dev/null +++ b/haskell-lsp-types/src/Data/IxMap.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.IxMap where + +import qualified Data.Map as M +import Data.Some +import Data.Kind +import Unsafe.Coerce + +-- a `compare` b <=> toBase a `compare` toBase b +-- toBase (i :: f a) == toBase (j :: f b) <=> a ~ b +class Ord (Base f) => IxOrd f where + type Base f + toBase :: forall a. f a -> Base f + +newtype IxMap (k :: a -> Type) (f :: a -> Type) = IxMap { getMap :: M.Map (Base k) (Some f) } + +emptyIxMap :: IxMap k f +emptyIxMap = IxMap M.empty + +insertIxMap :: IxOrd k => k m -> f m -> IxMap k f -> IxMap k f +insertIxMap i x (IxMap m) = IxMap $ M.insert (toBase i) (mkSome x) m + +lookupIxMap :: IxOrd k => k m -> IxMap k f -> Maybe (f m) +lookupIxMap i (IxMap m) = + case M.lookup (toBase i) m of + Just (Some v) -> Just $ unsafeCoerce v + Nothing -> Nothing + +pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) +pickFromIxMap i = pickFromIxMap' (toBase i) + +pickFromIxMap' :: IxOrd k => Base k -> IxMap k f -> (Maybe (f m), IxMap k f) +pickFromIxMap' i (IxMap m) = + case M.updateLookupWithKey (\_ _ -> Nothing) i m of + (Nothing,m) -> (Nothing,IxMap m) + (Just (Some k),m) -> (Just (unsafeCoerce k),IxMap m) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs index 3df6db976..45e37d396 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -7,8 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PolyKinds #-} diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs index 2c7285e89..954f5e31e 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs @@ -1,18 +1,11 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.Haskell.LSP.Types.Message where @@ -20,18 +13,12 @@ module Language.Haskell.LSP.Types.Message where import qualified Data.Aeson as A import Data.Aeson.TH import Data.Aeson.Types -import Data.Hashable --- For <= 8.2.2 import Data.Text (Text) import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.Utils +import Data.IxMap import Data.Function (on) -import Data.Kind import Control.Applicative -import qualified Data.Map as M -import Data.Some -import Unsafe.Coerce - -- | Id used for a request, Can be either a String or an Int data LspId (m :: Method p Request) = IdInt Int | IdString Text @@ -46,53 +33,11 @@ instance A.FromJSON (LspId m) where parseJSON (A.String s) = return (IdString s) parseJSON _ = mempty -instance Hashable (LspId m) where - hashWithSalt salt (IdInt i) = hashWithSalt salt i - hashWithSalt salt (IdString s) = hashWithSalt salt s - -type LspIdRsp m = Maybe (LspId m) - --- a `compare` b <=> toBase a `compare` toBase b --- toBase (i :: f a) == toBase (j :: f b) <=> a ~ b -class Ord (Base f) => IxOrd f where - type Base f - toBase :: forall a. f a -> Base f - instance IxOrd LspId where type Base LspId = Either Int Text toBase (IdInt i) = Left i toBase (IdString s) = Right s -newtype IxMap (k :: a -> Type) (f :: a -> Type) = IxMap { getMap :: M.Map (Base k) (Some f) } -type IdMap (f :: Method FromServer Request -> Type) = IxMap (LspId :: Method FromServer Request -> Type) f - -emptyIxMap :: IxMap k f -emptyIxMap = IxMap M.empty - -insertIxMap :: IxOrd k => k m -> f m -> IxMap k f -> IxMap k f -insertIxMap i x (IxMap m) = IxMap $ M.insert (toBase i) (mkSome x) m - -lookupIxMap :: IxOrd k => k m -> IxMap k f -> Maybe (f m) -lookupIxMap i (IxMap m) = - case M.lookup (toBase i) m of - Just (Some v) -> Just $ unsafeCoerce v - Nothing -> Nothing - -pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) -pickFromIxMap i = pickFromIxMap' (toBase i) - -pickFromIxMap' :: IxOrd k => Base k -> IxMap k f -> (Maybe (f m), IxMap k f) -pickFromIxMap' i (IxMap m) = - case M.updateLookupWithKey (\_ _ -> Nothing) i m of - (Nothing,m) -> (Nothing,IxMap m) - (Just (Some k),m) -> (Just (unsafeCoerce k),IxMap m) - -requestId :: LspIdRsp m -> LspId m -requestId (Just x) = x -requestId Nothing = error "reponse with no id" - -responseId :: LspId m -> LspIdRsp m -responseId = Just -- --------------------------------------------------------------------- data Provenance = FromServer | FromClient @@ -268,8 +213,10 @@ instance Ord SomeServerMethod where getString (A.String t) = t getString _ = error "ToJSON instance for some method isn't string" -instance ToJSON SomeMethod where - toJSON (SomeMethod m) = toJSON m +-- --------------------------------------------------------------------- +-- From JSON +-- --------------------------------------------------------------------- + instance FromJSON SomeMethod where parseJSON v = client <|> server where @@ -285,11 +232,8 @@ instance FromJSON SomeMethod where case c of SomeServerMethod m -> pure $ SomeMethod m - -instance ToJSON SomeClientMethod where - toJSON (SomeClientMethod m) = toJSON m instance FromJSON SomeClientMethod where - -- General + -- General parseJSON (A.String "initialize") = pure $ SomeClientMethod SInitialize parseJSON (A.String "initialized") = pure $ SomeClientMethod SInitialized parseJSON (A.String "shutdown") = pure $ SomeClientMethod SShutdown @@ -337,8 +281,6 @@ instance FromJSON SomeClientMethod where parseJSON (A.String m) = pure $ SomeClientMethod (SCustomMethod m) parseJSON _ = mempty -instance ToJSON SomeServerMethod where - toJSON (SomeServerMethod m) = toJSON m instance A.FromJSON SomeServerMethod where -- Server -- Window @@ -365,16 +307,21 @@ instance A.FromJSON SomeServerMethod where parseJSON (A.String m) = pure $ SomeServerMethod (SCustomMethod m) parseJSON _ = mempty --- --------------------------------------------------------------------- --- From JSON --- --------------------------------------------------------------------- - +-- instance ToJSON (SMethod m) makeSingletonFromJSON 'SomeMethod ''SMethod -- --------------------------------------------------------------------- -- TO JSON -- --------------------------------------------------------------------- +instance ToJSON SomeMethod where + toJSON (SomeMethod m) = toJSON m + +instance ToJSON SomeClientMethod where + toJSON (SomeClientMethod m) = toJSON m +instance ToJSON SomeServerMethod where + toJSON (SomeServerMethod m) = toJSON m + instance A.ToJSON (SMethod m) where -- Client -- General diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 7b963e4de..cbf7c43bf 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -51,6 +51,7 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default +import Data.IxMap import Data.Scientific (floatingOrInteger) import qualified Data.HashMap.Strict as HM import qualified Data.List as L @@ -100,7 +101,7 @@ data LanguageContextData config = , resLspFuncs :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization , resWorkspaceFolders :: ![J.WorkspaceFolder] , resProgressData :: !ProgressData - , resPendingResponses :: !(J.IdMap (Product J.SMethod ServerResponseHandler)) + , resPendingResponses :: !(IxMap J.LspId (Product J.SMethod ServerResponseHandler)) } data ProgressData = ProgressData { progressNextId :: !Int @@ -260,17 +261,17 @@ mkClientResponseHandler m cm tvarDat = case J.splitClientMethod m of J.IsClientNot -> ClientResponseHandler () J.IsClientReq -> ClientResponseHandler $ \mrsp -> case mrsp of - Left err -> sendErrorResponseE tvarDat m (J.responseId $ cm ^. J.id) err + Left err -> sendErrorResponseE tvarDat m (cm ^. J.id) err Right rsp -> sendResponse tvarDat $ J.FromServerRsp m $ makeResponseMessage (cm ^. J.id) rsp J.IsClientEither -> ClientResponseHandler $ case cm of J.NotMess _ -> Nothing J.ReqMess req -> Just $ \mrsp -> case mrsp of - Left err -> sendErrorResponseE tvarDat m (J.responseId $ req ^. J.id) err + Left err -> sendErrorResponseE tvarDat m (req ^. J.id) err Right rsp -> sendResponse tvarDat $ J.FromServerRsp m $ makeResponseMessage (req ^. J.id) rsp addResponseHandler :: TVar (LanguageContextData config) -> J.LspId m -> (Product J.SMethod ServerResponseHandler) m -> IO () addResponseHandler tv lid h = atomically $ modifyTVar' tv $ \ctx@LanguageContextData{resPendingResponses} -> - ctx { resPendingResponses = J.insertIxMap lid h resPendingResponses} + ctx { resPendingResponses = insertIxMap lid h resPendingResponses} mkServerRequestFunc :: TVar (LanguageContextData config) -> SomeServerMessageWithResponse -> IO () mkServerRequestFunc tvarDat (SomeServerMessageWithResponse m msg resHandler) = @@ -461,7 +462,7 @@ _ERR_MSG_URL = [ "`stack update` and install new haskell-lsp." defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> VFS -> LanguageContextData config defaultLanguageContextData h o lf tv sf vfs = LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf (VFSData vfs mempty) mempty - Nothing tv lf mempty defaultProgressData J.emptyIxMap + Nothing tv lf mempty defaultProgressData emptyIxMap defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty @@ -511,7 +512,7 @@ handleMessage dispatcherProc tvarDat jsonStr = do handleResponse baseId resobj = do resHandler <- atomically $ do ctx <- readTVar tvarDat - let (handler, newMap) = J.pickFromIxMap' baseId (resPendingResponses ctx) + let (handler, newMap) = pickFromIxMap' baseId (resPendingResponses ctx) modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) return handler case resHandler of @@ -556,7 +557,7 @@ handleMessage dispatcherProc tvarDat jsonStr = do -- --------------------------------------------------------------------- makeResponseMessage :: J.LspId m -> J.ResponseParams m -> J.ResponseMessage m -makeResponseMessage rid result = J.ResponseMessage "2.0" (J.responseId $ rid) (Just result) Nothing +makeResponseMessage rid result = J.ResponseMessage "2.0" (Just rid) (Just result) Nothing makeResponseError :: J.LspId m -> J.ResponseError -> J.ResponseMessage m makeResponseError origId err = J.ResponseMessage "2.0" (Just origId) Nothing (Just err) @@ -574,9 +575,9 @@ sendResponse tvarCtx msg = do sendErrorResponseE :: forall (m :: J.Method J.FromClient J.Request) config. TVar (LanguageContextData config) - -> J.SMethod m -> J.LspIdRsp (m :: J.Method J.FromClient J.Request) -> J.ResponseError -> IO () + -> J.SMethod m -> J.LspId (m :: J.Method J.FromClient J.Request) -> J.ResponseError -> IO () sendErrorResponseE sf m origId err = do - sendResponse sf $ J.FromServerRsp m (J.ResponseMessage "2.0" origId Nothing (Just err)) + sendResponse sf $ J.FromServerRsp m (J.ResponseMessage "2.0" (Just origId) Nothing (Just err)) sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () sendErrorLog tv msg =