Config.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ViewPatterns       #-}
module Ide.Plugin.Config
    ( getConfigFromNotification
    , Config(..)
    , parseConfig
    , PluginConfig(..)
    , CheckParents(..)
    ) where

import           Control.Applicative
import           Control.Lens        (preview)
import           Data.Aeson          hiding (Error)
import qualified Data.Aeson          as A
import           Data.Aeson.Lens     (_String)
import qualified Data.Aeson.Types    as A
import           Data.Default
import qualified Data.Map.Strict     as Map
import           Data.Maybe          (fromMaybe)
import qualified Data.Text           as T
import           GHC.Exts            (toList)
import           Ide.Types

-- ---------------------------------------------------------------------

-- | Given a DidChangeConfigurationNotification message, this function returns the parsed
-- Config object if possible.
getConfigFromNotification :: IdePlugins s -> Config -> A.Value -> Either T.Text Config
getConfigFromNotification plugins defaultValue p =
  case A.parse (parseConfig plugins defaultValue) p of
    A.Success c -> Right c
    A.Error err -> Left $ T.pack err

-- ---------------------------------------------------------------------

parseConfig :: IdePlugins s -> Config -> Value -> A.Parser Config
parseConfig idePlugins defValue = A.withObject "Config" $ \v -> do
    -- Officially, we use "haskell" as the section name but for
    -- backwards compatibility we also accept "languageServerHaskell"
    c <- v .: "haskell" <|> v .:? "languageServerHaskell"
    case c of
      Nothing -> return defValue
      Just s -> flip (A.withObject "Config.settings") s $ \o -> Config
        <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue
        <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue
        <*> o .:? "formattingProvider"                      .!= formattingProvider defValue
        <*> o .:? "cabalFormattingProvider"                 .!= cabalFormattingProvider defValue
        <*> o .:? "maxCompletions"                          .!= maxCompletions defValue
        <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue

-- | Parse the 'PluginConfig'.
--   Since we need to fall back to default values if we do not find one in the input,
--   we need the map of plugin-provided defaults, as in 'parseConfig'.
parsePlugins :: IdePlugins s -> Value -> A.Parser (Map.Map PluginId PluginConfig)
parsePlugins (IdePlugins plugins) = A.withObject "Config.plugins" $ \o -> do
  let -- parseOne :: Key -> Value -> A.Parser (T.Text, PluginConfig)
      parseOne (fmap PluginId . preview _String . toJSON -> Just pId) pConfig = do
        let defPluginConfig = fromMaybe def $ lookup pId defValue
        pConfig' <- parsePluginConfig defPluginConfig pConfig
        return (pId, pConfig')
      parseOne _ _ = fail "Expected plugin id to be a string"
      defValue = map (\p -> (pluginId p, configInitialGenericConfig (pluginConfigDescriptor p))) plugins
  plugins <- mapM (uncurry parseOne) (toList o)
  return $ Map.fromList plugins

-- ---------------------------------------------------------------------

parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig
parsePluginConfig def = A.withObject "PluginConfig" $ \o  -> PluginConfig
      <$> o .:? "globalOn"         .!= plcGlobalOn def
      <*> o .:? "callHierarchyOn"  .!= plcCallHierarchyOn def
      <*> o .:? "codeActionsOn"    .!= plcCodeActionsOn def
      <*> o .:? "codeLensOn"       .!= plcCodeLensOn    def
      <*> o .:? "diagnosticsOn"    .!= plcDiagnosticsOn def -- AZ
      <*> o .:? "hoverOn"          .!= plcHoverOn       def
      <*> o .:? "symbolsOn"        .!= plcSymbolsOn     def
      <*> o .:? "completionOn"     .!= plcCompletionOn  def
      <*> o .:? "renameOn"         .!= plcRenameOn      def
      <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def
      <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def
      <*> o .:? "config"           .!= plcConfig        def

-- ---------------------------------------------------------------------