{-# 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


-- 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
  { 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 }

-- We need to derive the FromJSON instance manually in order to provide defaults
-- for absent fields.
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  -- ^ The dhall import cache
  , ServerState -> Map Uri DhallError
_errors :: Map J.Uri DhallError  -- ^ Map from dhall files to their errors
  , ServerState -> Maybe Dynamic
_httpManager :: Maybe Dynamic
  -- ^ The http manager used by dhall's import infrastructure
  , ServerState -> LspFuncs ServerConfig
_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 :: 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