{-# 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 Language.LSP.Server              (LspT)

import qualified Language.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 (LspT ServerConfig 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 -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 -> Key -> Parser (Maybe (Maybe CharacterSet))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"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
  }

makeLenses ''ServerState

initialState :: ServerState
initialState :: ServerState
initialState = ServerState :: Cache -> Map Uri DhallError -> Maybe Dynamic -> ServerState
ServerState {Maybe Dynamic
Map Uri DhallError
Cache
forall a. Maybe a
forall k a. Map k a
_httpManager :: forall a. Maybe a
_errors :: forall k a. Map k a
_importCache :: Cache
_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