{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Dhall.LSP.State where
import Control.Lens.TH (makeLenses)
import Control.Lens.Type (LensLike')
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.State.Strict (StateT)
import Data.Aeson
( FromJSON (..)
, withObject
, (.!=)
, (.:)
, (.:?)
)
import Data.Default (Default(def))
import Data.Dynamic (Dynamic)
import Data.Map.Strict (Map, empty)
import Data.Text (Text)
import Dhall.LSP.Backend.Dhall (Cache, DhallError, emptyCache)
import Dhall.Pretty (CharacterSet)
import qualified Language.Haskell.LSP.Core as LSP
import qualified Language.Haskell.LSP.Messages as LSP
import qualified Language.Haskell.LSP.Types as J
type HandlerM = ExceptT (Severity, Text) (StateT ServerState IO)
data Severity = Error
| Warning
| Info
| Log
data ServerConfig = ServerConfig
{ ServerConfig -> Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
} deriving Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
(Int -> ServerConfig -> ShowS)
-> (ServerConfig -> String)
-> ([ServerConfig] -> ShowS)
-> Show ServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerConfig] -> ShowS
$cshowList :: [ServerConfig] -> ShowS
show :: ServerConfig -> String
$cshow :: ServerConfig -> String
showsPrec :: Int -> ServerConfig -> ShowS
$cshowsPrec :: Int -> ServerConfig -> ShowS
Show
instance Default ServerConfig where
def :: ServerConfig
def = ServerConfig :: Maybe CharacterSet -> ServerConfig
ServerConfig { chosenCharacterSet :: Maybe CharacterSet
chosenCharacterSet = Maybe CharacterSet
forall a. Maybe a
Nothing }
instance FromJSON ServerConfig where
parseJSON :: Value -> Parser ServerConfig
parseJSON = String
-> (Object -> Parser ServerConfig) -> Value -> Parser ServerConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"settings" ((Object -> Parser ServerConfig) -> Value -> Parser ServerConfig)
-> (Object -> Parser ServerConfig) -> Value -> Parser ServerConfig
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
Value
s <- Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"vscode-dhall-lsp-server"
((Object -> Parser ServerConfig) -> Value -> Parser ServerConfig)
-> Value -> (Object -> Parser ServerConfig) -> Parser ServerConfig
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser ServerConfig) -> Value -> Parser ServerConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"vscode-dhall-lsp-server") Value
s ((Object -> Parser ServerConfig) -> Parser ServerConfig)
-> (Object -> Parser ServerConfig) -> Parser ServerConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> Maybe CharacterSet -> ServerConfig
ServerConfig
(Maybe CharacterSet -> ServerConfig)
-> Parser (Maybe CharacterSet) -> Parser ServerConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe (Maybe CharacterSet))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"character-set" Parser (Maybe (Maybe CharacterSet))
-> Maybe CharacterSet -> Parser (Maybe CharacterSet)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Maybe CharacterSet
forall a. Maybe a
Nothing
data ServerState = ServerState
{ ServerState -> Cache
_importCache :: Cache
, ServerState -> Map Uri DhallError
_errors :: Map J.Uri DhallError
, ServerState -> Maybe Dynamic
_httpManager :: Maybe Dynamic
, ServerState -> LspFuncs ServerConfig
_lspFuncs :: LSP.LspFuncs ServerConfig
}
makeLenses ''ServerState
sendFunc :: Functor f =>
LensLike' f (LSP.LspFuncs ServerConfig) (LSP.FromServerMessage -> IO ())
sendFunc :: LensLike' f (LspFuncs ServerConfig) (FromServerMessage -> IO ())
sendFunc (FromServerMessage -> IO ()) -> f (FromServerMessage -> IO ())
k LspFuncs ServerConfig
s = ((FromServerMessage -> IO ()) -> LspFuncs ServerConfig)
-> f (FromServerMessage -> IO ()) -> f (LspFuncs ServerConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FromServerMessage -> IO ()
x -> LspFuncs ServerConfig
s {sendFunc :: FromServerMessage -> IO ()
LSP.sendFunc = FromServerMessage -> IO ()
x}) ((FromServerMessage -> IO ()) -> f (FromServerMessage -> IO ())
k (LspFuncs ServerConfig -> FromServerMessage -> IO ()
forall c. LspFuncs c -> FromServerMessage -> IO ()
LSP.sendFunc LspFuncs ServerConfig
s))
initialState :: LSP.LspFuncs ServerConfig -> ServerState
initialState :: LspFuncs ServerConfig -> ServerState
initialState LspFuncs ServerConfig
lsp = ServerState :: Cache
-> Map Uri DhallError
-> Maybe Dynamic
-> LspFuncs ServerConfig
-> ServerState
ServerState {Maybe Dynamic
Map Uri DhallError
LspFuncs ServerConfig
Cache
forall a. Maybe a
forall k a. Map k a
_lspFuncs :: LspFuncs ServerConfig
_httpManager :: forall a. Maybe a
_errors :: forall k a. Map k a
_importCache :: Cache
_lspFuncs :: LspFuncs ServerConfig
_httpManager :: Maybe Dynamic
_errors :: Map Uri DhallError
_importCache :: Cache
..}
where
_importCache :: Cache
_importCache = Cache
emptyCache
_errors :: Map k a
_errors = Map k a
forall k a. Map k a
empty
_httpManager :: Maybe a
_httpManager = Maybe a
forall a. Maybe a
Nothing
_lspFuncs :: LspFuncs ServerConfig
_lspFuncs = LspFuncs ServerConfig
lsp