{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Ide.Plugin.Config
    (
      getInitialConfig
    , getConfigFromNotification
    , Config(..)
    ) where

import           Control.Applicative
import qualified Data.Aeson                    as A
import           Data.Aeson              hiding ( Error )
import           Data.Default
import qualified Data.Text                     as T
import           Language.Haskell.LSP.Types

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


-- | Given a DidChangeConfigurationNotification message, this function returns the parsed

-- Config object if possible.

getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config
getConfigFromNotification :: DidChangeConfigurationNotification -> Either Text Config
getConfigFromNotification (NotificationMessage Text
_ ClientMethod
_ (DidChangeConfigurationParams Value
p)) =
  case Value -> Result Config
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
    A.Success Config
c -> Config -> Either Text Config
forall a b. b -> Either a b
Right Config
c
    A.Error String
err -> Text -> Either Text Config
forall a b. a -> Either a b
Left (Text -> Either Text Config) -> Text -> Either Text Config
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err

-- | Given an InitializeRequest message, this function returns the parsed

-- Config object if possible. Otherwise, it returns the default configuration

getInitialConfig :: InitializeRequest -> Either T.Text Config
getInitialConfig :: InitializeRequest -> Either Text Config
getInitialConfig (RequestMessage Text
_ LspId
_ ClientMethod
_ InitializeParams{$sel:_initializationOptions:InitializeParams :: InitializeParams -> Maybe Value
_initializationOptions = Maybe Value
Nothing }) = Config -> Either Text Config
forall a b. b -> Either a b
Right Config
forall a. Default a => a
def
getInitialConfig (RequestMessage Text
_ LspId
_ ClientMethod
_ InitializeParams{$sel:_initializationOptions:InitializeParams :: InitializeParams -> Maybe Value
_initializationOptions = Just Value
opts}) =
  case Value -> Result Config
forall a. FromJSON a => Value -> Result a
fromJSON Value
opts of
    A.Success Config
c -> Config -> Either Text Config
forall a b. b -> Either a b
Right Config
c
    A.Error String
err -> Text -> Either Text Config
forall a b. a -> Either a b
Left (Text -> Either Text Config) -> Text -> Either Text Config
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err

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


-- | 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 -> Bool
hlintOn                     :: Bool
    , Config -> Bool
diagnosticsOnChange         :: Bool
    , Config -> Int
maxNumberOfProblems         :: Int
    , Config -> Int
diagnosticsDebounceDuration :: Int
    , Config -> Bool
liquidOn                    :: Bool
    , Config -> Bool
completionSnippetsOn        :: Bool
    , Config -> Bool
formatOnImportOn            :: Bool
    , Config -> Text
formattingProvider          :: T.Text
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
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 :: Bool
-> Bool -> Int -> Int -> Bool -> Bool -> Bool -> Text -> Config
Config
    { hlintOn :: Bool
hlintOn                     = Bool
True
    , diagnosticsOnChange :: Bool
diagnosticsOnChange         = Bool
True
    , maxNumberOfProblems :: Int
maxNumberOfProblems         = Int
100
    , diagnosticsDebounceDuration :: Int
diagnosticsDebounceDuration = Int
350000
    , liquidOn :: Bool
liquidOn                    = Bool
False
    , completionSnippetsOn :: Bool
completionSnippetsOn        = Bool
True
    , formatOnImportOn :: Bool
formatOnImportOn            = Bool
True
    -- , formattingProvider          = "brittany"

    , formattingProvider :: Text
formattingProvider          = Text
"ormolu"
    -- , formattingProvider          = "floskell"

    -- , formattingProvider          = "stylish-haskell"

    }

-- TODO: Add API for plugins to expose their own LSP config options

instance A.FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON = String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Config" ((Object -> Parser Config) -> Value -> Parser Config)
-> (Object -> Parser Config) -> Value -> Parser 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"

    Value
s <- Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"haskell" Parser Value -> Parser Value -> Parser Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"languageServerHaskell"
    ((Object -> Parser Config) -> Value -> Parser Config)
-> Value -> (Object -> Parser Config) -> Parser Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Config.settings") Value
s ((Object -> Parser Config) -> Parser Config)
-> (Object -> Parser Config) -> Parser Config
forall a b. (a -> b) -> a -> b
$ \Object
o -> Bool
-> Bool -> Int -> Int -> Bool -> Bool -> Bool -> Text -> Config
Config
      (Bool
 -> Bool -> Int -> Int -> Bool -> Bool -> Bool -> Text -> Config)
-> Parser Bool
-> Parser
     (Bool -> Int -> Int -> Bool -> Bool -> Bool -> Text -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"hlintOn"                     Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
hlintOn Config
forall a. Default a => a
def
      Parser
  (Bool -> Int -> Int -> Bool -> Bool -> Bool -> Text -> Config)
-> Parser Bool
-> Parser (Int -> Int -> Bool -> Bool -> Bool -> Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"diagnosticsOnChange"         Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
diagnosticsOnChange Config
forall a. Default a => a
def
      Parser (Int -> Int -> Bool -> Bool -> Bool -> Text -> Config)
-> Parser Int
-> Parser (Int -> Bool -> Bool -> Bool -> Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"maxNumberOfProblems"         Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Int
maxNumberOfProblems Config
forall a. Default a => a
def
      Parser (Int -> Bool -> Bool -> Bool -> Text -> Config)
-> Parser Int -> Parser (Bool -> Bool -> Bool -> Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"diagnosticsDebounceDuration" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Int
diagnosticsDebounceDuration Config
forall a. Default a => a
def
      Parser (Bool -> Bool -> Bool -> Text -> Config)
-> Parser Bool -> Parser (Bool -> Bool -> Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"liquidOn"                    Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
liquidOn Config
forall a. Default a => a
def
      Parser (Bool -> Bool -> Text -> Config)
-> Parser Bool -> Parser (Bool -> Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"completionSnippetsOn"        Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
completionSnippetsOn Config
forall a. Default a => a
def
      Parser (Bool -> Text -> Config)
-> Parser Bool -> Parser (Text -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"formatOnImportOn"            Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Bool
formatOnImportOn Config
forall a. Default a => a
def
      Parser (Text -> Config) -> Parser Text -> Parser Config
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"formattingProvider"          Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Config -> Text
formattingProvider Config
forall a. Default a => a
def

-- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}}

-- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification:

-- NotificationMessage

--   {_jsonrpc = "2.0"

--   , _method = WorkspaceDidChangeConfiguration

--   , _params = DidChangeConfigurationParams

--                 {_settings = Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True)

--                                                                            ,("maxNumberOfProblems",Number 100.0)]))])}}


instance A.ToJSON Config where
  toJSON :: Config -> Value
toJSON (Config Bool
h Bool
diag Int
m Int
d Bool
l Bool
c Bool
f Text
fp) = [Pair] -> Value
object [ Text
"haskell" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
r ]
    where
      r :: Value
r = [Pair] -> Value
object [ Text
"hlintOn"                     Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
h
                 , Text
"diagnosticsOnChange"         Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
diag
                 , Text
"maxNumberOfProblems"         Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
m
                 , Text
"diagnosticsDebounceDuration" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
d
                 , Text
"liquidOn"                    Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
l
                 , Text
"completionSnippetsOn"        Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
c
                 , Text
"formatOnImportOn"            Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
f
                 , Text
"formattingProvider"          Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
fp
                 ]