Add dhall-lsp-server (#843)
This commit is contained in:
parent
e392657540
commit
f2f4fc2979
|
@ -11,7 +11,7 @@ environment:
|
||||||
STACK_VERSION: 1.9.3
|
STACK_VERSION: 1.9.3
|
||||||
|
|
||||||
matrix:
|
matrix:
|
||||||
- STACK_YAML: stack.yaml
|
- STACK_YAML: stack-nightly-2018-12-17.yaml
|
||||||
- STACK_YAML: stack-lts-6.yaml
|
- STACK_YAML: stack-lts-6.yaml
|
||||||
|
|
||||||
install:
|
install:
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
packages: ./dhall ./dhall-bash ./dhall-json ./dhall-text
|
packages: ./dhall ./dhall-bash ./dhall-json ./dhall-text ./dhall-lsp-server
|
||||||
|
|
|
@ -0,0 +1,3 @@
|
||||||
|
# Changelog for dhall-lsp-server
|
||||||
|
|
||||||
|
## Unreleased changes
|
|
@ -0,0 +1,21 @@
|
||||||
|
MIT License
|
||||||
|
|
||||||
|
Copyright (c) 2019 PanAeon
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||||
|
of this software and associated documentation files (the "Software"), to deal
|
||||||
|
in the Software without restriction, including without limitation the rights
|
||||||
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||||
|
copies of the Software, and to permit persons to whom the Software is
|
||||||
|
furnished to do so, subject to the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included in all
|
||||||
|
copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||||
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||||
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||||
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||||
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||||
|
SOFTWARE.
|
|
@ -0,0 +1,24 @@
|
||||||
|
|
||||||
|
# dhall-lsp-server
|
||||||
|
```[![Travis](https://travis-ci.org/PanAeon/dhall-lsp-server.svg?branch=master)](https://travis-ci.org/PanAeon/dhall-lsp-server)```
|
||||||
|
|
||||||
|
**This project is in alpha state !!!**
|
||||||
|
|
||||||
|
This is a [Language Server Protocol](https://microsoft.github.io/language-server-protocol/) server implementation for the [Dhall](https://dhall-lang.org) programming language.
|
||||||
|
|
||||||
|
|
||||||
|
## Installation
|
||||||
|
|
||||||
|
### From source
|
||||||
|
|
||||||
|
[Haskell Tool Stack](https://docs.haskellstack.org/en/stable/README/) should be installed.
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd ./dhall-lsp-server
|
||||||
|
stack install
|
||||||
|
```
|
||||||
|
|
||||||
|
Stack will copy executables to the current user's executable directory. On macOS this is `/Users/<username>/.local/bin`. On linux this should be `/Home/<username>/.local/bin`.
|
||||||
|
If you are using VSCode there's also an option in the [VSCode Dhall plugin](https://github.com/PanAeon/vscode-dhall-lsp-server) to specify the path to the executable directly, which might be useful if you have multiple executables or you can't use global PATH for some reason.
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
|
@ -0,0 +1,82 @@
|
||||||
|
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
import Data.Default
|
||||||
|
import qualified Data.HashMap.Strict as H
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified System.Exit
|
||||||
|
import qualified System.Log.Logger as L
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
import qualified Data.Text.IO
|
||||||
|
import qualified System.IO
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import Options.Applicative (Parser, ParserInfo)
|
||||||
|
import qualified Options.Applicative
|
||||||
|
|
||||||
|
import qualified System.IO.Unsafe
|
||||||
|
|
||||||
|
import LSP.Server(run)
|
||||||
|
|
||||||
|
data Options = Options {
|
||||||
|
command :: Command
|
||||||
|
, logFile :: Maybe String -- file where the server process debug log should be written
|
||||||
|
}
|
||||||
|
|
||||||
|
data Command = CmdVersion | Default
|
||||||
|
|
||||||
|
parseOptions :: Parser Options
|
||||||
|
parseOptions = Options <$> parseMode
|
||||||
|
<*> Options.Applicative.optional parseLogFile
|
||||||
|
where
|
||||||
|
parseLogFile = Options.Applicative.strOption
|
||||||
|
(
|
||||||
|
Options.Applicative.long "log"
|
||||||
|
<> Options.Applicative.help "If present writes debug output to the specified file")
|
||||||
|
|
||||||
|
|
||||||
|
subcommand :: String -> String -> Parser a -> Parser a
|
||||||
|
subcommand name description parser =
|
||||||
|
Options.Applicative.hsubparser
|
||||||
|
( Options.Applicative.command name parserInfo
|
||||||
|
<> Options.Applicative.metavar name
|
||||||
|
)
|
||||||
|
where
|
||||||
|
parserInfo =
|
||||||
|
Options.Applicative.info parser
|
||||||
|
( Options.Applicative.fullDesc
|
||||||
|
<> Options.Applicative.progDesc description
|
||||||
|
)
|
||||||
|
|
||||||
|
parseMode :: Parser Command
|
||||||
|
parseMode =
|
||||||
|
subcommand
|
||||||
|
"version"
|
||||||
|
"Display version"
|
||||||
|
(pure CmdVersion)
|
||||||
|
<|> pure Default
|
||||||
|
|
||||||
|
parserInfoOptions :: ParserInfo Options
|
||||||
|
parserInfoOptions =
|
||||||
|
Options.Applicative.info
|
||||||
|
(Options.Applicative.helper <*> parseOptions)
|
||||||
|
( Options.Applicative.progDesc "Interpreter for the Dhall language"
|
||||||
|
<> Options.Applicative.fullDesc
|
||||||
|
)
|
||||||
|
|
||||||
|
runCommand :: Options -> IO ()
|
||||||
|
runCommand Options{..} = case command of
|
||||||
|
CmdVersion -> putStrLn "0.0.1.0" -- TODO: read from build
|
||||||
|
Default ->
|
||||||
|
run logFile (pure ()) >>= \case
|
||||||
|
0 -> exitSuccess
|
||||||
|
c -> exitWith . System.Exit.ExitFailure $ c
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = Options.Applicative.execParser parserInfoOptions >>= runCommand
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
(import ../nix/shared.nix {}).possibly-static.dhall
|
|
@ -0,0 +1,128 @@
|
||||||
|
cabal-version: 1.12
|
||||||
|
name: dhall-lsp-server
|
||||||
|
version: 0.1.0.0
|
||||||
|
description: Please see the README on GitHub at <https://github.com/githubuser/dhall-lsp-server#readme>
|
||||||
|
homepage: https://github.com/dhall-lang/dhall-haskell/dhall-lsp-server#readme
|
||||||
|
bug-reports: https://github.com/dhall-lang/dhall-haskell/issues
|
||||||
|
author: panaeon
|
||||||
|
maintainer: panaeon
|
||||||
|
copyright: 2019 panaeon
|
||||||
|
license: MIT
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
extra-source-files:
|
||||||
|
README.md
|
||||||
|
ChangeLog.md
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/dhall-lang/dhall-haskell
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules:
|
||||||
|
Backend.Dhall.DhallErrors
|
||||||
|
Backend.Dhall.Diagnostics
|
||||||
|
LSP.Common
|
||||||
|
LSP.Dispatcher
|
||||||
|
LSP.Handlers.Diagnostics
|
||||||
|
LSP.Server
|
||||||
|
Prelude
|
||||||
|
other-modules:
|
||||||
|
Paths_dhall_lsp_server
|
||||||
|
hs-source-dirs:
|
||||||
|
src
|
||||||
|
default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
|
, base-noprelude >=4.7 && <5
|
||||||
|
, containers
|
||||||
|
, data-default
|
||||||
|
, dhall
|
||||||
|
, filepath
|
||||||
|
, haskell-lsp
|
||||||
|
, hslogger
|
||||||
|
, lens
|
||||||
|
, lens-family-core
|
||||||
|
, megaparsec
|
||||||
|
, mtl
|
||||||
|
, optparse-applicative
|
||||||
|
, prettyprinter
|
||||||
|
, relude
|
||||||
|
, sorted-list
|
||||||
|
, stm
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, unordered-containers
|
||||||
|
, yi-rope
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable dhall-lsp-server
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
Paths_dhall_lsp_server
|
||||||
|
hs-source-dirs:
|
||||||
|
app
|
||||||
|
default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables
|
||||||
|
ghc-options: -rtsopts
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
|
, base-noprelude >=4.7 && <5
|
||||||
|
, containers
|
||||||
|
, data-default
|
||||||
|
, dhall
|
||||||
|
, dhall-lsp-server
|
||||||
|
, filepath
|
||||||
|
, haskell-lsp
|
||||||
|
, hslogger
|
||||||
|
, lens
|
||||||
|
, lens-family-core
|
||||||
|
, megaparsec
|
||||||
|
, mtl
|
||||||
|
, optparse-applicative
|
||||||
|
, prettyprinter
|
||||||
|
, relude
|
||||||
|
, sorted-list
|
||||||
|
, stm
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, unordered-containers
|
||||||
|
, yi-rope
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite dhall-lsp-server-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
other-modules:
|
||||||
|
Paths_dhall_lsp_server
|
||||||
|
hs-source-dirs:
|
||||||
|
test
|
||||||
|
default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables
|
||||||
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
|
, base-noprelude >=4.7 && <5
|
||||||
|
, containers
|
||||||
|
, data-default
|
||||||
|
, dhall
|
||||||
|
, dhall-lsp-server
|
||||||
|
, filepath
|
||||||
|
, haskell-lsp
|
||||||
|
, hslogger
|
||||||
|
, lens
|
||||||
|
, lens-family-core
|
||||||
|
, megaparsec
|
||||||
|
, mtl
|
||||||
|
, optparse-applicative
|
||||||
|
, prettyprinter
|
||||||
|
, relude
|
||||||
|
, sorted-list
|
||||||
|
, stm
|
||||||
|
, tasty
|
||||||
|
, tasty-discover
|
||||||
|
, tasty-hspec
|
||||||
|
, tasty-quickcheck
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, unordered-containers
|
||||||
|
, yi-rope
|
||||||
|
default-language: Haskell2010
|
|
@ -0,0 +1 @@
|
||||||
|
(import ../nix/shared.nix { coverage = true; }).shell-dhall
|
|
@ -0,0 +1,226 @@
|
||||||
|
module Backend.Dhall.DhallErrors(simpleTypeMessage) where
|
||||||
|
|
||||||
|
{-| This file contains mostly copy-paste error formatting code from <root>/dhall/src/Dhall/TypeCheck.hs
|
||||||
|
This had to be necessary as to strip down extra information that standard error formatting provides (location, ascii-formatting).
|
||||||
|
-}
|
||||||
|
import Dhall.TypeCheck
|
||||||
|
import qualified Dhall.Diff
|
||||||
|
import Dhall.Core(Expr)
|
||||||
|
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||||
|
import qualified Data.Text.Prettyprint.Doc.Render.String as R
|
||||||
|
import Dhall.Pretty(Ann(..), layoutOpts)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
prettyDiff :: (Eq a, Pretty.Pretty a) => Expr s a -> Expr s a -> Text
|
||||||
|
prettyDiff exprL exprR = T.pack . R.renderString . Pretty.layoutPretty layoutOpts . Pretty.unAnnotate $ diff
|
||||||
|
where
|
||||||
|
diff = Dhall.Diff.diffNormalized exprL exprR
|
||||||
|
|
||||||
|
simpleTypeMessage :: (Pretty.Pretty a, Eq a) => TypeMessage s a -> Text
|
||||||
|
simpleTypeMessage (UnboundVariable x) =
|
||||||
|
"Unbound variable: " <> x
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidInputType expr) =
|
||||||
|
"Invalid function input"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidOutputType expr) =
|
||||||
|
"Invalid function output"
|
||||||
|
|
||||||
|
simpleTypeMessage (NotAFunction expr0 expr1) =
|
||||||
|
"Not a function"
|
||||||
|
|
||||||
|
simpleTypeMessage (TypeMismatch expr0 expr1 expr2 expr3) =
|
||||||
|
"Wrong type of function argument\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr1 expr3
|
||||||
|
|
||||||
|
simpleTypeMessage (AnnotMismatch expr0 expr1 expr2) =
|
||||||
|
"Expression doesn't match annotation\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr1 expr2
|
||||||
|
|
||||||
|
|
||||||
|
simpleTypeMessage Untyped =
|
||||||
|
"❰Sort❱ has no type, kind, or sort"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidPredicate expr0 expr1) =
|
||||||
|
"Invalid predicate for ❰if❱"
|
||||||
|
|
||||||
|
simpleTypeMessage (IfBranchMustBeTerm b expr0 expr1 expr2) =
|
||||||
|
"❰if❱ branch is not a term"
|
||||||
|
|
||||||
|
simpleTypeMessage (IfBranchMismatch expr0 expr1 expr2 expr3) =
|
||||||
|
"❰if❱ branches must have matching types\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr1 expr3
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidListType expr0) =
|
||||||
|
"Invalid type for ❰List❱ elements"
|
||||||
|
|
||||||
|
simpleTypeMessage MissingListType =
|
||||||
|
"An empty list requires a type annotation"
|
||||||
|
|
||||||
|
simpleTypeMessage (MismatchedListElements i expr0 _expr1 expr2) =
|
||||||
|
"List elements should all have the same type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr0 expr2
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidListElement i expr0 _expr1 expr2) =
|
||||||
|
"List element has the wrong type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr0 expr2
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidOptionalType expr0) =
|
||||||
|
"Invalid type for ❰Optional❱ element"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidOptionalElement expr0 expr1 expr2) =
|
||||||
|
"❰Optional❱ element has the wrong type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr0 expr2
|
||||||
|
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidSome expr0 expr1 expr2) =
|
||||||
|
"❰Some❱ argument has the wrong type"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidFieldType k expr0) =
|
||||||
|
"Invalid field type"
|
||||||
|
|
||||||
|
simpleTypeMessage (FieldAnnotationMismatch k0 expr0 c0 k1 expr1 c1) =
|
||||||
|
"Field annotation mismatch"
|
||||||
|
|
||||||
|
simpleTypeMessage (FieldMismatch k0 expr0 c0 k1 expr1 c1) =
|
||||||
|
"Field mismatch"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidField k expr0) =
|
||||||
|
"Invalid field"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidAlternativeType k expr0) =
|
||||||
|
"Invalid alternative type"
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidAlternative k expr0) =
|
||||||
|
"Invalid alternative"
|
||||||
|
|
||||||
|
|
||||||
|
-- ! FIXME: missing AlternativeAnnotationMismatch
|
||||||
|
-- simpleTypeMessage (AlternativeAnnotationMismatch k0 expr0 c0 k1 expr1 c1) =
|
||||||
|
-- "Alternative annotation mismatch"
|
||||||
|
|
||||||
|
simpleTypeMessage (ListAppendMismatch expr0 expr1) =
|
||||||
|
"You can only append ❰List❱s with matching element types\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (DuplicateAlternative k) =
|
||||||
|
"Duplicate union alternative"
|
||||||
|
|
||||||
|
simpleTypeMessage (MustCombineARecord c expr0 expr1) =
|
||||||
|
"You can only combine records"
|
||||||
|
|
||||||
|
simpleTypeMessage (RecordMismatch c expr0 expr1 const0 const1) =
|
||||||
|
"Record mismatch"
|
||||||
|
|
||||||
|
simpleTypeMessage (CombineTypesRequiresRecordType expr0 expr1) =
|
||||||
|
"❰⩓❱ requires arguments that are record types"
|
||||||
|
|
||||||
|
simpleTypeMessage (RecordTypeMismatch const0 const1 expr0 expr1) =
|
||||||
|
"Record type mismatch"
|
||||||
|
|
||||||
|
simpleTypeMessage (FieldCollision k) =
|
||||||
|
"Field collision"
|
||||||
|
|
||||||
|
simpleTypeMessage (MustMergeARecord expr0 expr1) =
|
||||||
|
"❰merge❱ expects a record of handlers"
|
||||||
|
|
||||||
|
simpleTypeMessage (MustMergeUnion expr0 expr1) =
|
||||||
|
"❰merge❱ expects a union"
|
||||||
|
|
||||||
|
simpleTypeMessage (UnusedHandler ks) =
|
||||||
|
"Unused handler"
|
||||||
|
|
||||||
|
simpleTypeMessage (MissingHandler ks) =
|
||||||
|
"Missing handler"
|
||||||
|
|
||||||
|
simpleTypeMessage MissingMergeType =
|
||||||
|
"An empty ❰merge❱ requires a type annotation"
|
||||||
|
|
||||||
|
simpleTypeMessage (HandlerInputTypeMismatch expr0 expr1 expr2) =
|
||||||
|
"Wrong handler input type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr1 expr2
|
||||||
|
|
||||||
|
simpleTypeMessage (InvalidHandlerOutputType expr0 expr1 expr2) =
|
||||||
|
"Wrong handler output type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr1 expr2
|
||||||
|
|
||||||
|
simpleTypeMessage (HandlerOutputTypeMismatch key0 expr0 key1 expr1) =
|
||||||
|
"Handlers should have the same output type\n"
|
||||||
|
<> "\n"
|
||||||
|
<> prettyDiff expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (HandlerNotAFunction k expr0) =
|
||||||
|
"Handler is not a function"
|
||||||
|
|
||||||
|
simpleTypeMessage (ConstructorsRequiresAUnionType expr0 expr1) =
|
||||||
|
"❰constructors❱ requires a union type"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantAccess lazyText0 expr0 expr1) =
|
||||||
|
"Not a record or a union"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantProject lazyText0 expr0 expr1) =
|
||||||
|
"Not a record"
|
||||||
|
|
||||||
|
simpleTypeMessage (MissingField k expr0) =
|
||||||
|
"Missing record field"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantAnd expr0 expr1) =
|
||||||
|
buildBooleanOperator "&&" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (CantOr expr0 expr1) =
|
||||||
|
buildBooleanOperator "||" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (CantEQ expr0 expr1) =
|
||||||
|
buildBooleanOperator "==" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (CantNE expr0 expr1) =
|
||||||
|
buildBooleanOperator "!=" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (CantInterpolate expr0 expr1) =
|
||||||
|
"You can only interpolate ❰Text❱"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantTextAppend expr0 expr1) =
|
||||||
|
"❰++❱ only works on ❰Text❱"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantListAppend expr0 expr1) =
|
||||||
|
"❰#❱ only works on ❰List❱s"
|
||||||
|
|
||||||
|
simpleTypeMessage (CantAdd expr0 expr1) =
|
||||||
|
buildNaturalOperator "+" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (CantMultiply expr0 expr1) =
|
||||||
|
buildNaturalOperator "*" expr0 expr1
|
||||||
|
|
||||||
|
simpleTypeMessage (NoDependentTypes expr0 expr1) =
|
||||||
|
"No dependent types"
|
||||||
|
|
||||||
|
buildBooleanOperator :: Text -> Expr s a -> Expr s a -> Text
|
||||||
|
buildBooleanOperator operator expr0 expr1 =
|
||||||
|
"❰" <> txt2 <> "❱ only works on ❰Bool❱s"
|
||||||
|
where
|
||||||
|
txt2 = operator
|
||||||
|
|
||||||
|
buildNaturalOperator :: Text -> Expr s a -> Expr s a -> Text
|
||||||
|
buildNaturalOperator operator expr0 expr1 =
|
||||||
|
"❰" <> txt2 <> "❱ only works on ❰Natural❱s"
|
||||||
|
|
||||||
|
|
||||||
|
where
|
||||||
|
txt2 = operator
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,260 @@
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
module Backend.Dhall.Diagnostics( compilerDiagnostics
|
||||||
|
, defaultDiagnosticSource
|
||||||
|
) where
|
||||||
|
|
||||||
|
|
||||||
|
{-|
|
||||||
|
This module is responsible for producing dhall compiler diagnostic (errors, warns, etc ...)
|
||||||
|
-}
|
||||||
|
|
||||||
|
import qualified Control.Exception
|
||||||
|
import qualified Dhall
|
||||||
|
import Dhall(rootDirectory, sourceName, defaultInputSettings, inputExprWithSettings)
|
||||||
|
import Dhall.Parser(ParseError(..), Src(..))
|
||||||
|
import qualified Dhall.Core
|
||||||
|
import qualified System.Exit
|
||||||
|
import qualified System.IO
|
||||||
|
import Lens.Family (LensLike', set, view)
|
||||||
|
import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..), X)
|
||||||
|
|
||||||
|
import Dhall.Binary(DecodingFailure(..))
|
||||||
|
import Dhall.Import(Imported(..), Cycle(..), ReferentiallyOpaque(..),
|
||||||
|
MissingFile, MissingEnvironmentVariable, MissingImports )
|
||||||
|
|
||||||
|
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
|
||||||
|
import qualified Text.Megaparsec
|
||||||
|
import qualified Text.Megaparsec.Error
|
||||||
|
import Text.Show(ShowS)
|
||||||
|
import qualified Data.Set
|
||||||
|
import qualified System.FilePath
|
||||||
|
|
||||||
|
import Backend.Dhall.DhallErrors(simpleTypeMessage)
|
||||||
|
|
||||||
|
import Language.Haskell.LSP.Types(
|
||||||
|
Diagnostic(..)
|
||||||
|
, Range(..)
|
||||||
|
, DiagnosticSeverity(..)
|
||||||
|
, DiagnosticSource(..)
|
||||||
|
, DiagnosticRelatedInformation(..)
|
||||||
|
, Position(..)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
defaultDiagnosticSource :: DiagnosticSource
|
||||||
|
defaultDiagnosticSource = "dhall-lsp-server"
|
||||||
|
|
||||||
|
-- FIXME: type errors span across whitespace after the expression
|
||||||
|
-- Dhall.Binary.DecodingFailure
|
||||||
|
-- Dhall.Import(Cycle, ReferentiallyOpaque, MissingFile, MissingEnvironmentVariable, MissingImports,
|
||||||
|
-- HashMismatch, CannotImportHTTPURL)
|
||||||
|
-- !FIXME: (aside) VSCode multiselection expand selects first world only
|
||||||
|
compilerDiagnostics :: FilePath -> Text -> Text -> IO [Diagnostic]
|
||||||
|
compilerDiagnostics path filePath txt = handle ast
|
||||||
|
where
|
||||||
|
-- bufferName = T.unpack $ last $ fromList $ T.split (=='/') filePath
|
||||||
|
-- rootDir = T.unpack $ T.intercalate "/" $ tail $ fromList $ T.split (=='/') filePath
|
||||||
|
(rootDir, bufferName) = System.FilePath.splitFileName path
|
||||||
|
settings = ( set rootDirectory rootDir
|
||||||
|
. set sourceName bufferName) defaultInputSettings
|
||||||
|
isEmpty = T.null $ T.strip txt -- FIXME: file consisting with only comments shouldn't produce an error? handle upstream?
|
||||||
|
ast = if isEmpty
|
||||||
|
then pure []
|
||||||
|
else [] <$ inputExprWithSettings settings txt
|
||||||
|
handle = Control.Exception.handle allErrors
|
||||||
|
. Control.Exception.handle decodingFailure
|
||||||
|
. handleImportErrors txt
|
||||||
|
. Control.Exception.handle parseErrors
|
||||||
|
. Control.Exception.handle importErrors
|
||||||
|
. Control.Exception.handle moduleErrors
|
||||||
|
|
||||||
|
|
||||||
|
allErrors e = do
|
||||||
|
let _ = e :: SomeException
|
||||||
|
numLines = length $ T.lines txt
|
||||||
|
pure [Diagnostic {
|
||||||
|
_range = Range (Position 0 0) (Position numLines 0)
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = "Internal error has occurred: " <> (show e)
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}]
|
||||||
|
decodingFailure e = do
|
||||||
|
let (CBORIsNotDhall term) = e
|
||||||
|
pure [Diagnostic {
|
||||||
|
_range = Range (Position 0 0) (Position 1 0)
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = "Cannot decode CBOR to Dhall " <> (show term)
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}]
|
||||||
|
parseErrors e = do
|
||||||
|
let _ = e :: ParseError
|
||||||
|
errors = errorBundleToDiagnostics $ unwrap e
|
||||||
|
System.IO.hPrint System.IO.stderr errors
|
||||||
|
pure $ errors
|
||||||
|
importErrors (Imported ps e) = do
|
||||||
|
let _ = e :: TypeError Src X
|
||||||
|
numLines = length $ T.lines txt
|
||||||
|
System.IO.hPrint System.IO.stderr (show ps)
|
||||||
|
pure [ Diagnostic {
|
||||||
|
_range = Range (Position 0 0) (Position numLines 0) -- getSourceRange e
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = ("import error: " <> (show e)) -- FIXME: simple show for import msgs
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}]
|
||||||
|
moduleErrors e = do
|
||||||
|
let _ = e :: TypeError Src X
|
||||||
|
(TypeError ctx expr msg) = e
|
||||||
|
-- System.IO.hPrint System.IO.stderr txt
|
||||||
|
-- System.IO.hPrint System.IO.stderr e
|
||||||
|
pure [ Diagnostic {
|
||||||
|
_range = getSourceRange e
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = (simpleTypeMessage msg) -- FIXME: using show for import msgs
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}]
|
||||||
|
|
||||||
|
-- ! FIXME: provide import errors source position (should be handled in the dhall project)
|
||||||
|
-- * Import Errors provide no source pos info, except import mode and ImportType (which contains actual url)
|
||||||
|
handleImportErrors :: Text -> IO [Diagnostic] -> IO [Diagnostic]
|
||||||
|
handleImportErrors txt = Control.Exception.handle (importHandler @Cycle)
|
||||||
|
. Control.Exception.handle (importHandler @ReferentiallyOpaque)
|
||||||
|
. Control.Exception.handle (importHandler @MissingFile)
|
||||||
|
. Control.Exception.handle (importHandler @MissingEnvironmentVariable)
|
||||||
|
. Control.Exception.handle (importHandler @MissingImports)
|
||||||
|
|
||||||
|
where
|
||||||
|
numLines = length $ T.lines txt
|
||||||
|
importHandler:: forall e a. Exception e => (e -> IO [Diagnostic])
|
||||||
|
importHandler e =
|
||||||
|
pure [Diagnostic {
|
||||||
|
_range = Range (Position 0 0) (Position numLines 0)
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = removeAsciiColors $ show e
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}]
|
||||||
|
|
||||||
|
removeAsciiColors :: Text -> Text
|
||||||
|
removeAsciiColors = T.replace "\ESC[1;31m" "" . T.replace "\ESC[0m" ""
|
||||||
|
-- Dhall.Import(Cycle, ReferentiallyOpaque, MissingFile, MissingEnvironmentVariable, MissingImports,
|
||||||
|
-- HashMismatch, CannotImportHTTPURL)
|
||||||
|
|
||||||
|
getSourceRange :: TypeError Src X -> Range
|
||||||
|
getSourceRange (TypeError ctx expr msg) = case expr of
|
||||||
|
Dhall.Core.Note (Src (Text.Megaparsec.SourcePos _ bl bc) (Text.Megaparsec.SourcePos _ el ec) _) _ ->
|
||||||
|
Range (Position (unPos bl - 1) (unPos bc - 1)) (Position (unPos el - 1) (unPos ec - 1))
|
||||||
|
_ -> error "expected note" -- $ Range (Position 0 0) (Position (negate 1) 0) -- FIXME: default case
|
||||||
|
where
|
||||||
|
unPos = Text.Megaparsec.unPos
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---------------------- Megaparsec utils: ----------------------------------------
|
||||||
|
|
||||||
|
|
||||||
|
errorBundleToDiagnostics
|
||||||
|
:: forall s e. ( Text.Megaparsec.Stream s
|
||||||
|
, Text.Megaparsec.Error.ShowErrorComponent e
|
||||||
|
)
|
||||||
|
=> Text.Megaparsec.ParseErrorBundle s e
|
||||||
|
-> [Diagnostic]
|
||||||
|
errorBundleToDiagnostics Text.Megaparsec.Error.ParseErrorBundle {..} =
|
||||||
|
fst $ foldl' f ([], bundlePosState) bundleErrors
|
||||||
|
where
|
||||||
|
f :: forall s e. ( Text.Megaparsec.Stream s, Text.Megaparsec.Error.ShowErrorComponent e)
|
||||||
|
=> ([Diagnostic], Text.Megaparsec.PosState s)
|
||||||
|
-> Text.Megaparsec.ParseError s e
|
||||||
|
-> ([Diagnostic], Text.Megaparsec.PosState s)
|
||||||
|
f (r, !pst) e = (diagnostics:r, pst')
|
||||||
|
where
|
||||||
|
(epos, line, pst') = Text.Megaparsec.reachOffset (Text.Megaparsec.errorOffset e) pst
|
||||||
|
errorText = Text.Megaparsec.Error.parseErrorTextPretty e
|
||||||
|
lineNumber = (Text.Megaparsec.unPos . Text.Megaparsec.sourceLine) epos - 1
|
||||||
|
startColumn = Text.Megaparsec.unPos (Text.Megaparsec.sourceColumn epos) - 1
|
||||||
|
diagnostics = Diagnostic {
|
||||||
|
_range = Range (Position lineNumber startColumn) (Position lineNumber endColumn)
|
||||||
|
, _severity = Just DsError
|
||||||
|
, _source = Just defaultDiagnosticSource
|
||||||
|
, _code = Nothing
|
||||||
|
, _message = T.pack errorText
|
||||||
|
, _relatedInformation = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
endColumn = startColumn + errorLength
|
||||||
|
|
||||||
|
lineLength = length line
|
||||||
|
errorLength =
|
||||||
|
case e of
|
||||||
|
Text.Megaparsec.TrivialError _ Nothing _ -> 1
|
||||||
|
Text.Megaparsec.TrivialError _ (Just x) _ -> errorItemLength x
|
||||||
|
Text.Megaparsec.FancyError _ xs ->
|
||||||
|
Data.Set.foldl' (\a b -> max a (errorFancyLength b)) 1 xs
|
||||||
|
|
||||||
|
-- | Get length of the “pointer” to display under a given 'ErrorItem'.
|
||||||
|
|
||||||
|
errorItemLength :: Text.Megaparsec.ErrorItem t -> Int
|
||||||
|
errorItemLength = \case
|
||||||
|
Text.Megaparsec.Tokens ts -> length ts
|
||||||
|
_ -> 1
|
||||||
|
|
||||||
|
errorFancyLength :: Text.Megaparsec.ShowErrorComponent e => Text.Megaparsec.ErrorFancy e -> Int
|
||||||
|
errorFancyLength = \case
|
||||||
|
Text.Megaparsec.ErrorCustom a -> Text.Megaparsec.errorComponentLen a
|
||||||
|
_ -> 1
|
||||||
|
-- errorBundlePretty
|
||||||
|
-- :: forall s e. ( Text.Megaparsec.Stream s
|
||||||
|
-- , Text.Megaparsec.Error.ShowErrorComponent e
|
||||||
|
-- )
|
||||||
|
-- => Text.Megaparsec.ParseErrorBundle s e -- ^ Parse error bundle to display
|
||||||
|
-- -> String -- ^ Textual rendition of the bundle
|
||||||
|
-- errorBundlePretty Text.Megaparsec.Error.ParseErrorBundle {..} =
|
||||||
|
-- let (r, _) = foldl' f (id, bundlePosState) bundleErrors
|
||||||
|
-- in drop 1 (r "")
|
||||||
|
-- where
|
||||||
|
-- f :: (ShowS, Text.Megaparsec.PosState s)
|
||||||
|
-- -> Text.Megaparsec.ParseError s e
|
||||||
|
-- -> (ShowS, Text.Megaparsec.PosState s)
|
||||||
|
-- f (o, !pst) e = (o . (outChunk ++), pst')
|
||||||
|
-- where
|
||||||
|
-- (epos, sline, pst') = reachOffset (errorOffset e) pst
|
||||||
|
-- outChunk =
|
||||||
|
-- "\n" <> sourcePosPretty epos <> ":\n" <>
|
||||||
|
-- padding <> "|\n" <>
|
||||||
|
-- lineNumber <> " | " <> sline <> "\n" <>
|
||||||
|
-- padding <> "| " <> rpadding <> pointer <> "\n" <>
|
||||||
|
-- Text.Megaparsec.Error.parseErrorTextPretty e
|
||||||
|
-- lineNumber = (show . unPos . sourceLine) epos
|
||||||
|
-- padding = replicate (length lineNumber + 1) ' '
|
||||||
|
-- rpadding =
|
||||||
|
-- if pointerLen > 0
|
||||||
|
-- then replicate rpshift ' '
|
||||||
|
-- else ""
|
||||||
|
-- rpshift = unPos (sourceColumn epos) - 1
|
||||||
|
-- pointer = replicate pointerLen '^'
|
||||||
|
-- pointerLen =
|
||||||
|
-- if rpshift + elen > slineLen
|
||||||
|
-- then slineLen - rpshift + 1
|
||||||
|
-- else elen
|
||||||
|
-- slineLen = length sline
|
||||||
|
-- elen =
|
||||||
|
-- case e of
|
||||||
|
-- Text.Megaparsec.TrivialError _ Nothing _ -> 1
|
||||||
|
-- Text.Megaparsec.TrivialError _ (Just x) _ -> errorItemLength x
|
||||||
|
-- Text.Megaparsec.FancyError _ xs ->
|
||||||
|
-- Data.Set.foldl' (\a b -> max a (errorFancyLength b)) 1 xs
|
||||||
|
|
|
@ -0,0 +1,18 @@
|
||||||
|
{-| Common utilities / types for the LSP part -}
|
||||||
|
module LSP.Common(sendToClient, nextLspReqId) where
|
||||||
|
|
||||||
|
import Language.Haskell.LSP.Messages
|
||||||
|
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||||
|
|
||||||
|
import qualified Data.Aeson as J
|
||||||
|
import qualified Language.Haskell.LSP.Types as J
|
||||||
|
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||||
|
|
||||||
|
|
||||||
|
sendToClient :: FromServerMessage -> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||||
|
sendToClient msg = do
|
||||||
|
lf <- ask
|
||||||
|
liftIO $ LSP.Core.sendFunc lf msg
|
||||||
|
|
||||||
|
nextLspReqId :: ReaderT (LSP.Core.LspFuncs ()) IO J.LspId
|
||||||
|
nextLspReqId = asks LSP.Core.getNextReqId >>= liftIO
|
|
@ -0,0 +1,93 @@
|
||||||
|
module LSP.Dispatcher(dispatcher) where
|
||||||
|
|
||||||
|
import Control.Concurrent.STM.TChan
|
||||||
|
import Language.Haskell.LSP.Messages
|
||||||
|
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 LSP.Types
|
||||||
|
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||||
|
|
||||||
|
import qualified Data.Aeson as J
|
||||||
|
import qualified Language.Haskell.LSP.Types as J
|
||||||
|
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||||
|
|
||||||
|
import LSP.Common
|
||||||
|
import LSP.Handlers.Diagnostics
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
|
||||||
|
-- ! FIXME: replace logs/logm (which are just utilities) with own logging functions to make intent clearer
|
||||||
|
-- | A basic router, which reads from Client messages queue `inp` and executes appropriate actions
|
||||||
|
dispatcher :: LSP.Core.LspFuncs () -> TChan FromClientMessage -> IO ()
|
||||||
|
dispatcher lf inp = do
|
||||||
|
liftIO $ LSP.Utility.logs "inside dispatcher"
|
||||||
|
flip runReaderT lf $ forever $ do
|
||||||
|
inval <- liftIO $ atomically $ readTChan inp
|
||||||
|
case inval of
|
||||||
|
|
||||||
|
(RspFromClient rm) ->
|
||||||
|
liftIO $ LSP.Utility.logs $ "reactor:got RspFromClient:" ++ show rm
|
||||||
|
|
||||||
|
-- -------------------------------
|
||||||
|
|
||||||
|
(NotInitialized _notification) -> do
|
||||||
|
liftIO $ LSP.Utility.logm "****** reactor: processing Initialized Notification"
|
||||||
|
|
||||||
|
let
|
||||||
|
registration = J.Registration "dhall-lsp-server-registered" J.WorkspaceExecuteCommand Nothing
|
||||||
|
let registrations = J.RegistrationParams (J.List [registration])
|
||||||
|
rid <- nextLspReqId
|
||||||
|
|
||||||
|
-- client/registerCapability
|
||||||
|
sendToClient $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid registrations
|
||||||
|
|
||||||
|
-- example of showMessageRequest
|
||||||
|
-- let
|
||||||
|
-- params = J.ShowMessageRequestParams J.MtWarning "choose an option for XXX"
|
||||||
|
-- (Just [J.MessageActionItem "option a", J.MessageActionItem "option b"])
|
||||||
|
-- rid1 <- nextLspReqId
|
||||||
|
|
||||||
|
-- reactorSend $ ReqShowMessage $ fmServerShowMessageRequest rid1 params
|
||||||
|
|
||||||
|
-- -------------------------------
|
||||||
|
|
||||||
|
(NotDidOpenTextDocument notification) -> do
|
||||||
|
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidOpenTextDocument"
|
||||||
|
let
|
||||||
|
doc = notification ^. J.params
|
||||||
|
. J.textDocument
|
||||||
|
. J.uri
|
||||||
|
v = notification ^. J.params
|
||||||
|
. J.textDocument
|
||||||
|
. J.version
|
||||||
|
fileName = J.uriToFilePath doc
|
||||||
|
liftIO $ LSP.Utility.logs $ "********* fileName=" <> show fileName <> "version: " <> show v
|
||||||
|
sendDiagnostics doc (Just v)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(NotDidSaveTextDocument notification) -> do
|
||||||
|
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidSaveTextDocument"
|
||||||
|
let
|
||||||
|
doc = notification ^. J.params
|
||||||
|
. J.textDocument
|
||||||
|
. J.uri
|
||||||
|
|
||||||
|
fileName = J.uriToFilePath doc
|
||||||
|
liftIO $ LSP.Utility.logs $ "********* fileName=" ++ show fileName
|
||||||
|
sendDiagnostics doc Nothing
|
||||||
|
|
||||||
|
|
||||||
|
(NotDidCloseTextDocument req) -> do
|
||||||
|
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidCloseTextDocument"
|
||||||
|
let
|
||||||
|
doc = req ^. J.params
|
||||||
|
. J.textDocument
|
||||||
|
. J.uri
|
||||||
|
fileName = J.uriToFilePath doc
|
||||||
|
liftIO $ LSP.Utility.logs $ "********* fileName=" ++ show fileName
|
||||||
|
sendEmptyDiagnostics doc Nothing
|
||||||
|
om -> do
|
||||||
|
liftIO $ LSP.Utility.logs $ "\nIGNORING!!!\n HandlerRequest:" ++ show om
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
|
@ -0,0 +1,54 @@
|
||||||
|
{-| This module contains everything related on how LSP server handles diagnostic messages. -}
|
||||||
|
module LSP.Handlers.Diagnostics( sendEmptyDiagnostics
|
||||||
|
, sendDiagnostics
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Language.Haskell.LSP.Messages
|
||||||
|
import Language.Haskell.LSP.Diagnostics
|
||||||
|
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 LSP.Types
|
||||||
|
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||||
|
|
||||||
|
|
||||||
|
import qualified Data.Aeson as J
|
||||||
|
import qualified Language.Haskell.LSP.Types as J
|
||||||
|
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||||
|
|
||||||
|
import qualified System.IO.Unsafe
|
||||||
|
import qualified Data.Text.IO
|
||||||
|
import qualified Data.SortedList
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
|
import Backend.Dhall.Diagnostics
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: Make max number of errors parameter configurable (not rly relevant since we got 1, but still)
|
||||||
|
-- ---------------------------------------------------------------------
|
||||||
|
-- Y no method to flush particular source errors?
|
||||||
|
sendEmptyDiagnostics :: J.Uri -> Maybe Int -> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||||
|
sendEmptyDiagnostics fileUri version =
|
||||||
|
publishDiagnostics 10 fileUri version defaultDiagnosticBySource
|
||||||
|
|
||||||
|
defaultDiagnosticBySource :: DiagnosticsBySource
|
||||||
|
defaultDiagnosticBySource = Map.singleton (Just defaultDiagnosticSource) (Data.SortedList.toSortedList [])
|
||||||
|
|
||||||
|
-- | Analyze the file and send any diagnostics to the client in a
|
||||||
|
-- "textDocument/publishDiagnostics" notification
|
||||||
|
|
||||||
|
sendDiagnostics :: J.Uri -> Maybe Int -> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||||
|
sendDiagnostics fileUri version = do
|
||||||
|
let
|
||||||
|
filePath = maybe (error "can't convert uri to file path") id $ J.uriToFilePath fileUri -- !FIXME: handle non-file uris
|
||||||
|
txt <- lift $ Data.Text.IO.readFile filePath
|
||||||
|
diags' <- lift $ compilerDiagnostics filePath (J.getUri fileUri) txt
|
||||||
|
lift $ LSP.Utility.logs $ "diagnostic: " <> show diags'
|
||||||
|
publishDiagnostics 10 fileUri version (Map.union (partitionBySource diags') defaultDiagnosticBySource)
|
||||||
|
|
||||||
|
|
||||||
|
publishDiagnostics :: Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||||
|
publishDiagnostics maxToPublish uri v diags = do
|
||||||
|
lf <- ask
|
||||||
|
liftIO $ (LSP.Core.publishDiagnosticsFunc lf) maxToPublish uri v diags
|
||||||
|
|
|
@ -0,0 +1,110 @@
|
||||||
|
|
||||||
|
{-| This is the entry point for the LSP server. All calls are delegated to the haskell-lsp library
|
||||||
|
which does the heavy lifting.
|
||||||
|
-}
|
||||||
|
module LSP.Server(run) where
|
||||||
|
|
||||||
|
import Control.Concurrent(forkIO)
|
||||||
|
import Control.Concurrent.STM.TChan
|
||||||
|
import qualified GHC.IO.Exception
|
||||||
|
import qualified Control.Exception
|
||||||
|
import Data.Default
|
||||||
|
import Language.Haskell.LSP.Messages
|
||||||
|
import qualified Language.Haskell.LSP.Control as LSP.Control
|
||||||
|
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||||
|
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||||
|
|
||||||
|
import qualified Data.Aeson as J
|
||||||
|
import qualified Language.Haskell.LSP.Types as J
|
||||||
|
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||||
|
|
||||||
|
import qualified System.Log.Logger
|
||||||
|
|
||||||
|
import LSP.Dispatcher(dispatcher)
|
||||||
|
|
||||||
|
run :: Maybe String -> IO () -> IO Int
|
||||||
|
run maybeLog dispatcherProc = flip Control.Exception.catches handlers $ do
|
||||||
|
|
||||||
|
rin <- atomically newTChan :: IO (TChan FromClientMessage)
|
||||||
|
|
||||||
|
let
|
||||||
|
dp lf = do
|
||||||
|
_rpid <- forkIO $ dispatcher lf rin
|
||||||
|
dispatcherProc
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
flip Control.Exception.finally finalProc $ do
|
||||||
|
setupLogger maybeLog
|
||||||
|
LSP.Control.run (pure (Right ()), dp) (lspHandlers rin) lspOptions Nothing
|
||||||
|
-- TODO: CTRL.run takes logger as the last option, and should write LSP log into it
|
||||||
|
-- TODO: 1. make upstream logger write in the format which lsp-inspector can read
|
||||||
|
-- TODO: 2. it would be cool, if we start writing log on file creation, e.g.
|
||||||
|
-- TODO: e.g. "touch file /var/log/dhall-lsp-server/log-2018-03-12-12-45-34-fe5dk3.log to enable LSP logging"
|
||||||
|
|
||||||
|
where
|
||||||
|
handlers = [ Control.Exception.Handler ioExcept
|
||||||
|
, Control.Exception.Handler someExcept
|
||||||
|
]
|
||||||
|
finalProc = System.Log.Logger.removeAllHandlers
|
||||||
|
ioExcept (e :: Control.Exception.IOException) = error $ show $ e -- print e >> pure 1
|
||||||
|
someExcept (e :: Control.Exception.SomeException) = error $ show $ e -- print e >> pure 1
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
||||||
|
-- | sets the output logger.
|
||||||
|
-- | if no filename is provided then logger is disabled, if input is string `[OUTPUT]` then log goes to stderr,
|
||||||
|
-- | which then redirects inside VSCode to the output pane of the plugin.
|
||||||
|
setupLogger :: Maybe FilePath -> IO () -- TODO: ADD verbosity
|
||||||
|
setupLogger Nothing = pure ()
|
||||||
|
setupLogger (Just "[OUTPUT]") = LSP.Core.setupLogger Nothing [] System.Log.Logger.DEBUG
|
||||||
|
setupLogger file = LSP.Core.setupLogger file [] System.Log.Logger.DEBUG
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
syncOptions :: J.TextDocumentSyncOptions
|
||||||
|
syncOptions = J.TextDocumentSyncOptions
|
||||||
|
{ J._openClose = Just True
|
||||||
|
, J._change = Just J.TdSyncNone--J.TdSyncIncremental
|
||||||
|
, J._willSave = Just False
|
||||||
|
, J._willSaveWaitUntil = Just False
|
||||||
|
, J._save = Just $ J.SaveOptions $ Just False
|
||||||
|
}
|
||||||
|
|
||||||
|
-- Capabilities entry point
|
||||||
|
lspOptions :: LSP.Core.Options
|
||||||
|
lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
||||||
|
-- , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["lsp-hello-command"]))
|
||||||
|
-- , Core.codeLensProvider = Just (J.CodeLensOptions (Just False))
|
||||||
|
}
|
||||||
|
|
||||||
|
lspHandlers :: TChan FromClientMessage -> LSP.Core.Handlers
|
||||||
|
lspHandlers rin
|
||||||
|
= def { LSP.Core.initializedHandler = Just $ passHandler rin NotInitialized
|
||||||
|
-- , Core.renameHandler = Just $ passHandler rin ReqRename
|
||||||
|
-- , Core.hoverHandler = Just $ passHandler rin ReqHover
|
||||||
|
, LSP.Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
|
||||||
|
, LSP.Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
|
||||||
|
, LSP.Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
|
||||||
|
, LSP.Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
|
||||||
|
, LSP.Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
|
||||||
|
, LSP.Core.responseHandler = Just $ responseHandlerCb rin
|
||||||
|
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
|
||||||
|
, LSP.Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
|
||||||
|
}
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
|
passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> LSP.Core.Handler a
|
||||||
|
passHandler rin convert notification =
|
||||||
|
atomically $ writeTChan rin (convert notification)
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
|
responseHandlerCb :: TChan FromClientMessage -> LSP.Core.Handler J.BareResponseMessage
|
||||||
|
responseHandlerCb _rin resp =
|
||||||
|
LSP.Utility.logs $ ">>> got ignoring ResponseMessage:" ++ show resp
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,5 @@
|
||||||
|
module Prelude
|
||||||
|
( module Relude
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Relude
|
|
@ -0,0 +1,2 @@
|
||||||
|
main :: IO ()
|
||||||
|
main = putStrLn "Test suite not yet implemented"
|
|
@ -0,0 +1,11 @@
|
||||||
|
resolver: nightly-2018-12-17
|
||||||
|
packages:
|
||||||
|
- dhall
|
||||||
|
- dhall-bash
|
||||||
|
- dhall-json
|
||||||
|
- dhall-text
|
||||||
|
- dhall-lsp-server
|
||||||
|
nix:
|
||||||
|
packages:
|
||||||
|
- ncurses
|
||||||
|
- zlib
|
|
@ -4,6 +4,7 @@ packages:
|
||||||
- dhall-bash
|
- dhall-bash
|
||||||
- dhall-json
|
- dhall-json
|
||||||
- dhall-text
|
- dhall-text
|
||||||
|
- dhall-lsp-server
|
||||||
nix:
|
nix:
|
||||||
packages:
|
packages:
|
||||||
- ncurses
|
- ncurses
|
||||||
|
|
Loading…
Reference in New Issue