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

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

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

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

dhall-lsp-server/src/Backend/Dhall/DhallErrors.hs

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

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
+-- TODO: type errors span across whitespace after the expression
---  Dhall.Binary.DecodingFailure
+-- TODO: don't use show for import msgs (requires alternative typeclass)
---  Dhall.Import(Cycle, ReferentiallyOpaque, MissingFile, MissingEnvironmentVariable, MissingImports,
+-- TODO: file consisting with only comments shouldn't produce an error msg
---   HashMismatch, CannotImportHTTPURL)
+compilerDiagnostics :: FilePath -> Text -> IO [Diagnostic]
--- !FIXME: (aside) VSCode multiselection expand selects first world only
+compilerDiagnostics path txt = handle ast
-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?
+    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 typeErrors
-             . Control.Exception.handle moduleErrors
              
     
     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
+    missingImports (SourcedException src e) = do
-      let _ = e :: TypeError Src X
+      let _ = e :: MissingImports
-          numLines = length $ T.lines txt
+      pure [Diagnostic {
-      System.IO.hPrint System.IO.stderr (show ps)
+             _range = sourceToRange src
-      pure [ Diagnostic {
+           , _severity = Just DsError
-               _range = Range (Position 0 0) (Position numLines 0) -- getSourceRange e
+           , _source = Just defaultDiagnosticSource
-             , _severity = Just DsError
+           , _code = Nothing
-             , _source = Just defaultDiagnosticSource
+           , _message = removeAsciiColors $ show e
-             , _code = Nothing
+           , _relatedInformation = Nothing
-             , _message =  ("import error: " <> (show e)) -- FIXME: simple show for import msgs
+           }]
-             , _relatedInformation = Nothing
+    typeErrors e = do
-             }]
-    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
+      , _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) _) _ -> 
+                Dhall.Core.Note src _ -> sourceToRange src
-                  Range (Position (unPos bl - 1) (unPos bc - 1)) (Position (unPos el - 1) (unPos ec - 1))
+                _        -> error  "Expected note"  -- FIXME: either justify this error or provide a default case
-                _        -> error  "expected note" -- $ Range (Position 0 0) (Position (negate 1) 0) -- FIXME: 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
- 

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)
 

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
+  }]

dhall-lsp-server/test/Driver.hs

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

dhall-lsp-server/test/Spec.hs

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