dhall-lsp-server: Add option to only use ASCII when formatting and linting (#1533)

* Add config support

The config so far consists of a single `asciiOnly` flag (whose intended
behaviour is not yet implemented).

* Implement 'ascii-only' option when formatting and linting

This commit adds functionality to the 'asciiOnly' flag, i.e. when turned
on we don't output fancy non-ascii characters. Needs a recent version of
the client to function -- the version on the marketplace does not relay
configuration data to the server yet!

Author: EggBaconAndSpam

dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs

@@ -2,7 +2,7 @@ module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where
 
 import Dhall.Core (Expr)
 import Dhall.Parser (Header(..))
-import Dhall.Pretty (CharacterSet(..), prettyCharacterSet)
+import Dhall.Pretty (CharacterSet, prettyCharacterSet)
 import qualified Dhall.Pretty
 import Dhall.Src (Src)
 
@@ -12,17 +12,18 @@ import qualified Data.Text.Prettyprint.Doc                 as Pretty
 import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty
 
 -- | Pretty-print the given Dhall expression.
-formatExpr :: Pretty.Pretty b => Expr Src b -> Text
-formatExpr expr = formatExprWithHeader expr (Header "")
+formatExpr :: Pretty.Pretty b => CharacterSet -> Expr Src b -> Text
+formatExpr charSet expr = Pretty.renderStrict . Dhall.Pretty.layout
+                          . Pretty.unAnnotate $ prettyCharacterSet charSet expr
 
 -- | Pretty-print the given Dhall expression, prepending the given a "header"
 --   (usually consisting of comments and whitespace).
-formatExprWithHeader :: Pretty.Pretty b => Expr Src b -> Header -> Text
-formatExprWithHeader expr (Header header) = Pretty.renderStrict
+formatExprWithHeader :: Pretty.Pretty b => CharacterSet -> Expr Src b -> Header -> Text
+formatExprWithHeader charSet expr (Header header) = Pretty.renderStrict
   (Dhall.Pretty.layout doc)
   where
     doc =
       Pretty.pretty header
-        <> Pretty.unAnnotate (prettyCharacterSet Unicode expr)
+        <> Pretty.unAnnotate (prettyCharacterSet charSet expr)
         <> "\n"
 

dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs

@@ -1,13 +1,11 @@
 module Dhall.LSP.Backend.Typing (annotateLet, exprAt, srcAt, typeAt) where
 
 import Dhall.Context (Context, insert, empty)
-import Dhall.Core (Binding(..), Expr(..), subExpressions, normalize, shift, subst, Var(..), pretty)
+import Dhall.Core (Binding(..), Expr(..), subExpressions, normalize, shift, subst, Var(..))
 import Dhall.TypeCheck (typeWithA, TypeError(..))
 import Dhall.Parser (Src(..))
 
-import Data.Monoid ((<>))
 import Control.Lens (toListOf)
-import Data.Text (Text)
 import Control.Applicative ((<|>))
 import Data.Bifunctor (first)
 import Data.Void (absurd, Void)
@@ -89,14 +87,15 @@ srcAt pos expr = do Note src _ <- exprAt pos expr
 
 
 -- | Given a well-typed expression and a position find the let binder at that
---   position (if there is one) and return a textual update to the source code
---   that inserts the type annotation (or replaces the existing one). If
---   something goes wrong returns a textual error message.
-annotateLet :: Position -> WellTyped -> Either String (Src, Text)
+--   position (if there is one) and return the type annotation to be inserted
+--   (potentially replacing the existing one). If something goes wrong returns a
+--   textual error message.
+annotateLet :: Position -> WellTyped -> Either String (Src, Expr Src Void)
 annotateLet pos expr = do
   annotateLet' pos empty (fromWellTyped expr)
 
-annotateLet' :: Position -> Context (Expr Src Void) -> Expr Src Void -> Either String (Src, Text)
+annotateLet' :: Position -> Context (Expr Src Void) -> Expr Src Void
+             -> Either String (Src, Expr Src Void)
 -- the input only contains singleton lets
 annotateLet' pos ctx (Note src e@(Let (Binding { value = a }) _))
   | not $ any (pos `inside`) [ src' | Note src' _ <- toListOf subExpressions e ]
@@ -105,7 +104,7 @@ annotateLet' pos ctx (Note src e@(Let (Binding { value = a }) _))
                      Just x -> return x
                      Nothing -> Left "The impossible happened: failed\
                                      \ to re-parse a Let expression."
-       return (srcAnnot, ": " <> pretty (normalize _A) <> " ")
+       return (srcAnnot, normalize _A)
 
 -- binders, see typeAt'
 annotateLet' pos ctx (Let (Binding { variable = x, value = a }) e@(Note src _)) | pos `inside` src = do

dhall-lsp-server/src/Dhall/LSP/Handlers.hs

@@ -12,14 +12,15 @@ import Data.Void (Void)
 import Dhall.Core (Expr(Note, Embed), pretty, Import(..), ImportHashed(..), ImportType(..), headers)
 import Dhall.Import (localToPath)
 import Dhall.Parser (Src(..))
+import Dhall.Pretty (CharacterSet(..))
 
 import Dhall.LSP.Backend.Completion (Completion(..), completionQueryAt,
   completeEnvironmentImport, completeLocalImport, buildCompletionContext, completeProjections, completeFromContext)
 import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
   fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader)
 import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
   rangeFromDhall, diagnose, embedsWithRanges)
-import Dhall.LSP.Backend.Formatting (formatExprWithHeader)
+import Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader)
 import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition,
   stripHash, getAllImportsWithHashPositions)
 import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
@@ -34,6 +35,7 @@ import Control.Monad (guard, forM)
 import Control.Monad.Trans (liftIO)
 import Control.Monad.Trans.Except (throwE, catchE, runExceptT)
 import Control.Monad.Trans.State.Strict (execStateT)
+import Data.Default (def)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe (maybeToList)
@@ -57,6 +59,14 @@ wrapHandler vstate handle message =
     execStateT . runExceptT $
       catchE (handle message) lspUserMessage
 
+getServerConfig :: HandlerM ServerConfig
+getServerConfig = do
+  lsp <- use lspFuncs
+  mConfig <- liftIO (LSP.config lsp)
+  case mConfig of
+    Just config -> return config
+    Nothing -> return def
+
 lspUserMessage :: (Severity, Text) -> HandlerM ()
 lspUserMessage (Log, text) =
   lspSendNotification LSP.NotLogMessage J.WindowLogMessage
@@ -289,7 +299,11 @@ documentFormattingHandler request = do
     Right res -> return res
     _ -> throwE (Warning, "Failed to format dhall code; parse error.")
 
-  let formatted = formatExprWithHeader expr header
+  ServerConfig {..} <- getServerConfig
+  let charSet | asciiOnly = ASCII
+              | otherwise = Unicode
+
+  let formatted = formatExprWithHeader charSet expr header
       numLines = Text.length txt
       range = J.Range (J.Position 0 0) (J.Position numLines 0)
       edits = J.List [J.TextEdit range formatted]
@@ -327,7 +341,11 @@ executeLintAndFormat request = do
     Right res -> return res
     _ -> throwE (Warning, "Failed to lint dhall code; parse error.")
 
-  let linted = formatExprWithHeader (lint expr) header
+  ServerConfig {..} <- getServerConfig
+  let charSet | asciiOnly = ASCII
+              | otherwise = Unicode
+
+  let linted = formatExprWithHeader charSet (lint expr) header
       numLines = Text.length txt
       range = J.Range (J.Position 0 0) (J.Position numLines 0)
       edit = J.WorkspaceEdit
@@ -350,13 +368,18 @@ executeAnnotateLet request = do
     Left _ -> throwE (Warning, "Failed to annotate let binding; not well-typed.")
     Right e -> return e
 
-  (Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _, txt)
+  ServerConfig {..} <- getServerConfig
+  let charSet | asciiOnly = ASCII
+              | otherwise = Unicode
+
+  (Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _, annotExpr)
     <- case annotateLet (line, col) welltyped of
       Right x -> return x
       Left msg -> throwE (Warning, Text.pack msg)
 
   let range = J.Range (J.Position (unPos x1 - 1) (unPos y1 - 1))
                       (J.Position (unPos x2 - 1) (unPos y2 - 1))
+      txt = formatExpr charSet annotExpr
       edit = J.WorkspaceEdit
         (Just (HashMap.singleton uri (J.List [J.TextEdit range txt]))) Nothing
 

dhall-lsp-server/src/Dhall/LSP/Server.hs

@@ -2,11 +2,14 @@
 module Dhall.LSP.Server(run) where
 
 import           Control.Concurrent.MVar
+import           Control.Lens ((^.))
+import           Data.Aeson (fromJSON, Result(Success))
 import           Data.Default
 import qualified Language.Haskell.LSP.Control as LSP.Control
 import qualified Language.Haskell.LSP.Core as LSP.Core
 
 import qualified Language.Haskell.LSP.Types as J
+import qualified Language.Haskell.LSP.Types.Lens as J
 
 import Data.Text (Text)
 import qualified System.Log.Logger
@@ -23,15 +26,23 @@ run mlog = do
   setupLogger mlog
   state <- newEmptyMVar
 
-  -- these two are stubs since we do not use a config
-  let onInitialConfiguration :: J.InitializeRequest -> Either Text ()
-      onInitialConfiguration _ = Right ()
-  let onConfigurationChange :: J.DidChangeConfigurationNotification -> Either Text ()
-      onConfigurationChange _ = Right ()
+  let onInitialConfiguration :: J.InitializeRequest -> Either Text ServerConfig
+      onInitialConfiguration req
+        | Just initOpts <- req ^. J.params . J.initializationOptions
+        , Success config <- fromJSON initOpts
+        = Right config
+      onInitialConfiguration _ = Right def
+
+  let onConfigurationChange :: J.DidChangeConfigurationNotification -> Either Text ServerConfig
+      onConfigurationChange notification
+        | preConfig <- notification ^. J.params . J.settings
+        , Success config <- fromJSON preConfig
+        = Right config
+      onConfigurationChange _ = Right def
 
   -- Callback that is called when the LSP server is started; makes the lsp
   -- state (LspFuncs) available to the message handlers through the `state` MVar.
-  let onStartup :: LSP.Core.LspFuncs () -> IO (Maybe J.ResponseError)
+  let onStartup :: LSP.Core.LspFuncs ServerConfig -> IO (Maybe J.ResponseError)
       onStartup lsp = do
         putMVar state (initialState lsp)
         return Nothing

dhall-lsp-server/src/Dhall/LSP/State.hs

@@ -7,7 +7,9 @@ import qualified Language.Haskell.LSP.Types as J
 
 import Control.Lens.TH (makeLenses)
 import Lens.Family (LensLike')
+import Data.Aeson (FromJSON(..), withObject, (.:), (.:?), (.!=))
 import Data.Map.Strict (Map, empty)
+import Data.Default (Default(def))
 import Data.Dynamic (Dynamic)
 import Dhall.LSP.Backend.Dhall (DhallError, Cache, emptyCache)
 import Data.Text (Text)
@@ -28,22 +30,39 @@ data Severity = Error
               | Log
               -- ^ Log message, not displayed by default.
 
+data ServerConfig = ServerConfig
+  { asciiOnly :: Bool
+  -- ^ Use ASCII symbols rather than fancy unicode when formatting and linting
+  -- code.
+  } deriving Show
+
+instance Default ServerConfig where
+  def = ServerConfig { asciiOnly = False }
+
+-- 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 .:? "asciiOnly" .!= asciiOnly def
+
 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 ()
+  , _lspFuncs :: LSP.LspFuncs ServerConfig
   -- ^ Access to the lsp functions supplied by haskell-lsp
   }
 
 makeLenses ''ServerState
 
 sendFunc :: Functor f =>
-  LensLike' f (LSP.LspFuncs ()) (LSP.FromServerMessage -> IO ())
+  LensLike' f (LSP.LspFuncs ServerConfig) (LSP.FromServerMessage -> IO ())
 sendFunc k s = fmap (\x -> s {LSP.sendFunc = x}) (k (LSP.sendFunc s))
 
-initialState :: LSP.LspFuncs () -> ServerState
+initialState :: LSP.LspFuncs ServerConfig -> ServerState
 initialState lsp = ServerState {..}
   where
     _importCache = emptyCache