Merge pull request #384 from Bodigrim/master

Eliminate dependent-sum and dependent-map dependencies

Author: michaelpj

.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:

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

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

lsp/lsp.cabal

@@ -42,7 +42,6 @@ library
                      , hslogger
                      , hashable
                      , lsp-types == 1.4.*
-                     , dependent-map
                      , lens >= 4.15.2
                      , mtl
                      , network-uri

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,19 +131,19 @@ 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)
 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)

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