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

import           Control.Applicative
import           Data.Aeson          hiding (Error)
import qualified Data.Aeson          as A
import qualified Data.Aeson.Types    as A
import           Data.Default
import qualified Data.Map            as Map
import qualified Data.Text           as T
import           GHC.Generics        (Generic)

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

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

-- ---------------------------------------------------------------------
data CheckParents
    -- Note that ordering of constructors is meaningful and must be monotonically
    -- increasing in the scenarios where parents are checked
    = NeverCheck
    | CheckOnSave
    | AlwaysCheck
  deriving stock (CheckParents -> CheckParents -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckParents -> CheckParents -> Bool
$c/= :: CheckParents -> CheckParents -> Bool
== :: CheckParents -> CheckParents -> Bool
$c== :: CheckParents -> CheckParents -> Bool
Eq, Eq CheckParents
CheckParents -> CheckParents -> Bool
CheckParents -> CheckParents -> Ordering
CheckParents -> CheckParents -> CheckParents
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CheckParents -> CheckParents -> CheckParents
$cmin :: CheckParents -> CheckParents -> CheckParents
max :: CheckParents -> CheckParents -> CheckParents
$cmax :: CheckParents -> CheckParents -> CheckParents
>= :: CheckParents -> CheckParents -> Bool
$c>= :: CheckParents -> CheckParents -> Bool
> :: CheckParents -> CheckParents -> Bool
$c> :: CheckParents -> CheckParents -> Bool
<= :: CheckParents -> CheckParents -> Bool
$c<= :: CheckParents -> CheckParents -> Bool
< :: CheckParents -> CheckParents -> Bool
$c< :: CheckParents -> CheckParents -> Bool
compare :: CheckParents -> CheckParents -> Ordering
$ccompare :: CheckParents -> CheckParents -> Ordering
Ord, Int -> CheckParents -> ShowS
[CheckParents] -> ShowS
CheckParents -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckParents] -> ShowS
$cshowList :: [CheckParents] -> ShowS
show :: CheckParents -> String
$cshow :: CheckParents -> String
showsPrec :: Int -> CheckParents -> ShowS
$cshowsPrec :: Int -> CheckParents -> ShowS
Show, forall x. Rep CheckParents x -> CheckParents
forall x. CheckParents -> Rep CheckParents x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckParents x -> CheckParents
$cfrom :: forall x. CheckParents -> Rep CheckParents x
Generic)
  deriving anyclass (Value -> Parser [CheckParents]
Value -> Parser CheckParents
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckParents]
$cparseJSONList :: Value -> Parser [CheckParents]
parseJSON :: Value -> Parser CheckParents
$cparseJSON :: Value -> Parser CheckParents
FromJSON, [CheckParents] -> Encoding
[CheckParents] -> Value
CheckParents -> Encoding
CheckParents -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckParents] -> Encoding
$ctoEncodingList :: [CheckParents] -> Encoding
toJSONList :: [CheckParents] -> Value
$ctoJSONList :: [CheckParents] -> Value
toEncoding :: CheckParents -> Encoding
$ctoEncoding :: CheckParents -> Encoding
toJSON :: CheckParents -> Value
$ctoJSON :: CheckParents -> Value
ToJSON)

-- | We (initially anyway) mirror the hie configuration, so that existing
-- clients can simply switch executable and not have any nasty surprises.  There
-- will be surprises relating to config options being ignored, initially though.
data Config =
  Config
    { Config -> CheckParents
checkParents       :: CheckParents
    , Config -> Bool
checkProject       :: !Bool
    , Config -> Text
formattingProvider :: !T.Text
    , Config -> Int
maxCompletions     :: !Int
    , Config -> Map Text PluginConfig
plugins            :: !(Map.Map T.Text PluginConfig)
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show,Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq)

instance Default Config where
  def :: Config
def = Config
    { checkParents :: CheckParents
checkParents                = CheckParents
CheckOnSave
    , checkProject :: Bool
checkProject                = Bool
True
    -- , formattingProvider          = "brittany"
    , formattingProvider :: Text
formattingProvider          = Text
"ormolu"
    -- , formattingProvider          = "floskell"
    -- , formattingProvider          = "stylish-haskell"
    , maxCompletions :: Int
maxCompletions              = Int
40
    , plugins :: Map Text PluginConfig
plugins                     = forall k a. Map k a
Map.empty
    }

-- TODO: Add API for plugins to expose their own LSP config options
parseConfig :: Config -> Value -> A.Parser Config
parseConfig :: Config -> Value -> Parser Config
parseConfig Config
defValue = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Config" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    -- Officially, we use "haskell" as the section name but for
    -- backwards compatibility we also accept "languageServerHaskell"
    Maybe Value
c <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"haskell" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"languageServerHaskell"
    case Maybe Value
c of
      Maybe Value
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Config
defValue
      Just Value
s -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Config.settings") Value
s forall a b. (a -> b) -> a -> b
$ \Object
o -> CheckParents
-> Bool -> Text -> Int -> Map Text PluginConfig -> Config
Config
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"checkParents" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"checkParents") forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> CheckParents
checkParents Config
defValue
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"checkProject" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"checkProject") forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
checkProject Config
defValue
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"formattingProvider"                      forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Text
formattingProvider Config
defValue
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"maxCompletions"                          forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Int
maxCompletions Config
defValue
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"plugin"                                  forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Map Text PluginConfig
plugins Config
defValue

instance A.ToJSON Config where
  toJSON :: Config -> Value
toJSON Config{Bool
Int
Text
Map Text PluginConfig
CheckParents
plugins :: Map Text PluginConfig
maxCompletions :: Int
formattingProvider :: Text
checkProject :: Bool
checkParents :: CheckParents
plugins :: Config -> Map Text PluginConfig
maxCompletions :: Config -> Int
formattingProvider :: Config -> Text
checkProject :: Config -> Bool
checkParents :: Config -> CheckParents
..} =
      [Pair] -> Value
object [ Key
"haskell" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
r ]
    where
      r :: Value
r = [Pair] -> Value
object [ Key
"checkParents"                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CheckParents
checkParents
                 , Key
"checkProject"                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
checkProject
                 , Key
"formattingProvider"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
formattingProvider
                 , Key
"maxCompletions"              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
maxCompletions
                 , Key
"plugin"                      forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Map Text PluginConfig
plugins
                 ]

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

-- | A PluginConfig is a generic configuration for a given HLS plugin.  It
-- provides a "big switch" to turn it on or off as a whole, as well as small
-- switches per feature, and a slot for custom config.
-- This provides a regular naming scheme for all plugin config.
data PluginConfig =
    PluginConfig
      { PluginConfig -> Bool
plcGlobalOn         :: !Bool
      , PluginConfig -> Bool
plcCallHierarchyOn  :: !Bool
      , PluginConfig -> Bool
plcCodeActionsOn    :: !Bool
      , PluginConfig -> Bool
plcCodeLensOn       :: !Bool
      , PluginConfig -> Bool
plcDiagnosticsOn    :: !Bool
      , PluginConfig -> Bool
plcHoverOn          :: !Bool
      , PluginConfig -> Bool
plcSymbolsOn        :: !Bool
      , PluginConfig -> Bool
plcCompletionOn     :: !Bool
      , PluginConfig -> Bool
plcRenameOn         :: !Bool
      , PluginConfig -> Bool
plcSelectionRangeOn :: !Bool
      , PluginConfig -> Object
plcConfig           :: !A.Object
      } deriving (Int -> PluginConfig -> ShowS
[PluginConfig] -> ShowS
PluginConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PluginConfig] -> ShowS
$cshowList :: [PluginConfig] -> ShowS
show :: PluginConfig -> String
$cshow :: PluginConfig -> String
showsPrec :: Int -> PluginConfig -> ShowS
$cshowsPrec :: Int -> PluginConfig -> ShowS
Show,PluginConfig -> PluginConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PluginConfig -> PluginConfig -> Bool
$c/= :: PluginConfig -> PluginConfig -> Bool
== :: PluginConfig -> PluginConfig -> Bool
$c== :: PluginConfig -> PluginConfig -> Bool
Eq)

instance Default PluginConfig where
  def :: PluginConfig
def = PluginConfig
      { plcGlobalOn :: Bool
plcGlobalOn         = Bool
True
      , plcCallHierarchyOn :: Bool
plcCallHierarchyOn  = Bool
True
      , plcCodeActionsOn :: Bool
plcCodeActionsOn    = Bool
True
      , plcCodeLensOn :: Bool
plcCodeLensOn       = Bool
True
      , plcDiagnosticsOn :: Bool
plcDiagnosticsOn    = Bool
True
      , plcHoverOn :: Bool
plcHoverOn          = Bool
True
      , plcSymbolsOn :: Bool
plcSymbolsOn        = Bool
True
      , plcCompletionOn :: Bool
plcCompletionOn     = Bool
True
      , plcRenameOn :: Bool
plcRenameOn         = Bool
True
      , plcSelectionRangeOn :: Bool
plcSelectionRangeOn = Bool
True
      , plcConfig :: Object
plcConfig           = forall a. Monoid a => a
mempty
      }

instance A.ToJSON PluginConfig where
    toJSON :: PluginConfig -> Value
toJSON (PluginConfig Bool
g Bool
ch Bool
ca Bool
cl Bool
d Bool
h Bool
s Bool
c Bool
rn Bool
sr Object
cfg) = Value
r
      where
        r :: Value
r = [Pair] -> Value
object [ Key
"globalOn"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
g
                   , Key
"callHierarchyOn"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
ch
                   , Key
"codeActionsOn"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
ca
                   , Key
"codeLensOn"       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
cl
                   , Key
"diagnosticsOn"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
d
                   , Key
"hoverOn"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
h
                   , Key
"symbolsOn"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
s
                   , Key
"completionOn"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
c
                   , Key
"renameOn"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
rn
                   , Key
"selectionRangeOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
sr
                   , Key
"config"           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object
cfg
                   ]

instance A.FromJSON PluginConfig where
  parseJSON :: Value -> Parser PluginConfig
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"PluginConfig" forall a b. (a -> b) -> a -> b
$ \Object
o  -> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Object
-> PluginConfig
PluginConfig
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"globalOn"         forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcGlobalOn forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"callHierarchyOn"  forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcCallHierarchyOn forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"codeActionsOn"    forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcCodeActionsOn forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"codeLensOn"       forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcCodeLensOn    forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"diagnosticsOn"    forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcDiagnosticsOn forall a. Default a => a
def -- AZ
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"hoverOn"          forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcHoverOn       forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"symbolsOn"        forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcSymbolsOn     forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"completionOn"     forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcCompletionOn  forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"renameOn"         forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcRenameOn      forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"selectionRangeOn" forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Bool
plcSelectionRangeOn forall a. Default a => a
def
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"config"           forall a. Parser (Maybe a) -> a -> Parser a
.!= PluginConfig -> Object
plcConfig        forall a. Default a => a
def

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