Skip to content

Commit

Permalink
Split out IxMap into new module
Browse files Browse the repository at this point in the history
  • Loading branch information
@wz1000
wz1000 committed May 8, 2020
1 parent ddd8555 commit f2c617c
Show file tree
Hide file tree
Showing 5 changed files with 66 additions and 79 deletions.
1 change: 1 addition & 0 deletions haskell-lsp-types/haskell-lsp-types.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
40 changes: 40 additions & 0 deletions haskell-lsp-types/src/Data/IxMap.hs
View file
Original file line number Diff line number Diff line change
@@ -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)
2 changes: 0 additions & 2 deletions haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,8 +7,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PolyKinds #-}
Expand Down
83 changes: 15 additions & 68 deletions haskell-lsp-types/src/Language/Haskell/LSP/Types/Message.hs
View file
Original file line number Diff line number Diff line change
@@ -1,37 +1,24 @@
{-# 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

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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
19 changes: 10 additions & 9 deletions src/Language/Haskell/LSP/Core.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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) =
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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 =
Expand Down

0 comments on commit f2c617c

Please sign in to comment.