From 1468d13d6ef3ef18b34002801012ba2139bbd9da Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Wed, 22 Dec 2021 19:31:58 +0000 Subject: [PATCH 1/2] Eliminate dependent-sum and dependent-map dependencies --- lsp-types/lsp-types.cabal | 2 +- .../src/Language/LSP/Types/SMethodMap.hs | 62 +++++++++++++++++++ lsp/lsp.cabal | 1 - lsp/src/Language/LSP/Server/Core.hs | 30 ++++----- lsp/src/Language/LSP/Server/Processing.hs | 12 ++-- 5 files changed, 84 insertions(+), 23 deletions(-) create mode 100644 lsp-types/src/Language/LSP/Types/SMethodMap.hs diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal index 733ff6221..1af690723 100644 --- a/lsp-types/lsp-types.cabal +++ b/lsp-types/lsp-types.cabal @@ -20,6 +20,7 @@ library exposed-modules: Language.LSP.Types , Language.LSP.Types.Capabilities , Language.LSP.Types.Lens + , Language.LSP.Types.SMethodMap , Language.LSP.VFS , Data.IxMap other-modules: Language.LSP.Types.CallHierarchy @@ -90,7 +91,6 @@ library , rope-utf16-splay >= 0.3.1.0 , scientific , some - , dependent-sum >= 0.7.1.0 , text , template-haskell , temporary diff --git a/lsp-types/src/Language/LSP/Types/SMethodMap.hs b/lsp-types/src/Language/LSP/Types/SMethodMap.hs new file mode 100644 index 000000000..fb758c8fe --- /dev/null +++ b/lsp-types/src/Language/LSP/Types/SMethodMap.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Language.LSP.Types.SMethodMap + ( SMethodMap + , singleton + , insert + , delete + , member + , lookup + , map + ) where + +import Prelude hiding (lookup, map) +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Kind (Type) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import GHC.Exts (Int(..), dataToTag#) +import Unsafe.Coerce (unsafeCoerce) + +import Language.LSP.Types.Method (Method(..), SMethod(..)) + +data SMethodMap (v :: Method f t -> Type) = + SMethodMap !(IntMap (v 'CustomMethod)) !(Map Text (v 'CustomMethod)) + +toIx :: SMethod a -> Int +toIx k = I# (dataToTag# k) + +singleton :: SMethod a -> v a -> SMethodMap v +singleton (SCustomMethod t) v = SMethodMap mempty (Map.singleton t v) +singleton k v = SMethodMap (IntMap.singleton (toIx k) (unsafeCoerce v)) mempty + +insert :: SMethod a -> v a -> SMethodMap v -> SMethodMap v +insert (SCustomMethod t) v (SMethodMap xs ys) = SMethodMap xs (Map.insert t v ys) +insert k v (SMethodMap xs ys) = SMethodMap (IntMap.insert (toIx k) (unsafeCoerce v) xs) ys + +delete :: SMethod a -> SMethodMap v -> SMethodMap v +delete (SCustomMethod t) (SMethodMap xs ys) = SMethodMap xs (Map.delete t ys) +delete k (SMethodMap xs ys) = SMethodMap (IntMap.delete (toIx k) xs) ys + +member :: SMethod a -> SMethodMap v -> Bool +member (SCustomMethod t) (SMethodMap _ ys) = Map.member t ys +member k (SMethodMap xs _) = IntMap.member (toIx k) xs + +lookup :: SMethod a -> SMethodMap v -> Maybe (v a) +lookup (SCustomMethod t) (SMethodMap _ ys) = Map.lookup t ys +lookup k (SMethodMap xs _) = unsafeCoerce (IntMap.lookup (toIx k) xs) + +map :: (forall a. u a -> v a) -> SMethodMap u -> SMethodMap v +map f (SMethodMap xs ys) = SMethodMap (IntMap.map f xs) (Map.map f ys) + +instance Semigroup (SMethodMap v) where + SMethodMap xs ys <> SMethodMap xs' ys' = SMethodMap (xs <> xs') (ys <> ys') + +instance Monoid (SMethodMap v) where + mempty = SMethodMap mempty mempty diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 7cec6d64b..7ae40103d 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -42,7 +42,6 @@ library , hslogger , hashable , lsp-types == 1.4.* - , dependent-map , lens >= 4.15.2 , mtl , network-uri diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 267b978e3..c7af82a27 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -42,8 +42,6 @@ import qualified Data.Aeson as J import Data.Default import Data.Functor.Product import Data.IxMap -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Map (DMap) import qualified Data.HashMap.Strict as HM import Data.Kind import qualified Data.List as L @@ -56,6 +54,8 @@ import Data.Text ( Text ) import qualified Data.UUID as UUID import qualified Language.LSP.Types.Capabilities as J import Language.LSP.Types as J +import Language.LSP.Types.SMethodMap (SMethodMap) +import qualified Language.LSP.Types.SMethodMap as SMethodMap import qualified Language.LSP.Types.Lens as J import Language.LSP.VFS import Language.LSP.Diagnostics @@ -131,8 +131,8 @@ data LanguageContextEnv config = -- @ data Handlers m = Handlers - { reqHandlers :: !(DMap SMethod (ClientMessageHandler m Request)) - , notHandlers :: !(DMap SMethod (ClientMessageHandler m Notification)) + { reqHandlers :: !(SMethodMap (ClientMessageHandler m Request)) + , notHandlers :: !(SMethodMap (ClientMessageHandler m Notification)) } instance Semigroup (Handlers config) where Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) @@ -140,10 +140,10 @@ instance Monoid (Handlers config) where mempty = Handlers mempty mempty notificationHandler :: forall (m :: Method FromClient Notification) f. SMethod m -> Handler f m -> Handlers f -notificationHandler m h = Handlers mempty (DMap.singleton m (ClientMessageHandler h)) +notificationHandler m h = Handlers mempty (SMethodMap.singleton m (ClientMessageHandler h)) requestHandler :: forall (m :: Method FromClient Request) f. SMethod m -> Handler f m -> Handlers f -requestHandler m h = Handlers (DMap.singleton m (ClientMessageHandler h)) mempty +requestHandler m h = Handlers (SMethodMap.singleton m (ClientMessageHandler h)) mempty -- | Wrapper to restrict 'Handler's to 'FromClient' 'Method's newtype ClientMessageHandler f (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler f m) @@ -170,8 +170,8 @@ mapHandlers -> Handlers m -> Handlers n mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' where - reqs' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs - nots' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots + reqs' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs + nots' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots -- | state used by the LSP dispatcher to manage the message loop data LanguageContextState config = @@ -189,7 +189,7 @@ data LanguageContextState config = type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) -type RegistrationMap (t :: MethodType) = DMap SMethod (Product RegistrationId (ClientMessageHandler IO t)) +type RegistrationMap (t :: MethodType) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t)) data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text @@ -496,8 +496,8 @@ registerCapability method regOpts f = do clientCaps <- resClientCapabilities <$> getLspEnv handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of - IsClientNot -> DMap.member method $ notHandlers handlers - IsClientReq -> DMap.member method $ reqHandlers handlers + IsClientNot -> SMethodMap.member method $ notHandlers handlers + IsClientReq -> SMethodMap.member method $ reqHandlers handlers IsClientEither -> error "Cannot register capability for custom methods" go clientCaps alreadyStaticallyRegistered where @@ -515,10 +515,10 @@ registerCapability method regOpts f = do ~() <- case splitClientMethod method of IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) - in DMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) - in DMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientEither -> error "Cannot register capability for custom methods" -- TODO: handle the scenario where this returns an error @@ -572,8 +572,8 @@ registerCapability method regOpts f = do unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do ~() <- case splitClientMethod m of - IsClientReq -> modifyState resRegistrationsReq $ DMap.delete m - IsClientNot -> modifyState resRegistrationsNot $ DMap.delete m + IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m + IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m IsClientEither -> error "Cannot unregister capability for custom methods" let unregistration = J.Unregistration uuid (J.SomeClientMethod m) diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index a249df6ec..aff536ad3 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -22,6 +22,8 @@ import qualified Data.Text.Lazy.Encoding as TL import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Types.SMethodMap (SMethodMap) +import qualified Language.LSP.Types.SMethodMap as SMethodMap import Language.LSP.Server.Core import Language.LSP.VFS import Data.Functor.Product @@ -34,9 +36,7 @@ import Control.Monad.Trans.Except import Control.Monad.Reader import Data.IxMap import System.Log.Logger -import qualified Data.Dependent.Map as DMap import Data.Maybe -import Data.Dependent.Map (DMap) import qualified Data.Map.Strict as Map import System.Exit import Data.Default (def) @@ -185,8 +185,8 @@ inferServerCapabilities clientCaps o h = supported_b :: forall m. SClientMethod m -> Bool supported_b m = case splitClientMethod m of - IsClientNot -> DMap.member m $ notHandlers h - IsClientReq -> DMap.member m $ reqHandlers h + IsClientNot -> SMethodMap.member m $ notHandlers h + IsClientReq -> SMethodMap.member m $ reqHandlers h IsClientEither -> error "capabilities depend on custom method" singleton :: a -> [a] @@ -335,8 +335,8 @@ handle' mAction m msg = do where -- | Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. - pickHandler :: RegistrationMap t -> DMap SMethod (ClientMessageHandler IO t) -> Maybe (Handler IO m) - pickHandler dynHandlerMap staticHandler = case (DMap.lookup m dynHandlerMap, DMap.lookup m staticHandler) of + pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO m) + pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of (Just (Pair _ (ClientMessageHandler h)), _) -> Just h (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing From c6bde6a8a3ecdec31d5c8d8a6430d5f2e5e450a5 Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Wed, 22 Dec 2021 19:58:32 +0000 Subject: [PATCH 2/2] Add GHC 9.2 to CI config --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0ae028418..f2228d13b 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -9,7 +9,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['9.0.1', '8.10.7', '8.8.4', '8.6.5'] + ghc: ['9.2.1', '9.0.1', '8.10.7', '8.8.4', '8.6.5'] os: [ubuntu-latest, macOS-latest, windows-latest] steps: