dhall-lsp-server 1.0.2 → 1.0.3
raw patch · 11 files changed
+208/−73 lines, 11 filesdep +QuickCheckdep ~dhalldep ~dhall-jsondep ~megaparsec
Dependencies added: QuickCheck
Dependency ranges changed: dhall, dhall-json, megaparsec, prettyprinter
Files
- README.md +8/−0
- dhall-lsp-server.cabal +9/−8
- src/Dhall/LSP/Backend/Completion.hs +12/−11
- src/Dhall/LSP/Backend/Dhall.hs +6/−5
- src/Dhall/LSP/Backend/Formatting.hs +12/−7
- src/Dhall/LSP/Backend/Parsing.hs +61/−12
- src/Dhall/LSP/Backend/Typing.hs +33/−16
- src/Dhall/LSP/Handlers.hs +27/−4
- src/Dhall/LSP/Server.hs +17/−6
- src/Dhall/LSP/State.hs +22/−3
- tests/Main.hs +1/−1
README.md view
@@ -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.
dhall-lsp-server.cabal view
@@ -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
src/Dhall/LSP/Backend/Completion.hs view
@@ -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 _ -> []
src/Dhall/LSP/Backend/Dhall.hs view
@@ -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
src/Dhall/LSP/Backend/Formatting.hs view
@@ -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"
src/Dhall/LSP/Backend/Parsing.hs view
@@ -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)
src/Dhall/LSP/Backend/Typing.hs view
@@ -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
src/Dhall/LSP/Handlers.hs view
@@ -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
src/Dhall/LSP/Server.hs view
@@ -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
src/Dhall/LSP/State.hs view
@@ -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
tests/Main.hs view
@@ -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 ()