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

@@ -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
+)

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",
+    ],
+)

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 }

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

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",
     ],

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"