{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Dhall.LSP.State where
import Control.Lens.TH (makeLenses)
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 Lens.Family (LensLike')
import qualified Language.Haskell.LSP.Core as LSP
import qualified Language.Haskell.LSP.Messages as LSP
import qualified Language.Haskell.LSP.Types as J
-- Inside a handler we have access to the ServerState. The exception layer
-- allows us to fail gracefully, displaying a message to the user via the
-- "ShowMessage" mechanism of the lsp standard.
type HandlerM = ExceptT (Severity, Text) (StateT ServerState IO)
data Severity = Error
-- ^ Error displayed to the user.
| Warning
-- ^ Warning displayed to the user.
| Info
-- ^ Information displayed to the user.
| Log
-- ^ Log message, not displayed by default.
data ServerConfig = ServerConfig
{ chosenCharacterSet :: Maybe CharacterSet
} deriving Show
instance Default ServerConfig where
def = ServerConfig { chosenCharacterSet = Nothing }
-- We need to derive the FromJSON instance manually in order to provide defaults
-- for absent fields.
instance FromJSON ServerConfig where
parseJSON = withObject "settings" $ \v -> do
s <- v .: "vscode-dhall-lsp-server"
flip (withObject "vscode-dhall-lsp-server") s $ \o -> ServerConfig
<$> o .:? "character-set" .!= Nothing
data ServerState = ServerState
{ _importCache :: Cache -- ^ The dhall import cache
, _errors :: Map J.Uri DhallError -- ^ Map from dhall files to their errors
, _httpManager :: Maybe Dynamic
-- ^ The http manager used by dhall's import infrastructure
, _lspFuncs :: LSP.LspFuncs ServerConfig
-- ^ Access to the lsp functions supplied by haskell-lsp
}
makeLenses ''ServerState
sendFunc :: Functor f =>
LensLike' f (LSP.LspFuncs ServerConfig) (LSP.FromServerMessage -> IO ())
sendFunc k s = fmap (\x -> s {LSP.sendFunc = x}) (k (LSP.sendFunc s))
initialState :: LSP.LspFuncs ServerConfig -> ServerState
initialState lsp = ServerState {..}
where
_importCache = emptyCache
_errors = empty
_httpManager = Nothing
_lspFuncs = lsp