diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 609736fc72..5b975ef058 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -23,6 +23,7 @@ module Development.IDE.Core.Rules( getParsedModuleWithComments, getClientConfigAction, usePropertyAction, + usePropertyByPathAction, getHieFile, -- * Rules CompiledLinkables(..), @@ -147,9 +148,13 @@ import qualified Ide.Logger as Logger import Ide.Plugin.Config import Ide.Plugin.Properties (HasProperty, KeyNameProxy, + KeyNamePath, Properties, ToHsType, - useProperty) + useProperty, + usePropertyByPath, + HasPropertyByPath + ) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) @@ -1061,6 +1066,16 @@ usePropertyAction kn plId p = do pluginConfig <- getPluginConfigAction plId pure $ useProperty kn p $ plcConfig pluginConfig +usePropertyByPathAction :: + (HasPropertyByPath props path t) => + KeyNamePath path -> + PluginId -> + Properties props -> + Action (ToHsType t) +usePropertyByPathAction path plId p = do + pluginConfig <- getPluginConfigAction plId + pure $ usePropertyByPath path p $ plcConfig pluginConfig + -- --------------------------------------------------------------------- getLinkableRule :: Recorder (WithPriority Log) -> Rules () diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 4e8bb6742c..eb00b42e00 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -112,6 +112,8 @@ test-suite tests Ide.TypesTests build-depends: + , bytestring + , aeson , base , containers , data-default @@ -119,6 +121,7 @@ test-suite tests , lens , lsp-types , tasty + , tasty-golden , tasty-hunit , tasty-quickcheck , tasty-rerun diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index ae3d505562..dda2bb7e33 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -1,10 +1,18 @@ -{-# 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 (..), @@ -14,8 +22,10 @@ module Ide.Plugin.Properties PropertyKey (..), SPropertyKey (..), KeyNameProxy (..), + KeyNamePath (..), Properties, HasProperty, + HasPropertyByPath, emptyProperties, defineNumberProperty, defineIntegerProperty, @@ -24,14 +34,18 @@ module Ide.Plugin.Properties 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 qualified Data.Text as T import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits + -- | Types properties may have data PropertyType = TNumber @@ -52,6 +67,7 @@ data PropertyType | 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 @@ type family ToHsType (t :: PropertyType) where 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,6 +97,15 @@ data MetaData (t :: PropertyType) where 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 @@ data SPropertyKey (k :: PropertyKey) where 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 @@ data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy 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 @@ type family NotElem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where 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 @@ parseProperty :: 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 :: 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 @@ toDefaultJSON pr = case pr of 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 @@ toVSCodeExtensionSchema prefix ps = case ps of "default" A..= defaultValue, "scope" A..= A.String "resource" ] + (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) -> + map (first Just) $ toVSCodeExtensionSchema' childrenProperties diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index 6bc02e0998..9d49ac276d 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,13 +6,29 @@ module Ide.PluginUtilsTest ( tests ) where +import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Types as A +import Data.ByteString.Lazy (ByteString) +import Data.Char (isPrint) +import Data.Function ((&)) import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Lazy as Tl +import Debug.Trace (trace, traceM) +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 +39,7 @@ tests = testGroup "PluginUtils" , localOption (QuickCheckMaxSize 10000) $ testProperty "RangeMap-List filtering identical" $ prop_rangemapListEq @Int + , propertyTest ] unescapeTest :: TestTree @@ -138,3 +156,54 @@ prop_rangemapListEq r xs = 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) diff --git a/hls-plugin-api/test/testdata/Property/NestedPropertyDefault.json b/hls-plugin-api/test/testdata/Property/NestedPropertyDefault.json new file mode 100644 index 0000000000..0d8f57656c --- /dev/null +++ b/hls-plugin-api/test/testdata/Property/NestedPropertyDefault.json @@ -0,0 +1 @@ +{"baz":"baz","parent":{"boo":"boo","foo":"foo"}} \ No newline at end of file diff --git a/hls-plugin-api/test/testdata/Property/NestedPropertyVscode.json b/hls-plugin-api/test/testdata/Property/NestedPropertyVscode.json new file mode 100644 index 0000000000..4c9e721c4d --- /dev/null +++ b/hls-plugin-api/test/testdata/Property/NestedPropertyVscode.json @@ -0,0 +1 @@ +{"top.baz":{"default":"baz","markdownDescription":"baz","scope":"resource","type":"string"},"top.parent.boo":{"default":"boo","markdownDescription":"boo","scope":"resource","type":"string"},"top.parent.foo":{"default":"foo","markdownDescription":"foo","scope":"resource","type":"string"}}