diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal --- a/hls-plugin-api.cabal +++ b/hls-plugin-api.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/Properties.hs b/src/Ide/Plugin/Properties.hs --- a/src/Ide/Plugin/Properties.hs +++ b/src/Ide/Plugin/Properties.hs @@ -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 diff --git a/src/Ide/Plugin/RangeMap.hs b/src/Ide/Plugin/RangeMap.hs --- a/src/Ide/Plugin/RangeMap.hs +++ b/src/Ide/Plugin/RangeMap.hs @@ -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. diff --git a/src/Ide/Plugin/Resolve.hs b/src/Ide/Plugin/Resolve.hs --- a/src/Ide/Plugin/Resolve.hs +++ b/src/Ide/Plugin/Resolve.hs @@ -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 diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -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 = () diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -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 diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -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)