{-# 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           Data.List             (nub)
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 default '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 {pluginConfigDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor {Bool
CustomConfig
configCustomConfig :: ConfigDescriptor -> CustomConfig
configHasDiagnostics :: ConfigDescriptor -> Bool
configEnableGenericConfig :: ConfigDescriptor -> Bool
configCustomConfig :: CustomConfig
configHasDiagnostics :: Bool
configEnableGenericConfig :: Bool
..}, [PluginCommand a]
Maybe (ParserInfo (IdeCommand a))
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
DynFlagsModifications
pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
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
pluginCli :: Maybe (ParserInfo (IdeCommand a))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers a
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:
        --
        -- {
        --   "codeActionsOn": true,
        --   "codeLensOn": true
        -- }
        --
        genericDefaultConfig :: [Pair]
genericDefaultConfig =
          let x :: [Pair]
x = [Text
"diagnosticsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True | Bool
configHasDiagnostics] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> [Pair]
forall a. Eq a => [a] -> [a]
nub ([[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 case [Pair]
x of
                -- if the plugin has only one capability, we produce globalOn instead of the specific one;
                -- otherwise we don't produce globalOn at all
                [Pair
_] -> [Text
"globalOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
                [Pair]
_   -> [Pair]
x
        -- Example:
        --
        -- {
        --  "config": {
        --      "property1": "foo"
        --   }
        --}
        dedicatedDefaultConfig :: [Pair]
dedicatedDefaultConfig =
          let x :: [Pair]
x = CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig CustomConfig
configCustomConfig
           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 {pluginConfigDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor {Bool
CustomConfig
configCustomConfig :: CustomConfig
configHasDiagnostics :: Bool
configEnableGenericConfig :: Bool
configCustomConfig :: ConfigDescriptor -> CustomConfig
configHasDiagnostics :: ConfigDescriptor -> Bool
configEnableGenericConfig :: ConfigDescriptor -> Bool
..}, [PluginCommand a]
Maybe (ParserInfo (IdeCommand a))
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
DynFlagsModifications
pluginCli :: Maybe (ParserInfo (IdeCommand a))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers a
pluginHandlers :: PluginHandlers a
pluginCommands :: [PluginCommand a]
pluginRules :: Rules ()
pluginId :: PluginId
pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
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 =
          let x :: [Pair]
x =
                [Text -> Text
withIdPrefix Text
"diagnosticsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"diagnostics" | Bool
configHasDiagnostics]
                  [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> [Pair]
forall a. Eq a => [a] -> [a]
nub ([[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))
           in case [Pair]
x of
                -- If the plugin has only one capability, we produce globalOn instead of the specific one;
                -- otherwise we don't produce globalOn at all
                [Pair
_] -> [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]
x
        dedicatedSchema :: [Pair]
dedicatedSchema = CustomConfig -> [Pair]
customConfigToDedicatedSchema CustomConfig
configCustomConfig
        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