From e2a424e5fc248de69eb48009b1fd3fdac3ae478e Mon Sep 17 00:00:00 2001 From: Andreas Herrmann <42969706+aherrmann-da@users.noreply.github.com> Date: Mon, 22 Jul 2019 15:42:04 +0200 Subject: [PATCH] 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 --- compiler/hie-core/BUILD.bazel | 9 ++- compiler/hie-core/test/BUILD.bazel | 50 +++++++++++++ compiler/hie-core/test/exe/Main.hs | 75 +++++++++++++++++++ .../hie-core/test/src/Development/IDE/Test.hs | 74 ++++++++++++++++++ compiler/lsp-tests/BUILD.bazel | 1 + compiler/lsp-tests/src/Daml/Lsp/Test/Util.hs | 46 +----------- 6 files changed, 208 insertions(+), 47 deletions(-) create mode 100644 compiler/hie-core/test/BUILD.bazel create mode 100644 compiler/hie-core/test/exe/Main.hs create mode 100644 compiler/hie-core/test/src/Development/IDE/Test.hs diff --git a/compiler/hie-core/BUILD.bazel b/compiler/hie-core/BUILD.bazel index 5c1f63f47c..95b8eb3bdc 100644 --- a/compiler/hie-core/BUILD.bazel +++ b/compiler/hie-core/BUILD.bazel @@ -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 +) diff --git a/compiler/hie-core/test/BUILD.bazel b/compiler/hie-core/test/BUILD.bazel new file mode 100644 index 0000000000..8591ed797c --- /dev/null +++ b/compiler/hie-core/test/BUILD.bazel @@ -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", + ], +) diff --git a/compiler/hie-core/test/exe/Main.hs b/compiler/hie-core/test/exe/Main.hs new file mode 100644 index 0000000000..d4856e36ec --- /dev/null +++ b/compiler/hie-core/test/exe/Main.hs @@ -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 } diff --git a/compiler/hie-core/test/src/Development/IDE/Test.hs b/compiler/hie-core/test/src/Development/IDE/Test.hs new file mode 100644 index 0000000000..3b0fc02c51 --- /dev/null +++ b/compiler/hie-core/test/src/Development/IDE/Test.hs @@ -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 diff --git a/compiler/lsp-tests/BUILD.bazel b/compiler/lsp-tests/BUILD.bazel index 51b004d08e..f1ca1c6876 100644 --- a/compiler/lsp-tests/BUILD.bazel +++ b/compiler/lsp-tests/BUILD.bazel @@ -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", ], diff --git a/compiler/lsp-tests/src/Daml/Lsp/Test/Util.hs b/compiler/lsp-tests/src/Daml/Lsp/Test/Util.hs index 68f679066b..5b76a7ad39 100644 --- a/compiler/lsp-tests/src/Daml/Lsp/Test/Util.hs +++ b/compiler/lsp-tests/src/Daml/Lsp/Test/Util.hs @@ -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"