From e6be5c050ecd127cd66b159dec7b41e6ad6b72ef Mon Sep 17 00:00:00 2001 From: PanAeon Date: Tue, 26 Mar 2019 13:20:25 +0000 Subject: [PATCH] LSP. Fix import errors location. Minor clean-up. Add tests for backend/diagnostics. (#868) --- dhall-lsp-server/ChangeLog.md | 1 + dhall-lsp-server/README.md | 19 +-- dhall-lsp-server/dhall-lsp-server.cabal | 4 +- .../src/Backend/Dhall/DhallErrors.hs | 6 +- .../src/Backend/Dhall/Diagnostics.hs | 138 +++++------------- .../src/LSP/Handlers/Diagnostics.hs | 2 +- .../test/Backend/Dhall/DiagnosticsSpec.hs | 113 ++++++++++++++ dhall-lsp-server/test/Driver.hs | 1 + dhall-lsp-server/test/Spec.hs | 2 - 9 files changed, 157 insertions(+), 129 deletions(-) create mode 100644 dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs create mode 100644 dhall-lsp-server/test/Driver.hs delete mode 100644 dhall-lsp-server/test/Spec.hs diff --git a/dhall-lsp-server/ChangeLog.md b/dhall-lsp-server/ChangeLog.md index 32dea00..bfb932a 100644 --- a/dhall-lsp-server/ChangeLog.md +++ b/dhall-lsp-server/ChangeLog.md @@ -2,5 +2,6 @@ ## unreleased - whole document formatting + - correctly show location of import errors ## 0.0.1.0 - diagnostic output diff --git a/dhall-lsp-server/README.md b/dhall-lsp-server/README.md index 65e74f4..5aaab17 100644 --- a/dhall-lsp-server/README.md +++ b/dhall-lsp-server/README.md @@ -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//.local/bin`. On linux this should be `/Home//.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) diff --git a/dhall-lsp-server/dhall-lsp-server.cabal b/dhall-lsp-server/dhall-lsp-server.cabal index 50116f6..162b69d 100644 --- a/dhall-lsp-server/dhall-lsp-server.cabal +++ b/dhall-lsp-server/dhall-lsp-server.cabal @@ -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 diff --git a/dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs b/dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs index 02209ae..a6848ef 100644 --- a/dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs +++ b/dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs @@ -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" diff --git a/dhall-lsp-server/src/Backend/Dhall/Diagnostics.hs b/dhall-lsp-server/src/Backend/Dhall/Diagnostics.hs index c73ec85..7e1f3f3 100644 --- a/dhall-lsp-server/src/Backend/Dhall/Diagnostics.hs +++ b/dhall-lsp-server/src/Backend/Dhall/Diagnostics.hs @@ -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 - \ No newline at end of file diff --git a/dhall-lsp-server/src/LSP/Handlers/Diagnostics.hs b/dhall-lsp-server/src/LSP/Handlers/Diagnostics.hs index 72e833c..5946f86 100644 --- a/dhall-lsp-server/src/LSP/Handlers/Diagnostics.hs +++ b/dhall-lsp-server/src/LSP/Handlers/Diagnostics.hs @@ -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) diff --git a/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs b/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs new file mode 100644 index 0000000..f4491b7 --- /dev/null +++ b/dhall-lsp-server/test/Backend/Dhall/DiagnosticsSpec.hs @@ -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 + }] \ No newline at end of file diff --git a/dhall-lsp-server/test/Driver.hs b/dhall-lsp-server/test/Driver.hs new file mode 100644 index 0000000..d67ec9a --- /dev/null +++ b/dhall-lsp-server/test/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} \ No newline at end of file diff --git a/dhall-lsp-server/test/Spec.hs b/dhall-lsp-server/test/Spec.hs deleted file mode 100644 index a8846b3..0000000 --- a/dhall-lsp-server/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn ("Test suite not yet implemented" :: String)