ehmry/dhall-haskell
ehmry
/
dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

LSP. Fix import errors location. Minor clean-up. Add tests for backend/diagnostics. (#868)

This commit is contained in:
PanAeon 2019-03-26 13:20:25 +00:00 committed by GitHub
parent 4c9dc60b20
commit e6be5c050e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 157 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dhall-lsp-server/ChangeLog.md
View File

@ -2,5 +2,6 @@
## unreleased
- whole document formatting
- correctly show location of import errors
## 0.0.1.0
- diagnostic output

19
dhall-lsp-server/README.md
View File

@ -1,24 +1,9 @@
# 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.
For installation or development instructions, see:
* [`dhall-haskell` - `README`](https://github.com/dhall-lang/dhall-haskell/blob/master/README.md)

4
dhall-lsp-server/dhall-lsp-server.cabal
View File

@ -93,9 +93,11 @@ executable dhall-lsp-server
test-suite dhall-lsp-server-test
type: exitcode-stdio-1.0
main-is: Spec.hs
main-is: Driver.hs
other-modules:
Paths_dhall_lsp_server
Backend.Dhall.DiagnosticsSpec
hs-source-dirs:
test
default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables

6
dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs
View File

@ -102,10 +102,8 @@ simpleTypeMessage (InvalidAlternativeType k expr0) =
simpleTypeMessage (InvalidAlternative k expr0) =
"Invalid alternative"
-- ! FIXME: missing AlternativeAnnotationMismatch
-- simpleTypeMessage (AlternativeAnnotationMismatch k0 expr0 c0 k1 expr1 c1) =
-- "Alternative annotation mismatch"
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"

138
dhall-lsp-server/src/Backend/Dhall/Diagnostics.hs
View File

@ -12,7 +12,7 @@ This module is responsible for producing dhall compiler diagnostic (errors, warn
import qualified Control.Exception
import qualified Dhall
import Dhall(rootDirectory, sourceName, defaultInputSettings, inputExprWithSettings)
import Dhall.Parser(ParseError(..), Src(..))
import Dhall.Parser(ParseError(..), Src(..), SourcedException(..))
import qualified Dhall.Core
import qualified System.Exit
import qualified System.IO
@ -21,7 +21,7 @@ import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..), X)
import Dhall.Binary(DecodingFailure(..))
import Dhall.Import(Imported(..), Cycle(..), ReferentiallyOpaque(..),
MissingFile, MissingEnvironmentVariable, MissingImports )
MissingFile, MissingEnvironmentVariable, MissingImports(..) )
import qualified Data.Text as T
@ -44,34 +44,27 @@ import Language.Haskell.LSP.Types(
, 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
-- TODO: type errors span across whitespace after the expression
-- TODO: don't use show for import msgs (requires alternative typeclass)
-- TODO: file consisting with only comments shouldn't produce an error msg
compilerDiagnostics :: FilePath -> Text -> IO [Diagnostic]
compilerDiagnostics path 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?
isEmpty = T.null $ T.strip txt
ast = if isEmpty
then pure []
else [] <$ inputExprWithSettings settings txt
handle = Control.Exception.handle allErrors
. Control.Exception.handle decodingFailure
. handleImportErrors txt
. Control.Exception.handle missingImports
. Control.Exception.handle parseErrors
. Control.Exception.handle importErrors
. Control.Exception.handle moduleErrors
. Control.Exception.handle typeErrors
allErrors e = do
@ -100,73 +93,52 @@ compilerDiagnostics path filePath txt = handle ast
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
missingImports (SourcedException src e) = do
let _ = e :: MissingImports
pure [Diagnostic {
_range = sourceToRange src
, _severity = Just DsError
, _source = Just defaultDiagnosticSource
, _code = Nothing
, _message = removeAsciiColors $ show e
, _relatedInformation = Nothing
}]
typeErrors 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
, _message = (simpleTypeMessage msg)
, _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
Dhall.Core.Note src _ -> sourceToRange src
_ -> error "Expected note" -- FIXME: either justify this error or provide a default case
where
unPos = Text.Megaparsec.unPos
sourcePosToRange :: Text.Megaparsec.SourcePos -> Text.Megaparsec.SourcePos -> Range
sourcePosToRange (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))
where
unPos = Text.Megaparsec.unPos
sourceToRange :: Src -> Range
sourceToRange (Src start end _) = sourcePosToRange start end
---------------------- Megaparsec utils: ----------------------------------------
-- see Text.Megaparsec.Error::errorBundlePretty for reference
errorBundleToDiagnostics
:: forall s e. ( Text.Megaparsec.Stream s
, Text.Megaparsec.Error.ShowErrorComponent e
@ -216,45 +188,3 @@ errorFancyLength :: Text.Megaparsec.ShowErrorComponent e => Text.Megaparsec.Erro
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

2
dhall-lsp-server/src/LSP/Handlers/Diagnostics.hs
View File

@ -42,7 +42,7 @@ 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
diags' <- lift $ compilerDiagnostics filePath txt
lift $ LSP.Utility.logs $ "diagnostic: " <> show diags'
publishDiagnostics 10 fileUri version (Map.union (partitionBySource diags') defaultDiagnosticBySource)

113
dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs Normal file
View File

@ -0,0 +1,113 @@
module Backend.Dhall.DiagnosticsSpec where
import Test.Tasty.Hspec
import Language.Haskell.LSP.Types(
Diagnostic(..)
, Range(..)
, DiagnosticSeverity(..)
, DiagnosticSource(..)
, DiagnosticRelatedInformation(..)
, Position(..)
)
import Backend.Dhall.Diagnostics
import qualified Data.Text
import qualified Data.Text.IO
spec_prelude :: Spec
spec_prelude = do
describe "Backend.Dhall.Diagnostics" $ do
it "should produce an empty diagnostics for an empty file" $ do
rs <- compilerDiagnostics "./empty.txt" ""
rs `shouldBe` ([])
it "should produce an empty diagnostics for a correct file (sanity check)" $ do
traverse_ (\x -> x `shouldReturn` []) (getDiagnostics <$> successImports)
it "should produce correct diagnostics for various missing imports" $ do
getDiagnostics "../dhall/dhall-lang/tests/import/failure/missing.dhall" `shouldReturn`
(mkDiagnostics "\nError: No valid imports" (0,0) (1,0))
getDiagnostics "../dhall/dhall-lang/tests/import/failure/alternativeEnv.dhall" `shouldReturn`
(mkDiagnostics ("\nError: Failed to resolve imports. Error list:\n\n\n\8627 env:UNSET1 as Text\n\n" <>
"Error: Missing environment variable\n\n\8627 UNSET1\n\n\n\8627 env:UNSET2\n\n" <>
"Error: Missing environment variable\n\n\8627 UNSET2\n\n\n\8627 env:UNSET3\n\n" <>
"Error: Missing environment variable\n\n\8627 UNSET3\n") (0,0) (1,0))
getDiagnostics "../dhall/dhall-lang/tests/import/failure/alternativeEnvMissing.dhall" `shouldReturn`
(mkDiagnostics "\n\8627 env:UNSET\n\nError: Missing environment variable\n\n\8627 UNSET" (0,0) (1,0))
getDiagnostics "../dhall/dhall-lang/tests/import/failure/cycle.dhall" `shouldReturn`
(mkDiagnostics ("\n\8627 ./../dhall/dhall-lang/tests/import/data/cycle.dhall\n" <>
" \8627 ./../dhall/dhall-lang/tests/import/failure/cycle.dhall\n\n" <>
"Cyclic import: ../data/cycle.dhall") (0,0) (1,0))
getDiagnostics "../dhall/dhall-lang/tests/import/failure/referentiallyInsane.dhall" `shouldReturn`
(mkDiagnostics ("\n\8627 https://raw.githubusercontent.com/dhall-lang/dhall-lang/master" <>
"/tests/import/data/referentiallyOpaque.dhall\n\n" <>
"Referentially opaque import: env:HOME as Text") (19,0) (20,0))
it "should produce correct diagnostic for various parser errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/boundBuiltins.dhall" `shouldReturn`
(mkDiagnostics "expecting label or whitespace\n" (5,8) (5,9))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/doubleBoundsNeg.dhall" `shouldReturn`
(mkDiagnostics "double out of bounds\n" (0,0) (0,1))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/doubleBoundsPos.dhall" `shouldReturn`
(mkDiagnostics "double out of bounds\n" (0,0) (0,1))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/importAccess.dhall" `shouldReturn`
(mkDiagnostics "unexpected 'h'\nexpecting '/'\n" (0,14) (0,15))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/incompleteIf.dhall" `shouldReturn`
(mkDiagnostics "unexpected end of input\nexpecting expression or whitespace\n" (10,0) (10,1))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/mandatoryNewline.dhall" `shouldReturn`
(mkDiagnostics "unexpected \"AB\"\nexpecting crlf newline or newline\n" (1,2) (1,4))
getDiagnostics "../dhall/dhall-lang/tests/parser/failure/missingSpace.dhall" `shouldReturn`
(mkDiagnostics ("\n\8627 ./../dhall/dhall-lang/tests/parser/failure/example.dhall\n\n" <>
"Error: Missing file /Users/edevi86/lab/haskell/dhall-haskell/dhall-l" <>
"sp-server/../dhall/dhall-lang/tests/parser/failure/example.dhall") (1,0) (1,15))
it "should produce correct diagnostic for various typecheck errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/combineMixedRecords.dhall" `shouldReturn`
(mkDiagnostics "Record mismatch" (0,0) (1,0))
it "should produce correct diagnostic for various typecheck errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/duplicateFields.dhall" `shouldReturn`
(mkDiagnostics "duplicate field: a\n" (0,15) (0,16))
it "should produce correct diagnostic for various typecheck errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/hurkensParadox.dhall" `shouldReturn`
(mkDiagnostics "\10096Sort\10097 has no type, kind, or sort" (6,4) (49,0))
it "should produce correct diagnostic for various typecheck errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/mixedUnions.dhall" `shouldReturn`
(mkDiagnostics "Alternative annotation mismatch" (0,0) (1,0))
it "should produce correct diagnostic for various typecheck errors" $ do
getDiagnostics "../dhall/dhall-lang/tests/typecheck/failure/preferMixedRecords.dhall" `shouldReturn`
(mkDiagnostics "Record mismatch" (0,0) (1,0))
getDiagnostics :: FilePath -> IO [Diagnostic]
getDiagnostics path = do
text <- Data.Text.IO.readFile path
compilerDiagnostics path text
successImports = [ "../dhall/dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall"
, "../dhall/dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall"
, "../dhall/dhall-lang/tests/import/success/alternativeNaturalA.dhall"
, "../dhall/dhall-lang/tests/import/success/asTextA.dhall"
, "../dhall/dhall-lang/tests/import/success/fieldOrderA.dhall"
, "../dhall/dhall-lang/tests/import/success/alternativeEnvNaturalB.dhall"
, "../dhall/dhall-lang/tests/import/success/alternativeEnvSimpleB.dhall"
, "../dhall/dhall-lang/tests/import/success/alternativeNaturalB.dhall"
, "../dhall/dhall-lang/tests/import/success/asTextB.dhall"
, "../dhall/dhall-lang/tests/import/success/fieldOrderB.dhall"]
mkDiagnostics msg (sl, sc) (el, ec) = [
Diagnostic {
_range = Range {
_start = Position {_line = sl, _character = sc}
, _end = Position {_line = el, _character = ec}
}
, _severity = Just DsError
, _code = Nothing
, _source = Just "dhall-lsp-server"
, _message = msg
, _relatedInformation = Nothing
}]

1
dhall-lsp-server/test/Driver.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF tasty-discover #-}

2
dhall-lsp-server/test/Spec.hs
View File

@ -1,2 +0,0 @@
main :: IO ()
main = putStrLn ("Test suite not yet implemented" :: String)