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