hls-plugin-api 2.8.0.0 → 2.9.0.0

raw patch · 7 files changed

+271/−45 lines, 7 filesdep +bytestringdep +tasty-goldendep −row-typesdep ~Diffdep ~hls-graphdep ~lspPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, tasty-golden

Dependencies removed: row-types

Dependency ranges changed: Diff, hls-graph, lsp

API changes (from Hackage documentation)

Files

• hls-plugin-api.cabal +7/−5
• src/Ide/Plugin/Properties.hs +112/−20
• src/Ide/Plugin/RangeMap.hs +5/−1
• src/Ide/Plugin/Resolve.hs +6/−10
• src/Ide/PluginUtils.hs +12/−0
• src/Ide/Types.hs +64/−9
• test/Ide/PluginUtilsTest.hs +65/−0

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-plugin-api-version:       2.8.0.0+version:       2.9.0.0 synopsis:      Haskell Language Server API for plugin communication description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -60,23 +60,22 @@     , data-default     , dependent-map     , dependent-sum         >=0.7-    , Diff                  ^>=0.4.0+    , Diff                  ^>=0.5     , dlist     , extra     , filepath     , ghc     , hashable-    , hls-graph             == 2.8.0.0+    , hls-graph             == 2.9.0.0     , lens     , lens-aeson-    , lsp                   ^>=2.4+    , lsp                   ^>=2.7     , megaparsec            >=9.0     , mtl     , opentelemetry         >=0.4     , optparse-applicative     , prettyprinter     , regex-tdfa            >=1.3.1.0-    , row-types     , stm     , text     , time@@ -113,6 +112,8 @@     Ide.TypesTests    build-depends:+    , bytestring+    , aeson     , base     , containers     , data-default@@ -120,6 +121,7 @@     , lens     , lsp-types     , tasty+    , tasty-golden     , tasty-hunit     , tasty-quickcheck     , tasty-rerun

@@ -1,11 +1,19 @@-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE LambdaCase           #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} + module Ide.Plugin.Properties   ( PropertyType (..),     ToHsType,@@ -14,8 +22,10 @@     PropertyKey (..),     SPropertyKey (..),     KeyNameProxy (..),+    KeyNamePath (..),     Properties,     HasProperty,+    HasPropertyByPath,     emptyProperties,     defineNumberProperty,     defineIntegerProperty,@@ -24,14 +34,18 @@     defineObjectProperty,     defineArrayProperty,     defineEnumProperty,+    definePropertiesProperty,     toDefaultJSON,     toVSCodeExtensionSchema,     usePropertyEither,     useProperty,+    usePropertyByPathEither,+    usePropertyByPath,     (&),   ) where +import           Control.Arrow        (first) import qualified Data.Aeson           as A import qualified Data.Aeson.Types     as A import           Data.Either          (fromRight)@@ -43,6 +57,7 @@ import           GHC.OverloadedLabels (IsLabel (..)) import           GHC.TypeLits + -- | Types properties may have data PropertyType   = TNumber@@ -52,6 +67,7 @@   | TObject Type   | TArray Type   | TEnum Type+  | TProperties [PropertyKey] -- ^ A typed TObject, defined in a recursive manner  type family ToHsType (t :: PropertyType) where   ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values@@ -61,13 +77,14 @@   ToHsType ('TObject a) = a   ToHsType ('TArray a) = [a]   ToHsType ('TEnum a) = a+  ToHsType ('TProperties _) = A.Object  -- ---------------------------------------------------------------------  -- | Metadata of a property data MetaData (t :: PropertyType) where   MetaData ::-    (IsTEnum t ~ 'False) =>+    (IsTEnum t ~ 'False, IsProperties t ~ 'False) =>     { defaultValue :: ToHsType t,       description :: T.Text     } ->@@ -80,7 +97,16 @@       enumDescriptions :: [T.Text]     } ->     MetaData t+  PropertiesMetaData ::+    (t ~ TProperties rs) =>+    {+      defaultValue :: ToHsType t+      , description :: T.Text+      , childrenProperties :: Properties rs+    } ->+    MetaData t + -- | Used at type level for name-type mapping in 'Properties' data PropertyKey = PropertyKey Symbol PropertyType @@ -93,6 +119,7 @@   SObject :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TObject a))   SArray :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TArray a))   SEnum :: (A.ToJSON a, A.FromJSON a, Eq a, Show a) => Proxy a -> SPropertyKey ('PropertyKey s ('TEnum a))+  SProperties :: SPropertyKey ('PropertyKey s ('TProperties pp))  -- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData' data SomePropertyKeyWithMetaData@@ -116,12 +143,53 @@ instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where   fromLabel = KeyNameProxy +data NonEmptyList a =+    a :| NonEmptyList a | NE a++-- | a path to a property in a json object+data KeyNamePath (r :: NonEmptyList Symbol) where+   SingleKey :: KeyNameProxy s -> KeyNamePath (NE s)+   ConsKeysPath :: KeyNameProxy s1 -> KeyNamePath ss -> KeyNamePath (s1 :| ss)++class ParsePropertyPath (rs :: [PropertyKey]) (r :: NonEmptyList Symbol) where+    usePropertyByPathEither :: KeyNamePath r -> Properties rs -> A.Object -> Either String (ToHsType (FindByKeyPath r rs))+    useDefault :: KeyNamePath r -> Properties rs -> ToHsType (FindByKeyPath r rs)+    usePropertyByPath :: KeyNamePath r -> Properties rs -> A.Object -> ToHsType (FindByKeyPath r rs)+    usePropertyByPath p ps x = fromRight (useDefault p ps) $ usePropertyByPathEither p ps x++instance (HasProperty s k t r) => ParsePropertyPath r (NE s) where+    usePropertyByPathEither (SingleKey kn) sm x = parseProperty kn (find kn sm) x+    useDefault (SingleKey kn) sm = defaultValue metadata+        where (_, metadata) = find kn sm++instance ( ToHsType (FindByKeyPath ss r2) ~ ToHsType (FindByKeyPath (s :| ss) r)+          ,HasProperty s ('PropertyKey s ('TProperties r2)) t2 r+          , ParsePropertyPath r2 ss)+          => ParsePropertyPath r (s :| ss) where+    usePropertyByPathEither (ConsKeysPath kn p) sm x = do+        let (key, meta) = find kn sm+        interMedia <- parseProperty kn (key, meta) x+        case meta of+            PropertiesMetaData {..}+                -> usePropertyByPathEither p childrenProperties interMedia+    useDefault (ConsKeysPath kn p) sm = case find kn sm of+            (_, PropertiesMetaData {..}) -> useDefault p childrenProperties+ -- --------------------------------------------------------------------- +type family IsProperties (t :: PropertyType) :: Bool where+  IsProperties ('TProperties pp) = 'True+  IsProperties _ = 'False+ type family IsTEnum (t :: PropertyType) :: Bool where   IsTEnum ('TEnum _) = 'True   IsTEnum _ = 'False +type family FindByKeyPath (ne :: NonEmptyList Symbol) (r :: [PropertyKey]) :: PropertyType where+  FindByKeyPath (s :| xs) ('PropertyKey s ('TProperties rs) ': _) = FindByKeyPath xs rs+  FindByKeyPath (s :| xs) (_ ': ys) = FindByKeyPath (s :| xs) ys+  FindByKeyPath (NE s) ys = FindByKeyName s ys+ type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where   FindByKeyName s ('PropertyKey s t ': _) = t   FindByKeyName s (_ ': xs) = FindByKeyName s xs@@ -140,10 +208,13 @@   NotElem s (_ ': xs) = NotElem s xs   NotElem s '[] = () + -- | In row @r@, there is a 'PropertyKey' @k@, which has name @s@ and carries haskell type @t@-type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s, FindPropertyMeta s r t)+type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyPath (NE s) r ~ t, FindByKeyName s r ~ t, KnownSymbol s, FindPropertyMeta s r t)+-- similar to HasProperty, but the path is given as a type-level list of symbols+type HasPropertyByPath props path t = (t ~ FindByKeyPath path props, ParsePropertyPath props path) class FindPropertyMeta (s :: Symbol) (r :: [PropertyKey]) t where-    findSomePropertyKeyWithMetaData :: KeyNameProxy s -> Properties r -> (SPropertyKey ('PropertyKey s t), MetaData t)+   findSomePropertyKeyWithMetaData :: KeyNameProxy s -> Properties r -> (SPropertyKey ('PropertyKey s t), MetaData t) instance (FindPropertyMetaIf (IsPropertySymbol symbol k) symbol k ks t) => FindPropertyMeta symbol (k : ks) t where   findSomePropertyKeyWithMetaData = findSomePropertyKeyWithMetaDataIf class (bool ~ IsPropertySymbol symbol k) => FindPropertyMetaIf bool symbol k ks t where@@ -219,6 +290,7 @@   A.Object ->   Either String (ToHsType t) parseProperty kn k x = case k of+  (SProperties, _) -> parseEither   (SNumber, _) -> parseEither   (SInteger, _) -> parseEither   (SString, _) -> parseEither@@ -338,6 +410,16 @@ defineEnumProperty kn description enums defaultValue =   insert kn (SEnum Proxy) $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) +definePropertiesProperty ::+  (KnownSymbol s, NotElem s r) =>+  KeyNameProxy s ->+  T.Text ->+  Properties childrenProps ->+  Properties r ->+  Properties ('PropertyKey s ('TProperties childrenProps) : r)+definePropertiesProperty kn description ps rs =+    insert kn SProperties (PropertiesMetaData mempty description ps) rs+ -- ---------------------------------------------------------------------  -- | Converts a properties definition into kv pairs with default values from 'MetaData'@@ -363,60 +445,68 @@         fromString s A..= defaultValue       (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->         fromString s A..= defaultValue+      (SomePropertyKeyWithMetaData SProperties  PropertiesMetaData {..}) ->+        fromString s A..= A.object (toDefaultJSON childrenProperties)  -- | Converts a properties definition into kv pairs as vscode schema toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair]-toVSCodeExtensionSchema prefix ps = case ps of+toVSCodeExtensionSchema prefix p = [fromString (T.unpack prefix <> fromString k) A..= v | (k, v) <- toVSCodeExtensionSchema' p]+toVSCodeExtensionSchema' :: Properties r -> [(String, A.Value)]+toVSCodeExtensionSchema' ps = case ps of     EmptyProperties -> []     ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs ->-       fromString (T.unpack prefix <> symbolVal keyNameProxy) A..= toEntry (SomePropertyKeyWithMetaData k m) : toVSCodeExtensionSchema prefix xs+          [(symbolVal keyNameProxy <> maybe "" ((<>) ".") k1, v)+            | (k1, v) <- toEntry (SomePropertyKeyWithMetaData k m) ]+          ++ toVSCodeExtensionSchema' xs   where-    toEntry :: SomePropertyKeyWithMetaData -> A.Value+    wrapEmpty :: A.Value -> [(Maybe String, A.Value)]+    wrapEmpty v = [(Nothing, v)]+    toEntry :: SomePropertyKeyWithMetaData -> [(Maybe String, A.Value)]     toEntry = \case       (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "number",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "integer",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData SString MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "string",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "boolean",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "object",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "array",             "markdownDescription" A..= description,             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]       (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->-        A.object+        wrapEmpty $ A.object           [ "type" A..= A.String "string",             "description" A..= description,             "enum" A..= enumValues,@@ -424,3 +514,5 @@             "default" A..= defaultValue,             "scope" A..= A.String "resource"           ]+      (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) ->+        map (first Just) $ toVSCodeExtensionSchema' childrenProperties

@@ -16,14 +16,18 @@   ) where  import           Development.IDE.Graph.Classes            (NFData)+ #ifdef USE_FINGERTREE import           Data.Bifunctor                           (first)-import           Data.Foldable                            (foldl') import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM import           Language.LSP.Protocol.Types              (Position,                                                            Range (Range)) #else import           Language.LSP.Protocol.Types              (Range, isSubrangeOf)+#endif++#if USE_FINGERTREE && !MIN_VERSION_base(4,20,0)+import           Data.List                                (foldl') #endif  -- | A map from code ranges to values.

@@ -1,6 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase               #-}-{-# LANGUAGE OverloadedLabels         #-} {-# LANGUAGE OverloadedStrings        #-} {-| This module currently includes helper functions to provide fallback support to code actions that use resolve in HLS. The difference between the two@@ -26,7 +25,6 @@  import qualified Data.Aeson                    as A import           Data.Maybe                    (catMaybes)-import           Data.Row                      ((.!)) import qualified Data.Text                     as T import           GHC.Generics                  (Generic) import           Ide.Logger@@ -35,12 +33,10 @@ import qualified Language.LSP.Protocol.Lens    as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server           (LspT, getClientCapabilities,-                                                sendRequest)  data Log     = DoesNotSupportResolve T.Text-    | ApplyWorkspaceEditFailed ResponseError+    | forall m . A.ToJSON (ErrorData m) => ApplyWorkspaceEditFailed (TResponseError m) instance Pretty Log where     pretty = \case         DoesNotSupportResolve fallback->@@ -62,7 +58,7 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =   let newCodeActionMethod ideState pid params =         do codeActionReturn <- codeActionMethod ideState pid params-           caps <- lift getClientCapabilities+           caps <- lift pluginGetClientCapabilities            case codeActionReturn of              r@(InR Null) -> pure r              (InL ls) | -- We don't need to do anything if the client supports@@ -76,7 +72,7 @@   <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)   where dropData :: CodeAction -> CodeAction         dropData ca = ca & L.data_ .~ Nothing-        resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)+        resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (HandlerM Config) (Command |? CodeAction)         resolveCodeAction _uri _ideState _plId c@(InL _) = pure c         resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do           case A.fromJSON value of@@ -107,7 +103,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod =   let newCodeActionMethod ideState pid params =         do codeActionReturn <- codeActionMethod ideState pid params-           caps <- lift getClientCapabilities+           caps <- lift pluginGetClientCapabilities            case codeActionReturn of              r@(InR Null) -> pure r              (InL ls) | -- We don't need to do anything if the client supports@@ -147,7 +143,7 @@                   resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded                   case resolveResult of                     ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do-                        _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback+                        _ <- ExceptT $ Right <$> pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback                         pure $ InR Null                     ca2@CodeAction {_edit = Just _ }  ->                       throwError $ internalError $@@ -190,7 +186,7 @@ supportsCodeActionResolve caps =     caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True     && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of-        Just row -> "edit" `elem` row .! #properties+        Just ClientCodeActionResolveOptions{_properties} -> "edit" `elem` _properties         _        -> False  internalError :: T.Text -> PluginError

@@ -32,6 +32,8 @@     usePropertyLsp,     -- * Escape     unescape,+    -- * toAbsolute+    toAbsolute   ) where @@ -50,6 +52,7 @@ import qualified Language.LSP.Protocol.Lens  as L import           Language.LSP.Protocol.Types import           Language.LSP.Server+import           System.FilePath             ((</>)) import qualified Text.Megaparsec             as P import qualified Text.Megaparsec.Char        as P import qualified Text.Megaparsec.Char.Lexer  as P@@ -316,3 +319,12 @@           inside' = concatMap f inside        pure $ "\"" <> inside' <> "\""++-- ---------------------------------------------------------------------++-- | toAbsolute+-- use `toAbsolute` to state our intention that we are actually make a path absolute+-- the first argument should be the root directory+-- the second argument should be the relative path+toAbsolute :: FilePath -> FilePath -> FilePath+toAbsolute = (</>)

@@ -31,6 +31,7 @@ , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId , PluginId(..) , PluginHandler(..), mkPluginHandler+, HandlerM, runHandlerM, pluginGetClientCapabilities, pluginGetVirtualFile, pluginGetVersionedTextDoc, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress , PluginHandlers(..) , PluginMethod(..) , PluginMethodHandler@@ -62,6 +63,7 @@                                                 (^?)) import           Control.Monad                 (void) import           Control.Monad.Error.Class     (MonadError (throwError))+import           Control.Monad.IO.Class        (MonadIO) import           Control.Monad.Trans.Class     (MonadTrans (lift)) import           Control.Monad.Trans.Except    (ExceptT, runExceptT) import           Data.Aeson                    hiding (Null, defaultOptions)@@ -70,7 +72,6 @@ import           Data.Dependent.Map            (DMap) import qualified Data.Dependent.Map            as DMap import qualified Data.DList                    as DList-import           Data.Foldable                 (foldl') import           Data.GADT.Compare import           Data.Hashable                 (Hashable) import           Data.HashMap.Strict           (HashMap)@@ -94,7 +95,7 @@ import qualified Language.LSP.Protocol.Lens    as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server           (LspM, LspT, getVirtualFile)+import           Language.LSP.Server import           Language.LSP.VFS import           Numeric.Natural import           OpenTelemetry.Eventlog@@ -103,6 +104,12 @@ import           System.FilePath import           System.IO.Unsafe import           Text.Regex.TDFA.Text          ()+import           UnliftIO                      (MonadUnliftIO)++#if !MIN_VERSION_base(4,20,0)+import           Data.Foldable                 (foldl')+#endif+ -- ---------------------------------------------------------------------  data IdePlugins ideState = IdePlugins_@@ -890,9 +897,57 @@ instance GCompare IdeNotification where   gcompare (IdeNotification a) (IdeNotification b) = gcompare a b +-- | Restricted version of 'LspM' specific to plugins.+--+-- We plan to use this monad for running plugins instead of 'LspM', since there+-- are parts of the LSP server state which plugins should not access directly,+-- but instead only via the build system. Note that this restriction of the LSP+-- server state has not yet been implemented. See 'pluginGetVirtualFile'.+newtype HandlerM config a = HandlerM { _runHandlerM :: LspM config a }+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO)++runHandlerM :: HandlerM config a -> LspM config a+runHandlerM = _runHandlerM++-- | Wrapper of 'getVirtualFile' for HandlerM+--+-- TODO: To be replaced by a lookup of the Shake build graph+pluginGetVirtualFile :: NormalizedUri -> HandlerM config (Maybe VirtualFile)+pluginGetVirtualFile uri = HandlerM $ getVirtualFile uri++-- | Version of 'getVersionedTextDoc' for HandlerM+--+-- TODO: Should use 'pluginGetVirtualFile' instead of wrapping 'getVersionedTextDoc'.+-- At the time of writing, 'getVersionedTextDoc' of the "lsp" package is implemented with 'getVirtualFile'.+pluginGetVersionedTextDoc :: TextDocumentIdentifier -> HandlerM config VersionedTextDocumentIdentifier+pluginGetVersionedTextDoc = HandlerM . getVersionedTextDoc++-- | Wrapper of 'getClientCapabilities' for HandlerM+pluginGetClientCapabilities :: HandlerM config ClientCapabilities+pluginGetClientCapabilities = HandlerM getClientCapabilities++-- | Wrapper of 'sendNotification for HandlerM+--+-- TODO: Return notification in result instead of calling `sendNotification` directly+pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> HandlerM config ()+pluginSendNotification smethod params = HandlerM $ sendNotification smethod params++-- | Wrapper of 'sendRequest' for HandlerM+--+-- TODO: Return request in result instead of calling `sendRequest` directly+pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> HandlerM config ()) -> HandlerM config (LspId m)+pluginSendRequest smethod params action = HandlerM $ sendRequest smethod params (runHandlerM . action)++-- | Wrapper of 'withIndefiniteProgress' for HandlerM+pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> HandlerM config ()) -> HandlerM config a) -> HandlerM config a+pluginWithIndefiniteProgress title progressToken cancellable updateAction =+  HandlerM $+    withIndefiniteProgress title progressToken cancellable $ \putUpdate ->+      runHandlerM $ updateAction (HandlerM . putUpdate)+ -- | Combine handlers for the newtype PluginHandler a (m :: Method ClientToServer Request)-  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))+  = PluginHandler (PluginId -> a -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))  newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)   = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())@@ -917,7 +972,7 @@ instance Monoid (PluginNotificationHandlers a) where   mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (HandlerM Config) (MessageResult m)  type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -930,7 +985,7 @@   -> PluginHandlers ideState mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m))   where-    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))+    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m)))     -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions     -- CodeLens, and Completion methods.     f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =@@ -1034,7 +1089,7 @@   = ideState   -> Maybe ProgressToken   -> a-  -> ExceptT PluginError (LspM Config) (Value |? Null)+  -> ExceptT PluginError (HandlerM Config) (Value |? Null)  -- --------------------------------------------------------------------- @@ -1044,7 +1099,7 @@   -> MessageParams m   -> Uri   -> a-  -> ExceptT PluginError (LspM Config) (MessageResult m)+  -> ExceptT PluginError (HandlerM Config) (MessageResult m)  -- | Make a handler for resolve methods. In here we take your provided ResolveFunction -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]@@ -1126,7 +1181,7 @@   -> T.Text   -> NormalizedFilePath   -> FormattingOptions-  -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)+  -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)  mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)@@ -1135,7 +1190,7 @@     provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m     provider m ide _pid params       | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do-        mf <- lift $ getVirtualFile $ toNormalizedUri uri+        mf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri         case mf of           Just vf -> do             let (typ, mtoken) = case m of

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedLabels  #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,13 +6,25 @@     ( tests     ) where +import qualified Data.Aeson                  as A+import qualified Data.Aeson.Types            as A+import           Data.ByteString.Lazy        (ByteString)+import           Data.Function               ((&)) import qualified Data.Set                    as Set import qualified Data.Text                   as T+import           Ide.Plugin.Properties       (KeyNamePath (..),+                                              definePropertiesProperty,+                                              defineStringProperty,+                                              emptyProperties, toDefaultJSON,+                                              toVSCodeExtensionSchema,+                                              usePropertyByPath,+                                              usePropertyByPathEither) import qualified Ide.Plugin.RangeMap         as RangeMap import           Ide.PluginUtils             (extractTextInRange, unescape) import           Language.LSP.Protocol.Types (Position (..), Range (Range),                                               UInt, isSubrangeOf) import           Test.Tasty+import           Test.Tasty.Golden           (goldenVsStringDiff) import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck @@ -22,6 +35,7 @@     , localOption (QuickCheckMaxSize 10000) $         testProperty "RangeMap-List filtering identical" $           prop_rangemapListEq @Int+    , propertyTest     ]  unescapeTest :: TestTree@@ -138,3 +152,54 @@       cover 5 (length filteredList == 1) "1 match" $       cover 2 (length filteredList > 1) ">1 matches" $       Set.fromList filteredList === Set.fromList filteredRangeMap+++gitDiff :: FilePath -> FilePath -> [String]+gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "-w", "--no-index", "--text", "--exit-code", fRef, fNew]++goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree+goldenGitDiff name = goldenVsStringDiff name gitDiff++testDir :: FilePath+testDir = "test/testdata/Property"++propertyTest :: TestTree+propertyTest = testGroup "property api tests" [+    goldenGitDiff "property toVSCodeExtensionSchema" (testDir <> "/NestedPropertyVscode.json") (return $ A.encode $ A.object $ toVSCodeExtensionSchema "top." nestedPropertiesExample)+    , goldenGitDiff "property toDefaultJSON" (testDir <> "/NestedPropertyDefault.json") (return $ A.encode $ A.object $ toDefaultJSON nestedPropertiesExample)+    , testCase "parsePropertyPath single key path" $ do+        let obj = A.object (toDefaultJSON nestedPropertiesExample)+        let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+                let key1 = usePropertyByPathEither examplePath1 nestedPropertiesExample o+                return key1) obj+        key1 @?= Right (Right "baz")+    , testCase "parsePropertyPath two key path" $ do+        let obj = A.object (toDefaultJSON nestedPropertiesExample)+        let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+                let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+                return key1) obj+        key1 @?= Right (Right "foo")+    , testCase "parsePropertyPath two key path default" $ do+        let obj = A.object []+        let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+                let key1 = usePropertyByPath examplePath2 nestedPropertiesExample o+                return key1) obj+        key1 @?= Right "foo"+    , testCase "parsePropertyPath two key path not default" $ do+        let obj = A.object (toDefaultJSON nestedPropertiesExample2)+        let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+                let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+                return key1) obj+        key1 @?= Right (Right "xxx")+    ]+    where+    nestedPropertiesExample = emptyProperties+        & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "foo" & defineStringProperty #boo "boo" "boo")+        & defineStringProperty #baz "baz" "baz"++    nestedPropertiesExample2 = emptyProperties+        & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "xxx")+        & defineStringProperty #baz "baz" "baz"++    examplePath1 = SingleKey #baz+    examplePath2 = ConsKeysPath #parent (SingleKey #foo)