diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -87,3 +87,11 @@ 2. Use `npm install -g vsce` to install the *vsce* executable. 3. Run `vsce package` inside the git repo to package the extension, resulting in a file `vscode-dhall-lsp-server-x.x.x.vsix`. 4. You can install the packaged extension directly by opening the `.vsix` file from within VSCod/ium. + +**Integration tests** + +The `dhall-lsp-server:tests` testsuite depends on the `dhall-lsp-server` executable. Since `stack` isn't aware of this dependency, `stack test dhall-lsp-server:tests` may use an old executable version. Run these tests with + + stack test dhall-lsp-server:tests dhall-lsp-server:dhall-lsp-server + +to ensure that the executable is up-to-date. diff --git a/dhall-lsp-server.cabal b/dhall-lsp-server.cabal --- a/dhall-lsp-server.cabal +++ b/dhall-lsp-server.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.12 name: dhall-lsp-server -Version: 1.0.2 +Version: 1.0.3 +cabal-version: 1.12 synopsis: Language Server Protocol (LSP) server for Dhall homepage: https://github.com/dhall-lang/dhall-haskell/dhall-lsp-server#readme bug-reports: https://github.com/dhall-lang/dhall-haskell/issues @@ -45,23 +45,23 @@ build-depends: aeson >= 1.3.1.1 && < 1.5 , aeson-pretty >= 0.8.7 && < 0.9 - , base >= 4.7 && < 5 + , base >= 4.11 && < 5 , bytestring >= 0.10.8.2 && < 0.11 , containers >= 0.5.11.0 && < 0.7 , data-default >= 0.7.1.1 && < 0.8 , directory >= 1.2.2.0 && < 1.4 - , dhall >= 1.26.0 && < 1.28 - , dhall-json >= 1.4 && < 1.6 + , dhall >= 1.28.0 && < 1.29 + , dhall-json >= 1.4 && < 1.7 , filepath >= 1.4.2 && < 1.5 , haskell-lsp >= 0.15.0.0 && < 0.17 , rope-utf16-splay >= 0.3.1.0 && < 0.4 , hslogger >= 1.2.10 && < 1.4 , lens >= 4.16.1 && < 4.19 , lens-family-core >= 1.2.3 && < 2.1 - , megaparsec >= 7.0.2 && < 7.1 + , megaparsec >= 7.0.2 && < 8.1 , mtl >= 2.2.2 && < 2.3 , network-uri >= 2.6.1.0 && < 2.7 - , prettyprinter >= 1.2.1 && < 1.4 + , prettyprinter >= 1.5.1 && < 1.6 , text >= 1.2.3.0 && < 1.3 , transformers >= 0.5.5.0 && < 0.6 , unordered-containers >= 0.2.9.0 && < 0.3 @@ -98,7 +98,8 @@ base , directory >= 1.3.1.5 && < 1.4 , filepath < 1.5 , - doctest >= 0.7.0 && < 0.17 + doctest >= 0.7.0 && < 0.17, + QuickCheck Other-Extensions: OverloadedStrings RecordWildCards Default-Language: Haskell2010 -- `doctest` doesn't work with `MIN_VERSION` macros before GHC 8 diff --git a/src/Dhall/LSP/Backend/Completion.hs b/src/Dhall/LSP/Backend/Completion.hs --- a/src/Dhall/LSP/Backend/Completion.hs +++ b/src/Dhall/LSP/Backend/Completion.hs @@ -1,7 +1,8 @@ module Dhall.LSP.Backend.Completion where +import Data.List (foldl') import Data.Text (Text) -import Data.Void (absurd) +import Data.Void (Void, absurd) import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (takeDirectory, ()) @@ -12,7 +13,7 @@ import qualified Data.Text as Text import Dhall.Context (Context, insert) import Dhall.Core (Binding(..), Expr(..), Var(..), normalize, shift, subst, pretty, reservedIdentifiers) -import Dhall.TypeCheck (X, typeWithA, typeOf) +import Dhall.TypeCheck (typeWithA, typeOf) import Dhall.Parser (Src, exprFromText) import qualified Dhall.Map import qualified Data.HashSet as HashSet @@ -37,7 +38,7 @@ data Completion = Completion { completeText :: Text, - completeType :: Maybe (Expr Src X) } + completeType :: Maybe (Expr Src Void) } -- | Complete file names. completeLocalImport :: FilePath -> FilePath -> IO [Completion] @@ -66,17 +67,17 @@ -- around. data CompletionContext = CompletionContext { - context :: Context (Expr Src X), + context :: Context (Expr Src Void), -- values to be substituted for 'dependent let' behaviour - values :: Context (Expr Src X) } + values :: Context (Expr Src Void) } -- | Given a 'binders expression' (with arbitrarily many 'holes') construct the -- corresponding completion context. -buildCompletionContext :: Expr Src X -> CompletionContext +buildCompletionContext :: Expr Src Void -> CompletionContext buildCompletionContext = buildCompletionContext' empty empty -buildCompletionContext' :: Context (Expr Src X) -> Context (Expr Src X) - -> Expr Src X -> CompletionContext +buildCompletionContext' :: Context (Expr Src Void) -> Context (Expr Src Void) + -> Expr Src Void -> CompletionContext buildCompletionContext' context values (Let (Binding { variable = x, annotation = mA, value = a }) e) -- We prefer the actual value over the annotated type in order to get -- 'dependent let' behaviour whenever possible. @@ -131,7 +132,7 @@ -- Helper. Given `Dhall.Context.toList ctx` construct the corresponding variable -- names. -contextToVariables :: [(Text, Expr Src X)] -> [Var] +contextToVariables :: [(Text, Expr Src Void)] -> [Var] contextToVariables [] = [] contextToVariables ((name, _) : rest) = V name 0 : map (inc name) (contextToVariables rest) @@ -153,12 +154,12 @@ ++ reserved -- | Complete union constructors and record projections. -completeProjections :: CompletionContext -> Expr Src X -> [Completion] +completeProjections :: CompletionContext -> Expr Src Void -> [Completion] completeProjections (CompletionContext context values) expr = -- substitute 'dependent lets', necessary for completion of unions let values' = toList values subs = filter ((/= holeExpr) . snd) $ zip (contextToVariables values') (map snd values') - expr' = foldl (\e (x,val) -> subst x val e) expr subs + expr' = foldl' (\e (x,val) -> subst x val e) expr subs in case typeWithA absurd context expr' of Left _ -> [] diff --git a/src/Dhall/LSP/Backend/Dhall.hs b/src/Dhall/LSP/Backend/Dhall.hs --- a/src/Dhall/LSP/Backend/Dhall.hs +++ b/src/Dhall/LSP/Backend/Dhall.hs @@ -29,6 +29,7 @@ import qualified Data.Graph as Graph import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Dhall.Map import qualified Network.URI as URI import qualified Language.Haskell.LSP.Types as LSP.Types import qualified Data.Text as Text @@ -75,11 +76,11 @@ -- | A cache maps Dhall imports to fully normalised expressions. By reusing -- caches we can speeds up diagnostics etc. significantly! -data Cache = Cache ImportGraph (Map.Map Dhall.Chained Dhall.ImportSemantics) +data Cache = Cache ImportGraph (Dhall.Map.Map Dhall.Chained Dhall.ImportSemantics) -- | The initial cache. emptyCache :: Cache -emptyCache = Cache [] Map.empty +emptyCache = Cache [] Dhall.Map.empty -- | Invalidate any _unhashed_ imports of the given file. Hashed imports are -- kept around as per @@ -87,7 +88,7 @@ -- Transitively invalidates any imports depending on the changed file. invalidate :: FileIdentifier -> Cache -> Cache invalidate (FileIdentifier chained) (Cache dependencies cache) = - Cache dependencies' $ Map.withoutKeys cache invalidImports + Cache dependencies' $ Dhall.Map.withoutKeys cache invalidImports where imports = map Dhall.parent dependencies ++ map Dhall.child dependencies @@ -128,7 +129,7 @@ -- | Parse a Dhall expression along with its "header", i.e. whitespace and -- comments prefixing the actual code. -parseWithHeader :: Text -> Either DhallError (Text, Expr Src Dhall.Import) +parseWithHeader :: Text -> Either DhallError (Dhall.Header, Expr Src Dhall.Import) parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText "" -- | Resolve all imports in an expression. @@ -165,5 +166,5 @@ -- Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded). hashNormalToCode :: Normal -> Text hashNormalToCode (Normal expr) = - Dhall.hashExpressionToCode alphaNormal + Dhall.hashExpressionToCode (Dhall.denote alphaNormal) where alphaNormal = Dhall.alphaNormalize expr diff --git a/src/Dhall/LSP/Backend/Formatting.hs b/src/Dhall/LSP/Backend/Formatting.hs --- a/src/Dhall/LSP/Backend/Formatting.hs +++ b/src/Dhall/LSP/Backend/Formatting.hs @@ -1,7 +1,9 @@ module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where import Dhall.Core (Expr) -import Dhall.Pretty (CharacterSet(..), layoutOpts, prettyCharacterSet) +import Dhall.Pretty (CharacterSet(..)) +import Dhall.Parser (Header(..)) +import qualified Dhall.Pretty import Dhall.Src (Src) import Data.Monoid ((<>)) @@ -10,17 +12,20 @@ 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 "" +formatExpr :: Pretty.Pretty b => CharacterSet -> Expr Src b -> Text +formatExpr charSet expr = + Pretty.renderStrict + . Dhall.Pretty.layout + $ Dhall.Pretty.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 -> Text -> Text -formatExprWithHeader expr header = Pretty.renderStrict - (Pretty.layoutSmart layoutOpts doc) +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) + <> Dhall.Pretty.prettyCharacterSet charSet expr <> "\n" diff --git a/src/Dhall/LSP/Backend/Parsing.hs b/src/Dhall/LSP/Backend/Parsing.hs --- a/src/Dhall/LSP/Backend/Parsing.hs +++ b/src/Dhall/LSP/Backend/Parsing.hs @@ -15,8 +15,8 @@ import Dhall.Core (Binding(..), Expr(..), Import, Var(..)) import Dhall.Src (Src(..)) import Dhall.Parser -import Dhall.Parser.Token -import Dhall.Parser.Expression +import Dhall.Parser.Token hiding (text) +import Dhall.Parser.Expression (getSourcePos, importType_, importHash_, localOnly) import Text.Megaparsec (try, skipManyTill, lookAhead, anySingle, notFollowedBy, eof, takeRest) @@ -24,7 +24,6 @@ import qualified Text.Megaparsec as Megaparsec import Text.Megaparsec (SourcePos(..)) - -- | Parse the outermost binding in a Src descriptor of a let-block and return -- the rest. Ex. on input `let a = 0 let b = a in b` parses `let a = 0 ` and -- returns the Src descriptor containing `let b = a in b`. @@ -33,13 +32,20 @@ where parseLetInnerOffset = do setSourcePos left _let + nonemptyWhitespace _ <- label + whitespace _ <- optional (do _ <- _colon - expr) + nonemptyWhitespace + _ <- expr + whitespace) _equal + whitespace _ <- expr + whitespace _ <- optional _in + whitespace begin <- getSourcePos tokens <- Megaparsec.takeRest end <- getSourcePos @@ -53,11 +59,15 @@ where parseLetAnnot = do setSourcePos left _let + nonemptyWhitespace _ <- label + whitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match $ optional (do _ <- _colon - expr) + nonemptyWhitespace + _ <- expr + whitespace) end <- getSourcePos _ <- Megaparsec.takeRest return (Src begin end tokens) @@ -73,6 +83,7 @@ where parseLetIdentifier = do setSourcePos left _let + nonemptyWhitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match label end <- getSourcePos @@ -86,7 +97,9 @@ where parseLetIdentifier = do setSourcePos left _lambda + whitespace _openParens + whitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match label end <- getSourcePos @@ -100,7 +113,9 @@ where parseLetIdentifier = do setSourcePos left _forall + whitespace _openParens + whitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match label end <- getSourcePos @@ -116,6 +131,7 @@ where parseImportHashPosition = do setSourcePos left _ <- importType_ + whitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match $ optional importHash_ end <- getSourcePos @@ -123,9 +139,10 @@ return (Src begin end tokens) setSourcePos :: SourcePos -> Parser () -setSourcePos src = Megaparsec.updateParserState - (\(Megaparsec.State s o (Megaparsec.PosState i o' _ t l)) -> - Megaparsec.State s o (Megaparsec.PosState i o' src t l)) +setSourcePos src = + Megaparsec.updateParserState $ \state -> + let posState = (Megaparsec.statePosState state) { Megaparsec.pstateSourcePos = src } + in state { Megaparsec.statePosState = posState } getImportLink :: Src -> Src getImportLink src@(Src left _ text) = @@ -166,37 +183,57 @@ closedLet = do _let + nonemptyWhitespace _ <- label + whitespace _ <- optional (do _colon + nonemptyWhitespace expr) _equal + whitespace _ <- expr + whitespace (do _in + nonemptyWhitespace _ <- expr return ()) <|> closedLet closedLambda = do _lambda + whitespace _openParens + whitespace _ <- label + whitespace _colon + nonemptyWhitespace _ <- expr + whitespace _closeParens + whitespace _arrow + whitespace _ <- expr return () closedPi = do _forall + whitespace _openParens + whitespace _ <- label + whitespace _colon + nonemptyWhitespace _ <- expr + whitespace _closeParens + whitespace _arrow + whitespace _ <- expr return () @@ -219,33 +256,45 @@ letBinder = do _let + nonemptyWhitespace name <- label - mType <- optional (do _colon; _type <- expr; return (Nothing, _type)) + whitespace + mType <- optional (do _colon; nonemptyWhitespace; _type <- expr; whitespace; return (Nothing, _type)) -- if the bound value does not parse, skip and replace with 'hole' - value <- try (do _equal; expr) + value <- try (do _equal; whitespace; expr <* whitespace) <|> (do skipManyTill anySingle (lookAhead boundary <|> _in); return holeExpr) inner <- parseBinderExpr return (Let (Binding Nothing name Nothing mType Nothing value) inner) forallBinder = do _forall + whitespace _openParens + whitespace name <- label + whitespace _colon + nonemptyWhitespace -- if the bound type does not parse, skip and replace with 'hole' - typ <- try (do e <- expr; _closeParens; _arrow; return e) + typ <- try (do e <- expr; whitespace; _closeParens; whitespace; _arrow; return e) <|> (do skipManyTill anySingle _arrow; return holeExpr) + whitespace inner <- parseBinderExpr return (Pi name typ inner) lambdaBinder = do _lambda + whitespace _openParens + whitespace name <- label + whitespace _colon + nonemptyWhitespace -- if the bound type does not parse, skip and replace with 'hole' - typ <- try (do e <- expr; _closeParens; _arrow; return e) + typ <- try (do e <- expr; whitespace; _closeParens; whitespace; _arrow; return e) <|> (do skipManyTill anySingle _arrow; return holeExpr) + whitespace inner <- parseBinderExpr return (Lam name typ inner) diff --git a/src/Dhall/LSP/Backend/Typing.hs b/src/Dhall/LSP/Backend/Typing.hs --- a/src/Dhall/LSP/Backend/Typing.hs +++ b/src/Dhall/LSP/Backend/Typing.hs @@ -1,18 +1,16 @@ 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) -import Dhall.LSP.Backend.Parsing (getLetAnnot, getLetIdentifier, +import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot, getLetIdentifier, getLamIdentifier, getForallIdentifier) import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall) import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped) @@ -22,7 +20,10 @@ -- that subexpression if possible. typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src Void) typeAt pos expr = do - let expr' = fromWellTyped expr + expr' <- case splitMultiLetSrc (fromWellTyped expr) of + Just e -> return e + Nothing -> Left "The impossible happened: failed to split let\ + \ blocks when preprocessing for typeAt'." (mSrc, typ) <- first show $ typeAt' pos empty expr' case mSrc of Just src -> return (Just src, normalize typ) @@ -44,7 +45,6 @@ , pos `inside` src' = return (Just src', _A) --- the input only contains singleton lets typeAt' pos ctx (Let (Binding { variable = x, value = a }) e@(Note src _)) | pos `inside` src = do _ <- typeWithA absurd ctx a let a' = shift 1 (V x 0) (normalize a) @@ -74,12 +74,16 @@ -- | Find the smallest Note-wrapped expression at the given position. exprAt :: Position -> Expr Src a -> Maybe (Expr Src a) -exprAt pos e@(Note _ expr) = exprAt pos expr <|> Just e -exprAt pos expr = +exprAt pos e = do e' <- splitMultiLetSrc e + exprAt' pos e' + +exprAt' :: Position -> Expr Src a -> Maybe (Expr Src a) +exprAt' pos e@(Note _ expr) = exprAt pos expr <|> Just e +exprAt' pos expr = let subExprs = toListOf subExpressions expr in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of [] -> Nothing - ((src,e) : _) -> exprAt pos e <|> Just (Note src e) + ((src,e) : _) -> exprAt' pos e <|> Just (Note src e) -- | Find the smallest Src annotation containing the given position. @@ -89,14 +93,20 @@ -- | 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) + expr' <- case splitMultiLetSrc (fromWellTyped expr) of + Just e -> return e + Nothing -> Left "The impossible happened: failed to split let\ + \ blocks when preprocessing for annotateLet'." + annotateLet' pos empty 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 +115,7 @@ 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 @@ -133,6 +143,13 @@ case [ Note src e | (Note src e) <- subExprs, pos `inside` src ] of (e:[]) -> annotateLet' pos ctx e _ -> Left "You weren't pointing at a let binder!" + +-- Make sure all lets in a multilet are annotated with their source information +splitMultiLetSrc :: Expr Src a -> Maybe (Expr Src a) +splitMultiLetSrc (Note src (Let b (Let b' e))) = do + src' <- getLetInner src + splitMultiLetSrc (Note src (Let b (Note src' (Let b' e)))) +splitMultiLetSrc expr = subExpressions splitMultiLetSrc expr -- Check if range lies completely inside a given subexpression. -- This version takes trailing whitespace into account diff --git a/src/Dhall/LSP/Handlers.hs b/src/Dhall/LSP/Handlers.hs --- a/src/Dhall/LSP/Handlers.hs +++ b/src/Dhall/LSP/Handlers.hs @@ -12,6 +12,7 @@ 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) @@ -19,7 +20,7 @@ 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.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 @@ 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 @@ 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 @@ 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 @@ 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 diff --git a/src/Dhall/LSP/Server.hs b/src/Dhall/LSP/Server.hs --- a/src/Dhall/LSP/Server.hs +++ b/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 @@ 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 diff --git a/src/Dhall/LSP/State.hs b/src/Dhall/LSP/State.hs --- a/src/Dhall/LSP/State.hs +++ b/src/Dhall/LSP/State.hs @@ -7,7 +7,9 @@ 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 @@ | 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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -37,7 +37,7 @@ case (extractContents typeHover, extractContents funcHover) of (HoverContents typeContent, HoverContents functionContent) -> do getValue typeContent `shouldBe` "Type" - getValue functionContent `shouldBe` "{ home : Text, name : Text }" + getValue functionContent `shouldBe` "\8704(_isAdmin : Bool) \8594 { home : Text, name : Text }" _ -> error "test failed" pure ()