{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

module Ide.Plugin.ConfigUtils where

import qualified Data.Aeson            as A
import qualified Data.Aeson.Types      as A
import           Data.Default          (def)
import qualified Data.Dependent.Map    as DMap
import qualified Data.Dependent.Sum    as DSum
import qualified Data.HashMap.Lazy     as HMap
import           Ide.Plugin.Config
import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
import           Ide.Types
import           Language.LSP.Types

-- Attention:
-- 'diagnosticsOn' will never be added into the default config or the schema,
-- since diagnostics emit in arbitrary shake rules -- we don't know
-- whether a plugin is capable of producing diagnostics.

-- | Generates a defalut 'Config', but remains only effective items
pluginsToDefaultConfig :: IdePlugins a -> A.Value
pluginsToDefaultConfig :: IdePlugins a -> Value
pluginsToDefaultConfig IdePlugins {[(PluginId, PluginDescriptor a)]
ipMap :: forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
ipMap :: [(PluginId, PluginDescriptor a)]
..} =
  Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
    (Value -> Value) -> Text -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
HMap.adjust
      ( \(Value -> Object
unsafeValueToObject -> Object
o) ->
          Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Text
"plugin" Value
elems Object
o -- inplace the "plugin" section with our 'elems', leaving others unchanged
      )
      Text
"haskell"
      (Value -> Object
unsafeValueToObject (Config -> Value
forall a. ToJSON a => a -> Value
A.toJSON Config
defaultConfig))
  where
    defaultConfig :: Config
defaultConfig@Config {} = Config
forall a. Default a => a
def
    unsafeValueToObject :: Value -> Object
unsafeValueToObject (A.Object Object
o) = Object
o
    unsafeValueToObject Value
_            = [Char] -> Object
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
    elems :: Value
elems = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat ([[Pair]] -> [Pair]) -> [[Pair]] -> [Pair]
forall a b. (a -> b) -> a -> b
$ PluginDescriptor a -> [Pair]
forall a a. KeyValue a => PluginDescriptor a -> [a]
singlePlugin (PluginDescriptor a -> [Pair]) -> [PluginDescriptor a] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PluginId, PluginDescriptor a) -> PluginDescriptor a)
-> [(PluginId, PluginDescriptor a)] -> [PluginDescriptor a]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, PluginDescriptor a) -> PluginDescriptor a
forall a b. (a, b) -> b
snd [(PluginId, PluginDescriptor a)]
ipMap
    -- Splice genericDefaultConfig and dedicatedDefaultConfig
    -- Example:
    --
    -- {
    --  "plugin-id": {
    --    "globalOn": true,
    --    "codeActionsOn": true,
    --    "codeLensOn": true,
    --    "config": {
    --      "property1": "foo"
    --     }
    --   }
    -- }
    singlePlugin :: PluginDescriptor a -> [a]
singlePlugin PluginDescriptor {[PluginCommand a]
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
CustomConfig
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginCustomConfig :: forall ideState. PluginDescriptor ideState -> CustomConfig
pluginHandlers :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginCommands :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginRules :: forall ideState. PluginDescriptor ideState -> Rules ()
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
pluginNotificationHandlers :: PluginNotificationHandlers a
pluginCustomConfig :: CustomConfig
pluginHandlers :: PluginHandlers a
pluginCommands :: [PluginCommand a]
pluginRules :: Rules ()
pluginId :: PluginId
..} =
      let x :: [Pair]
x = [Pair]
genericDefaultConfig [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedDefaultConfig
       in [Text
pId Text -> Value -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x]
      where
        (PluginHandlers (DMap IdeMethod (PluginHandler a)
-> [DSum IdeMethod (PluginHandler a)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler a)]
handlers)) = PluginHandlers a
pluginHandlers
        customConfigToDedicatedDefaultConfig :: CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig (CustomConfig Properties r
p) = Properties r -> [Pair]
forall (r :: [PropertyKey]). Properties r -> [Pair]
toDefaultJSON Properties r
p
        -- Example:
        --
        -- {
        --   "globalOn": true,
        --   "codeActionsOn": true,
        --   "codeLensOn": true
        -- }
        --
        -- we don't generate the config section if the plugin doesn't register any of the following six methods,
        -- which avoids producing trivial configuration for formatters:
        --
        -- "stylish-haskell": {
        --    "globalOn": true
        -- }
        genericDefaultConfig :: [Pair]
genericDefaultConfig =
          let x :: [Pair]
x = [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat (DSum IdeMethod (PluginHandler a) -> [Pair]
forall (f :: Method 'FromClient 'Request -> *).
DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig (DSum IdeMethod (PluginHandler a) -> [Pair])
-> [DSum IdeMethod (PluginHandler a)] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler a)]
handlers)
           in [Text
"globalOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
x
        -- Example:
        --
        -- {
        --  "config": {
        --      "property1": "foo"
        --   }
        --}
        dedicatedDefaultConfig :: [Pair]
dedicatedDefaultConfig =
          let x :: [Pair]
x = CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig CustomConfig
pluginCustomConfig
           in [Text
"config" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x]

        (PluginId Text
pId) = PluginId
pluginId

        -- This function captures ide methods registered by the plugin, and then converts it to kv pairs
        handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair]
        handlersToGenericDefaultConfig :: DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig (IdeMethod SMethod a
m DSum.:=> f a
_) = case SMethod a
m of
          SMethod a
STextDocumentCodeAction     -> [Text
"codeActionsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentCodeLens       -> [Text
"codeLensOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentRename         -> [Text
"renameOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentHover          -> [Text
"hoverOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentDocumentSymbol -> [Text
"symbolsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentCompletion     -> [Text
"completionOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
          SMethod a
_                           -> []

-- | Generates json schema used in haskell vscode extension
-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
pluginsToVSCodeExtensionSchema :: IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins {[(PluginId, PluginDescriptor a)]
ipMap :: [(PluginId, PluginDescriptor a)]
ipMap :: forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
..} = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat ([[Pair]] -> [Pair]) -> [[Pair]] -> [Pair]
forall a b. (a -> b) -> a -> b
$ PluginDescriptor a -> [Pair]
forall a. PluginDescriptor a -> [Pair]
singlePlugin (PluginDescriptor a -> [Pair]) -> [PluginDescriptor a] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PluginId, PluginDescriptor a) -> PluginDescriptor a)
-> [(PluginId, PluginDescriptor a)] -> [PluginDescriptor a]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, PluginDescriptor a) -> PluginDescriptor a
forall a b. (a, b) -> b
snd [(PluginId, PluginDescriptor a)]
ipMap
  where
    singlePlugin :: PluginDescriptor a -> [Pair]
singlePlugin PluginDescriptor {[PluginCommand a]
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
CustomConfig
pluginNotificationHandlers :: PluginNotificationHandlers a
pluginCustomConfig :: CustomConfig
pluginHandlers :: PluginHandlers a
pluginCommands :: [PluginCommand a]
pluginRules :: Rules ()
pluginId :: PluginId
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginCustomConfig :: forall ideState. PluginDescriptor ideState -> CustomConfig
pluginHandlers :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginCommands :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginRules :: forall ideState. PluginDescriptor ideState -> Rules ()
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
..} = [Pair]
genericSchema [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedSchema
      where
        (PluginHandlers (DMap IdeMethod (PluginHandler a)
-> [DSum IdeMethod (PluginHandler a)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler a)]
handlers)) = PluginHandlers a
pluginHandlers
        customConfigToDedicatedSchema :: CustomConfig -> [Pair]
customConfigToDedicatedSchema (CustomConfig Properties r
p) = Text -> Properties r -> [Pair]
forall (r :: [PropertyKey]). Text -> Properties r -> [Pair]
toVSCodeExtensionSchema (Text -> Text
withIdPrefix Text
"config.") Properties r
p
        (PluginId Text
pId) = PluginId
pluginId
        genericSchema :: [Pair]
genericSchema = Text -> Text
withIdPrefix Text
"globalOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"plugin" Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat (DSum IdeMethod (PluginHandler a) -> [Pair]
handlersToGenericSchema (DSum IdeMethod (PluginHandler a) -> [Pair])
-> [DSum IdeMethod (PluginHandler a)] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler a)]
handlers)
        dedicatedSchema :: [Pair]
dedicatedSchema = CustomConfig -> [Pair]
customConfigToDedicatedSchema CustomConfig
pluginCustomConfig
        handlersToGenericSchema :: DSum IdeMethod (PluginHandler a) -> [Pair]
handlersToGenericSchema (IdeMethod m DSum.:=> PluginHandler a a
_) = case SMethod a
m of
          SMethod a
STextDocumentCodeAction -> [Text -> Text
withIdPrefix Text
"codeActionsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"code actions"]
          SMethod a
STextDocumentCodeLens -> [Text -> Text
withIdPrefix Text
"codeLensOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"code lenses"]
          SMethod a
STextDocumentRename -> [Text -> Text
withIdPrefix Text
"renameOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"rename"]
          SMethod a
STextDocumentHover -> [Text -> Text
withIdPrefix Text
"hoverOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"hover"]
          SMethod a
STextDocumentDocumentSymbol -> [Text -> Text
withIdPrefix Text
"symbolsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"symbols"]
          SMethod a
STextDocumentCompletion -> [Text -> Text
withIdPrefix Text
"completionOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"completions"]
          SMethod a
_ -> []
        schemaEntry :: Text -> Value
schemaEntry Text
desc =
          [Pair] -> Value
A.object
            [ Text
"scope" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String Text
"resource",
              Text
"type" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String Text
"boolean",
              Text
"default" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True,
              Text
"description" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String (Text
"Enables " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc)
            ]
        withIdPrefix :: Text -> Text
withIdPrefix Text
x = Text
"haskell.plugin." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x