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

module Ide.Plugin.ConfigUtils where

import           Control.Lens          (at, ix, (&), (?~))
import qualified Data.Aeson            as A
import           Data.Aeson.Lens       (_Object)
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           Data.List             (nub)
import           Data.String           (IsString (fromString))
import qualified Data.Text             as T
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 :: forall a. IdePlugins a -> Value
pluginsToDefaultConfig IdePlugins {[PluginDescriptor a]
ipMap :: forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap :: [PluginDescriptor a]
..} =
  -- Use 'ix' to look at all the "haskell" keys in the outer value (since we're not
  -- setting it if missing), then we use '_Object' and 'at' to get at the "plugin" key
  -- and actually set it.
  forall a. ToJSON a => a -> Value
A.toJSON Config
defaultConfig forall a b. a -> (a -> b) -> b
& forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
"haskell" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t (KeyMap Value)
_Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Key
"plugin" forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
elems
  where
    defaultConfig :: Config
defaultConfig@Config {} = forall a. Default a => a
def
    elems :: Value
elems = [Pair] -> Value
A.object forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall {a} {ideState}.
KeyValue a =>
PluginDescriptor ideState -> [a]
singlePlugin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PluginDescriptor a]
ipMap
    -- Splice genericDefaultConfig and dedicatedDefaultConfig
    -- Example:
    --
    -- {
    --  "plugin-id": {
    --    "globalOn": true,
    --    "codeActionsOn": true,
    --    "codeLensOn": true,
    --    "config": {
    --      "property1": "foo"
    --     }
    --   }
    -- }
    singlePlugin :: PluginDescriptor ideState -> [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
..}, Natural
[Text]
[PluginCommand ideState]
Maybe (ParserInfo (IdeCommand ideState))
Rules ()
PluginId
PluginNotificationHandlers ideState
PluginHandlers ideState
DynFlagsModifications
pluginFileType :: forall ideState. PluginDescriptor ideState -> [Text]
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 ()
pluginPriority :: forall ideState. PluginDescriptor ideState -> Natural
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
pluginFileType :: [Text]
pluginCli :: Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers ideState
pluginHandlers :: PluginHandlers ideState
pluginCommands :: [PluginCommand ideState]
pluginRules :: Rules ()
pluginPriority :: Natural
pluginId :: PluginId
..} =
      let x :: [Pair]
x = [Pair]
genericDefaultConfig forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedDefaultConfig
       in [forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
pId) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x]
      where
        (PluginHandlers (forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler ideState)]
handlers)) = PluginHandlers ideState
pluginHandlers
        customConfigToDedicatedDefaultConfig :: CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig (CustomConfig Properties r
p) = forall (r :: [PropertyKey]). Properties r -> [Pair]
toDefaultJSON Properties r
p
        -- Example:
        --
        -- {
        --   "codeActionsOn": true,
        --   "codeLensOn": true
        -- }
        --
        genericDefaultConfig :: [Pair]
genericDefaultConfig =
          let x :: [Pair]
x = [Key
"diagnosticsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True | Bool
configHasDiagnostics] forall a. Semigroup a => a -> a -> a
<> forall a. Eq a => [a] -> [a]
nub (forall a. Monoid a => [a] -> a
mconcat (forall (f :: Method 'FromClient 'Request -> *).
DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler ideState)]
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
_] -> [Key
"globalOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> 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 [Key
"config" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 :: forall (f :: Method 'FromClient 'Request -> *).
DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig (IdeMethod SMethod a
m DSum.:=> f a
_) = case SMethod a
m of
          SMethod a
STextDocumentCodeAction           -> [Key
"codeActionsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentCodeLens             -> [Key
"codeLensOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentRename               -> [Key
"renameOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentHover                -> [Key
"hoverOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentDocumentSymbol       -> [Key
"symbolsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentCompletion           -> [Key
"completionOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True]
          SMethod a
STextDocumentPrepareCallHierarchy -> [Key
"callHierarchyOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> 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 :: forall a. IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins {[PluginDescriptor a]
ipMap :: [PluginDescriptor a]
ipMap :: forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
..} = [Pair] -> Value
A.object forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall {ideState}. PluginDescriptor ideState -> [Pair]
singlePlugin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PluginDescriptor a]
ipMap
  where
    singlePlugin :: PluginDescriptor ideState -> [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
..}, Natural
[Text]
[PluginCommand ideState]
Maybe (ParserInfo (IdeCommand ideState))
Rules ()
PluginId
PluginNotificationHandlers ideState
PluginHandlers ideState
DynFlagsModifications
pluginFileType :: [Text]
pluginCli :: Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers ideState
pluginHandlers :: PluginHandlers ideState
pluginCommands :: [PluginCommand ideState]
pluginRules :: Rules ()
pluginPriority :: Natural
pluginId :: PluginId
pluginFileType :: forall ideState. PluginDescriptor ideState -> [Text]
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 ()
pluginPriority :: forall ideState. PluginDescriptor ideState -> Natural
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
..} = [Pair]
genericSchema forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedSchema
      where
        (PluginHandlers (forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler ideState)]
handlers)) = PluginHandlers ideState
pluginHandlers
        customConfigToDedicatedSchema :: CustomConfig -> [Pair]
customConfigToDedicatedSchema (CustomConfig Properties r
p) = 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 -> Key
toKey' Text
"diagnosticsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"diagnostics" | Bool
configHasDiagnostics]
                  forall a. Semigroup a => a -> a -> a
<> forall a. Eq a => [a] -> [a]
nub (forall a. Monoid a => [a] -> a
mconcat (DSum IdeMethod (PluginHandler ideState) -> [Pair]
handlersToGenericSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler ideState)]
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 -> Key
toKey' Text
"globalOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"plugin"]
                [Pair]
_   -> [Pair]
x
        dedicatedSchema :: [Pair]
dedicatedSchema = CustomConfig -> [Pair]
customConfigToDedicatedSchema CustomConfig
configCustomConfig
        handlersToGenericSchema :: DSum IdeMethod (PluginHandler ideState) -> [Pair]
handlersToGenericSchema (IdeMethod SMethod a
m DSum.:=> PluginHandler ideState a
_) = case SMethod a
m of
          SMethod a
STextDocumentCodeAction -> [Text -> Key
toKey' Text
"codeActionsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"code actions"]
          SMethod a
STextDocumentCodeLens -> [Text -> Key
toKey' Text
"codeLensOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"code lenses"]
          SMethod a
STextDocumentRename -> [Text -> Key
toKey' Text
"renameOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"rename"]
          SMethod a
STextDocumentHover -> [Text -> Key
toKey' Text
"hoverOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"hover"]
          SMethod a
STextDocumentDocumentSymbol -> [Text -> Key
toKey' Text
"symbolsOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"symbols"]
          SMethod a
STextDocumentCompletion -> [Text -> Key
toKey' Text
"completionOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"completions"]
          SMethod a
STextDocumentPrepareCallHierarchy -> [Text -> Key
toKey' Text
"callHierarchyOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
schemaEntry Text
"call hierarchy"]
          SMethod a
_ -> []
        schemaEntry :: Text -> Value
schemaEntry Text
desc =
          [Pair] -> Value
A.object
            [ Key
"scope" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
A.String Text
"resource",
              Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
A.String Text
"boolean",
              Key
"default" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
True,
              Key
"description" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
A.String (Text
"Enables " forall a. Semigroup a => a -> a -> a
<> Text
pId forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
desc)
            ]
        withIdPrefix :: Text -> Text
withIdPrefix Text
x = Text
"haskell.plugin." forall a. Semigroup a => a -> a -> a
<> Text
pId forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
x
        toKey' :: Text -> Key
toKey' = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
withIdPrefix