mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
hie-core/test: Dedicated test suite for hie-core (#2243)
* hie-core/test: Dedicated test suite for hie-core * Apply hlint suggestion Use System.Environment.Blank's setEnv which has a non-overwrite mode that implements precisely what we were doing with more code before. * buildifier fixes * hie-core-exe works on Windows now - ghc-paths was fixed
This commit is contained in:
parent
46a8737d82
commit
e2a424e5fc
@ -1,7 +1,12 @@
|
||||
# Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
# SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library")
|
||||
load(
|
||||
"//bazel_tools:haskell.bzl",
|
||||
"da_haskell_binary",
|
||||
"da_haskell_library",
|
||||
"da_haskell_test",
|
||||
)
|
||||
load("@os_info//:os_info.bzl", "is_windows")
|
||||
|
||||
depends = [
|
||||
@ -109,4 +114,4 @@ da_haskell_binary(
|
||||
deps = [
|
||||
"hie-core-public",
|
||||
],
|
||||
) if not is_windows else None # Disable on Windows until ghc-paths is fixed upstream
|
||||
)
|
||||
|
50
compiler/hie-core/test/BUILD.bazel
Normal file
50
compiler/hie-core/test/BUILD.bazel
Normal file
@ -0,0 +1,50 @@
|
||||
# Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
# SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
load(
|
||||
"//bazel_tools:haskell.bzl",
|
||||
"da_haskell_library",
|
||||
"da_haskell_test",
|
||||
)
|
||||
|
||||
da_haskell_library(
|
||||
name = "hie-core-testing",
|
||||
srcs = glob(["src/**/*.hs"]),
|
||||
hazel_deps = [
|
||||
"base",
|
||||
"containers",
|
||||
"haskell-lsp-types",
|
||||
"lens",
|
||||
"lsp-test",
|
||||
"parser-combinators",
|
||||
"tasty-hunit",
|
||||
"text",
|
||||
],
|
||||
src_strip_prefix = "src",
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
"//compiler/hie-core",
|
||||
],
|
||||
)
|
||||
|
||||
da_haskell_test(
|
||||
name = "hie-core-tests",
|
||||
srcs = glob(["exe/**/*.hs"]),
|
||||
data = ["//compiler/hie-core:hie-core-exe"],
|
||||
hazel_deps = [
|
||||
"base",
|
||||
"extra",
|
||||
"filepath",
|
||||
"haskell-lsp-types",
|
||||
"lsp-test",
|
||||
"tasty",
|
||||
"tasty-hunit",
|
||||
"text",
|
||||
],
|
||||
src_strip_prefix = "exe",
|
||||
deps = [
|
||||
"//compiler/hie-core",
|
||||
"//compiler/hie-core/test:hie-core-testing",
|
||||
"//libs-haskell/bazel-runfiles",
|
||||
],
|
||||
)
|
75
compiler/hie-core/test/exe/Main.hs
Normal file
75
compiler/hie-core/test/exe/Main.hs
Normal file
@ -0,0 +1,75 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Test
|
||||
import Language.Haskell.LSP.Test
|
||||
import Language.Haskell.LSP.Types
|
||||
import System.Environment.Blank (setEnv)
|
||||
import System.FilePath
|
||||
import System.IO.Extra
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import DA.Bazel.Runfiles
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain $ testGroup "HIE"
|
||||
[ testSession "open close" $ do
|
||||
doc <- openDoc' "Testing.hs" "haskell" ""
|
||||
void (message :: Session ProgressStartNotification)
|
||||
closeDoc doc
|
||||
void (message :: Session ProgressDoneNotification)
|
||||
, testSession "fix syntax error" $ do
|
||||
let content = T.unlines [ "module Testing wher" ]
|
||||
doc <- openDoc' "Testing.hs" "haskell" content
|
||||
expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
|
||||
let change = TextDocumentContentChangeEvent
|
||||
{ _range = Just (Range (Position 0 15) (Position 0 19))
|
||||
, _rangeLength = Nothing
|
||||
, _text = "where"
|
||||
}
|
||||
changeDoc doc [change]
|
||||
expectDiagnostics [("Testing.hs", [])]
|
||||
, testSession "introduce syntax error" $ do
|
||||
let content = T.unlines [ "module Testing where" ]
|
||||
doc <- openDoc' "Testing.hs" "haskell" content
|
||||
void (message :: Session ProgressStartNotification)
|
||||
let change = TextDocumentContentChangeEvent
|
||||
{ _range = Just (Range (Position 0 15) (Position 0 18))
|
||||
, _rangeLength = Nothing
|
||||
, _text = "wher"
|
||||
}
|
||||
changeDoc doc [change]
|
||||
expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
|
||||
]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Utils
|
||||
|
||||
|
||||
testSession :: String -> Session () -> TestTree
|
||||
testSession name = testCase name . run
|
||||
|
||||
|
||||
run :: Session a -> IO a
|
||||
run s = withTempDir $ \dir -> do
|
||||
let hieCoreExePath = mainWorkspace </> exe "compiler/hie-core/hie-core-exe"
|
||||
hieCoreExe <- locateRunfiles hieCoreExePath
|
||||
let cmd = unwords [hieCoreExe, "--lsp", "--cwd", dir]
|
||||
-- HIE calls getXgdDirectory which assumes that HOME is set.
|
||||
-- Only sets HOME if it wasn't already set.
|
||||
setEnv "HOME" "/homeless-shelter" False
|
||||
runSessionWithConfig conf cmd fullCaps dir s
|
||||
where
|
||||
conf = defaultConfig
|
||||
-- If you uncomment this you can see all messages
|
||||
-- which can be quite useful for debugging.
|
||||
-- { logMessages = True, logColor = False, logStdErr = True }
|
74
compiler/hie-core/test/src/Development/IDE/Test.hs
Normal file
74
compiler/hie-core/test/src/Development/IDE/Test.hs
Normal file
@ -0,0 +1,74 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module Development.IDE.Test
|
||||
( Cursor
|
||||
, cursorPosition
|
||||
, requireDiagnostic
|
||||
, expectDiagnostics
|
||||
) where
|
||||
|
||||
import Control.Applicative.Combinators
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import Language.Haskell.LSP.Test hiding (message, openDoc')
|
||||
import qualified Language.Haskell.LSP.Test as LspTest
|
||||
import Language.Haskell.LSP.Types
|
||||
import Language.Haskell.LSP.Types.Lens as Lsp
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
|
||||
-- | (0-based line number, 0-based column number)
|
||||
type Cursor = (Int, Int)
|
||||
|
||||
cursorPosition :: Cursor -> Position
|
||||
cursorPosition (line, col) = Position line col
|
||||
|
||||
requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text) -> Assertion
|
||||
requireDiagnostic actuals expected@(severity, cursor, expectedMsg) = do
|
||||
unless (any match actuals) $
|
||||
assertFailure $
|
||||
"Could not find " <> show expected <>
|
||||
" in " <> show actuals
|
||||
where
|
||||
match :: Diagnostic -> Bool
|
||||
match d =
|
||||
Just severity == _severity d
|
||||
&& cursorPosition cursor == d ^. range . start
|
||||
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
|
||||
standardizeQuotes (T.toLower $ d ^. message)
|
||||
|
||||
expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
|
||||
expectDiagnostics expected = do
|
||||
expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected
|
||||
go expected'
|
||||
where
|
||||
go m
|
||||
| Map.null m = pure ()
|
||||
| otherwise = do
|
||||
diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
|
||||
let fileUri = diagsNot ^. params . uri
|
||||
case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
|
||||
Nothing -> liftIO $ assertFailure $
|
||||
"Got diagnostics for " <> show fileUri <>
|
||||
" but only expected diagnostics for " <> show (Map.keys m)
|
||||
Just expected -> do
|
||||
let actual = diagsNot ^. params . diagnostics
|
||||
liftIO $ mapM_ (requireDiagnostic actual) expected
|
||||
liftIO $ unless (length expected == length actual) $
|
||||
assertFailure $
|
||||
"Incorrect number of diagnostics for " <> show fileUri <>
|
||||
", expected " <> show expected <>
|
||||
" but got " <> show actual
|
||||
go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
|
||||
|
||||
standardizeQuotes :: T.Text -> T.Text
|
||||
standardizeQuotes msg = let
|
||||
repl '‘' = '\''
|
||||
repl '’' = '\''
|
||||
repl '`' = '\''
|
||||
repl c = c
|
||||
in T.map repl msg
|
@ -36,6 +36,7 @@ da_haskell_test(
|
||||
deps = [
|
||||
"//compiler/damlc/daml-ide-core",
|
||||
"//compiler/hie-core",
|
||||
"//compiler/hie-core/test:hie-core-testing",
|
||||
"//libs-haskell/bazel-runfiles",
|
||||
"//libs-haskell/test-utils",
|
||||
],
|
||||
|
@ -23,7 +23,6 @@ import Control.Lens hiding (List)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson (Result(..), fromJSON)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import Language.Haskell.LSP.Test hiding (message, openDoc')
|
||||
import qualified Language.Haskell.LSP.Test as LspTest
|
||||
@ -33,52 +32,9 @@ import Network.URI
|
||||
import System.IO.Extra
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import DA.Test.Util
|
||||
import Development.IDE.Test
|
||||
import Development.IDE.Core.Rules.Daml (VirtualResourceChangedParams(..))
|
||||
|
||||
-- | (0-based line number, 0-based column number)
|
||||
type Cursor = (Int, Int)
|
||||
|
||||
cursorPosition :: Cursor -> Position
|
||||
cursorPosition (line, col) = Position line col
|
||||
|
||||
requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text) -> Assertion
|
||||
requireDiagnostic actuals expected@(severity, cursor, expectedMsg) = do
|
||||
unless (any match actuals) $
|
||||
assertFailure $
|
||||
"Could not find " <> show expected <>
|
||||
" in " <> show actuals
|
||||
where
|
||||
match :: Diagnostic -> Bool
|
||||
match d =
|
||||
Just severity == _severity d
|
||||
&& cursorPosition cursor == d ^. range . start
|
||||
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
|
||||
standardizeQuotes (T.toLower $ d ^. message)
|
||||
|
||||
expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
|
||||
expectDiagnostics expected = do
|
||||
expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected
|
||||
go expected'
|
||||
where
|
||||
go m
|
||||
| Map.null m = pure ()
|
||||
| otherwise = do
|
||||
diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
|
||||
let fileUri = diagsNot ^. params . uri
|
||||
case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
|
||||
Nothing -> liftIO $ assertFailure $
|
||||
"Got diagnostics for " <> show fileUri <>
|
||||
" but only expected diagnostics for " <> show (Map.keys m)
|
||||
Just expected -> do
|
||||
let actual = diagsNot ^. params . diagnostics
|
||||
liftIO $ mapM_ (requireDiagnostic actual) expected
|
||||
liftIO $ unless (length expected == length actual) $
|
||||
assertFailure $
|
||||
"Incorrect number of diagnostics for " <> show fileUri <>
|
||||
", expected " <> show expected <>
|
||||
" but got " <> show actual
|
||||
go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
|
||||
|
||||
damlId :: String
|
||||
damlId = "daml"
|
||||
|
Loading…
Reference in New Issue
Block a user