3944 extend the properties api to better support nested configuration

ghcide/src/Development/IDE/Core/Rules.hs

@@ -23,6 +23,7 @@
     getParsedModuleWithComments,
     getClientConfigAction,
     usePropertyAction,
+    usePropertyByPathAction,
     getHieFile,
     -- * Rules
     CompiledLinkables(..),
@@ -147,9 +148,13 @@
 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))
@@ -818,7 +823,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -1061,6 +1066,16 @@
   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 ()
@@ -1090,7 +1105,7 @@
             -- thus bump its modification time, forcing this rule to be rerun every time.
             exists <- liftIO $ doesFileExist obj_file
             mobj_time <- liftIO $
               if exists
               then Just <$> getModTime obj_file
               else pure Nothing
             case mobj_time of

hls-plugin-api/hls-plugin-api.cabal

@@ -112,13 +112,16 @@ test-suite tests
     Ide.TypesTests
 
   build-depends:
+    , bytestring
+    , aeson
     , base
     , containers
     , data-default
     , hls-plugin-api
     , lens
     , lsp-types
     , tasty
+    , tasty-golden
     , tasty-hunit
     , tasty-quickcheck
     , tasty-rerun

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,64 +445,74 @@ 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,
             "enumDescriptions" A..= enumDescriptions,
             "default" A..= defaultValue,
             "scope" A..= A.String "resource"
           ]
+      (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) ->
+        map (first Just) $ toVSCodeExtensionSchema' childrenProperties