1{-# LANGUAGE GADTs #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE RecordWildCards #-} 4{-# LANGUAGE ViewPatterns #-} 5 6module Ide.Plugin.ConfigUtils where 7 8import qualified Data.Aeson as A 9import qualified Data.Aeson.Types as A 10import Data.Default (def) 11import qualified Data.Dependent.Map as DMap 12import qualified Data.Dependent.Sum as DSum 13import qualified Data.HashMap.Lazy as HMap 14import Data.List (nub) 15import Ide.Plugin.Config 16import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) 17import Ide.Types 18import Language.LSP.Types 19 20-- Attention: 21-- 'diagnosticsOn' will never be added into the default config or the schema, 22-- since diagnostics emit in arbitrary shake rules -- we don't know 23-- whether a plugin is capable of producing diagnostics. 24 25-- | Generates a default 'Config', but remains only effective items 26pluginsToDefaultConfig :: IdePlugins a -> A.Value 27pluginsToDefaultConfig IdePlugins {..} = 28 A.Object $ 29 HMap.adjust 30 ( \(unsafeValueToObject -> o) -> 31 A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged 32 ) 33 "haskell" 34 (unsafeValueToObject (A.toJSON defaultConfig)) 35 where 36 defaultConfig@Config {} = def 37 unsafeValueToObject (A.Object o) = o 38 unsafeValueToObject _ = error "impossible" 39 elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap 40 -- Splice genericDefaultConfig and dedicatedDefaultConfig 41 -- Example: 42 -- 43 -- { 44 -- "plugin-id": { 45 -- "globalOn": true, 46 -- "codeActionsOn": true, 47 -- "codeLensOn": true, 48 -- "config": { 49 -- "property1": "foo" 50 -- } 51 -- } 52 -- } 53 singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = 54 let x = genericDefaultConfig <> dedicatedDefaultConfig 55 in [pId A..= A.object x | not $ null x] 56 where 57 (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers 58 customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p 59 -- Example: 60 -- 61 -- { 62 -- "codeActionsOn": true, 63 -- "codeLensOn": true 64 -- } 65 -- 66 genericDefaultConfig = 67 let x = ["diagnosticsOn" A..= True | configHasDiagnostics] <> nub (mconcat (handlersToGenericDefaultConfig <$> handlers)) 68 in case x of 69 -- if the plugin has only one capability, we produce globalOn instead of the specific one; 70 -- otherwise we don't produce globalOn at all 71 [_] -> ["globalOn" A..= True] 72 _ -> x 73 -- Example: 74 -- 75 -- { 76 -- "config": { 77 -- "property1": "foo" 78 -- } 79 --} 80 dedicatedDefaultConfig = 81 let x = customConfigToDedicatedDefaultConfig configCustomConfig 82 in ["config" A..= A.object x | not $ null x] 83 84 (PluginId pId) = pluginId 85 86 -- This function captures ide methods registered by the plugin, and then converts it to kv pairs 87 handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair] 88 handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of 89 STextDocumentCodeAction -> ["codeActionsOn" A..= True] 90 STextDocumentCodeLens -> ["codeLensOn" A..= True] 91 STextDocumentRename -> ["renameOn" A..= True] 92 STextDocumentHover -> ["hoverOn" A..= True] 93 STextDocumentDocumentSymbol -> ["symbolsOn" A..= True] 94 STextDocumentCompletion -> ["completionOn" A..= True] 95 STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= True] 96 _ -> [] 97 98-- | Generates json schema used in haskell vscode extension 99-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure 100pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value 101pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap 102 where 103 singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema 104 where 105 (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers 106 customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p 107 (PluginId pId) = pluginId 108 genericSchema = 109 let x = 110 [withIdPrefix "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics] 111 <> nub (mconcat (handlersToGenericSchema <$> handlers)) 112 in case x of 113 -- If the plugin has only one capability, we produce globalOn instead of the specific one; 114 -- otherwise we don't produce globalOn at all 115 [_] -> [withIdPrefix "globalOn" A..= schemaEntry "plugin"] 116 _ -> x 117 dedicatedSchema = customConfigToDedicatedSchema configCustomConfig 118 handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of 119 STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"] 120 STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"] 121 STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"] 122 STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"] 123 STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"] 124 STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"] 125 STextDocumentPrepareCallHierarchy -> [withIdPrefix "callHierarchyOn" A..= schemaEntry "call hierarchy"] 126 _ -> [] 127 schemaEntry desc = 128 A.object 129 [ "scope" A..= A.String "resource", 130 "type" A..= A.String "boolean", 131 "default" A..= True, 132 "description" A..= A.String ("Enables " <> pId <> " " <> desc) 133 ] 134 withIdPrefix x = "haskell.plugin." <> pId <> "." <> x 135