Testlib decompose 2

tests/app/Spec/Tests/Haskell/CodeActions.hs

@@ -11,10 +11,11 @@ import Language.LSP.Test hiding (message)
 import Spec.Tests.Haskell.Common
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 import UnliftIO.Timeout
 
 
-tests :: (LspContext context m) => Text -> SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => Text -> SpecFree context m ()
 tests ghcPackage = describe "Code actions" $ do
   it "gets no code actions for putStrLn" $ doNotebookSession lsName codeActionsCode $ \filename -> do
     ident <- openDoc filename "haskell"

tests/app/Spec/Tests/Haskell/Diagnostics.hs

@@ -21,9 +21,10 @@ import Test.Sandwich as Sandwich
 import TestLib.JupyterRunnerContext
 import TestLib.LSP
 import TestLib.NixEnvironmentContext
+import TestLib.Types
 
 
-tests :: (LspContext context m) => Text -> Text -> SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => Text -> Text -> SpecFree context m ()
 tests ghcPackage lsName = describe "Diagnostics" $ do
   describe "Foo.hs" $ do
     testDiagnosticsLabelDesired "Out of scope variable" lsName "Foo.hs" Nothing

tests/app/Spec/Tests/Haskell/DocumentHighlight.hs

@@ -13,9 +13,10 @@ import Language.LSP.Test hiding (message)
 import Spec.Tests.Haskell.Common
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Document highlight" $ do
   it "foo (.ipynb)" $ doNotebookSession lsName documentHighlightCode $ \filename -> do
     ident <- openDoc filename "haskell"

tests/app/Spec/Tests/Haskell/Hover.hs

@@ -11,9 +11,10 @@ import Language.LSP.Test hiding (message)
 import Spec.Tests.Haskell.Common
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Hover" $ do
   it "hovers foo" $ doNotebookSession lsName hoverCode $ \filename -> do
     ident <- openDoc filename "haskell"

tests/app/Spec/Tests/Haskell/Statements.hs

@@ -10,10 +10,11 @@ import Spec.Tests.Haskell.Common
 import Spec.Tests.Haskell.DocumentHighlight (documentHighlightResults)
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 import UnliftIO.Timeout
 
 
-tests :: (LspContext context m) => Text -> SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => Text -> SpecFree context m ()
 tests ghcPackage = describe "Statements" $ do
   describe "Single-line" $ do
     it "doesn't choke" $ doNotebookSession lsName statementsCode $ \filename -> do

tests/app/Spec/Tests/Haskell/Symbols.hs

@@ -8,10 +8,11 @@ import Spec.Tests.Haskell.Common
 import Spec.Tests.Haskell.DocumentHighlight (documentHighlightCode)
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 import UnliftIO.Timeout
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Symbols" $ do
   it "symbols" $ doNotebookSession lsName documentHighlightCode $ \filename -> do
     ident <- openDoc filename "haskell"

tests/app/Spec/Tests/Julia/Diagnostics.hs

@@ -8,9 +8,10 @@ import Data.Text as T
 import Language.LSP.Protocol.Types
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => Text -> SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => Text -> SpecFree context m ()
 tests lsName = describe "Diagnostics" $ do
   testDiagnostics'' "flags a simple missing reference" lsName "test.jl" (Just "julia") [i|printlnzzzz("HI")|] [] $ \diagnostics -> do
     assertDiagnosticRanges' diagnostics [(Range (Position 0 0) (Position 0 11), Nothing, "Missing reference: printlnzzzz")]

tests/app/Spec/Tests/Rust/Changes.hs

@@ -12,9 +12,10 @@ import Language.LSP.Test
 import Test.Sandwich as Sandwich
 import Test.Sandwich.Waits (waitUntil)
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Changes" $ do
   it [i|Simple change|] $ doSession' "main.ipynb" "rust-analyzer" [i|println("hi");|] $ \filename -> do
     ident <- openDoc filename "haskell"

tests/app/Spec/Tests/Rust/Completion.hs

@@ -11,9 +11,10 @@ import Safe
 import Test.Sandwich as Sandwich
 import Test.Sandwich.Waits (waitUntil)
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Completions" $ do
   forM_ ["main.ipynb", "test.rs"] $ \doc -> do
     it [i|(#{doc}) Completes printl to println!|] $ doSession' doc "rust-analyzer" [i|printl|] $ \filename -> do

tests/app/Spec/Tests/Rust/Diagnostics.hs

@@ -9,9 +9,10 @@ import qualified Language.LSP.Protocol.Lens as LSP
 import Language.LSP.Protocol.Types
 import Test.Sandwich as Sandwich
 import TestLib.LSP
+import TestLib.Types
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Diagnostics" $ do
   testDiagnostics "rust-analyzer" "main.ipynb" Nothing [__i|printlnz!("Hello world");
                                                            |] $ \diagnostics -> do

tests/app/Spec/Tests/Rust/Hovers.hs

@@ -9,24 +9,25 @@ import Language.LSP.Test
 import Test.Sandwich as Sandwich
 import Test.Sandwich.Waits (waitUntil)
 import TestLib.LSP
+import TestLib.Types
 import UnliftIO.Exception
 
 
-tests :: (LspContext context m) => SpecFree context m ()
+tests :: (LspContext context m, HasNixEnvironment context) => SpecFree context m ()
 tests = describe "Hovers" $ do
   forM_ ["main.ipynb", "test.rs"] $ \doc -> do
     it [i|hovers println! (#{doc})|] $ doSession' doc "rust-analyzer" [i|println!("hi")|] $ \filename -> do
       ident <- openDoc filename "haskell"
 
       waitUntil 60 $
-        handle handleSessionException $ do
+        handle handleSessionException' $ do
           hover <- getHoverOrException ident (Position 0 1)
           allHoverText hover `textShouldContain` [i|Prints to the standard output|]
 
 
 
 -- | We may get an UnexpectedResponseError from rust-analyzer, while it's indexing (?)
 -- Not sure why, but rethrow it as a sandwich FailureReason so the waitUntil keeps trying.
-handleSessionException :: MonadIO m => SessionException -> m ()
-handleSessionException (UnexpectedResponseError lspId err) = expectationFailure [i|LSP UnexpectedResponseError: #{lspId}, #{err}|]
-handleSessionException x = throwIO x
+handleSessionException' :: MonadIO m => SessionException -> m ()
+handleSessionException' (UnexpectedResponseError lspId err) = expectationFailure [i|LSP UnexpectedResponseError: #{lspId}, #{err}|]
+handleSessionException' x = throwIO x

tests/app/Spec/Tests/Spellchecker.hs

@@ -29,7 +29,9 @@ otherConfig = [
 tests :: TopSpec
 tests = describe "Spellchecker" $ introduceNixEnvironment [] otherConfig "Spellchecker env" $ introduceJustBubblewrap $ do
   it "Gets diagnostics and a working code action" $ do
-    withLspSession' id "spellchecker" "test.md" [i|\# This is mispelled|] [] $ \lspHomeDir -> do
+    lspConfig <- findLspConfig "spellchecker"
+    (pathToUse, closure) <- getPathAndNixEnvironmentClosure
+    withLspSession lspConfig pathToUse closure "test.md" [i|\# This is mispelled|] [] $ \lspHomeDir -> do
       ident <- openDoc "test.md" "spellchecker"
       waitUntil 300.0 $ do
         diagnostics <- waitForDiagnostics
@@ -49,8 +51,10 @@ tests = describe "Spellchecker" $ introduceNixEnvironment [] otherConfig "Spellc
         liftIO (T.readFile datPath) >>= (`shouldBe` "mispelled\n")
 
   it "Uses a personal dictionary on startup" $ do
+    lspConfig <- findLspConfig "spellchecker"
+    (pathToUse, closure) <- getPathAndNixEnvironmentClosure
     let extraFiles = [(".codedown/personal-dictionary.dat", "mispelled\n")]
-    withLspSession' id "spellchecker" "test.md" [i|\# This is mispelled|] extraFiles $ \_homeDir -> do
+    withLspSession' id lspConfig pathToUse closure "test.md" [i|\# This is mispelled|] extraFiles $ \_homeDir -> do
       _ident <- openDoc "test.md" "spellchecker"
       waitUntil 300.0 $ do
         diagnostics <- waitForDiagnostics

tests/src/TestLib/LSP.hs

@@ -11,8 +11,8 @@ import Control.Lens hiding (List)
 import Control.Monad
 import Control.Monad.Catch as C (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.IO.Unlift
-import Control.Monad.Logger (MonadLoggerIO)
-import Control.Monad.Trans (lift)
+import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
+import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson as A
 import Data.Aeson.TH as A
@@ -85,37 +85,46 @@ type LspContext ctx m = (
   , MonadMask m
 
   , HasBaseContext ctx
-  , HasNixEnvironment ctx
   , HasMaybeBubblewrap ctx
   )
 
 doNotebookSession :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => Text -> Text -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
 doNotebookSession = doSession' "main.ipynb"
 
 doSession' :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => Text -> Text -> Text -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
-doSession' filename lsName codeToUse cb = do
-  withLspSession lsName (T.unpack filename) codeToUse [] $ \_homeDir -> do
+doSession' filename lsName codeToUse cb = doSession'' filename lsName codeToUse [] cb
+
+doSession'' :: (
+  LspContext ctx m, HasNixEnvironment ctx
+  ) => Text -> Text -> Text -> [(FilePath, B.ByteString)] -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
+doSession'' filename lsName codeToUse extraFiles cb = do
+  lspConfig <- findLspConfig lsName
+  (pathToUse, closure) <- getPathAndNixEnvironmentClosure
+  withLspSession lspConfig pathToUse closure (T.unpack filename) codeToUse extraFiles $ \_homeDir -> do
     cb (T.unpack filename)
 
 testDiagnostics :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => Text -> FilePath -> Maybe LanguageKind -> Text -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
 testDiagnostics name filename maybeLanguageId codeToTest = testDiagnostics' name filename maybeLanguageId codeToTest []
 
 testDiagnostics' :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => Text -> FilePath -> Maybe LanguageKind -> Text -> [(FilePath, B.ByteString)] -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
 testDiagnostics' name filename maybeLanguageId codeToTest = testDiagnostics'' [i|#{name}, #{filename} with #{show codeToTest} (diagnostics)|] name filename maybeLanguageId codeToTest
 
 testDiagnosticsLabelDesired :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => String -> Text -> FilePath -> Maybe LanguageKind -> Text -> ([Diagnostic] -> Bool) -> SpecFree ctx m ()
-testDiagnosticsLabelDesired label name filename maybeLanguageId codeToTest cb = it label $
-  withLspSession' id name filename codeToTest [] $ \_homeDir -> do
+testDiagnosticsLabelDesired label name filename maybeLanguageId codeToTest cb = it label $ do
+  lspConfig <- findLspConfig name
+  (pathToUse, closure) <- getPathAndNixEnvironmentClosure
+
+  withLspSession' id lspConfig pathToUse closure filename codeToTest [] $ \_homeDir -> do
     _ <- openDoc filename (fromMaybe (LanguageKind_Custom name) maybeLanguageId)
 
     lastSeenDiagsVar <- newTVarIO mempty
@@ -136,15 +145,18 @@ testDiagnosticsLabelDesired label name filename maybeLanguageId codeToTest cb =
                  loop newDiags
 
 testDiagnosticsLabel :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => String -> Text -> FilePath -> Maybe LanguageKind -> Text -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
 testDiagnosticsLabel label name filename maybeLanguageId codeToTest = testDiagnostics'' label name filename maybeLanguageId codeToTest []
 
 testDiagnostics'' :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => String -> Text -> FilePath -> Maybe LanguageKind -> Text -> [(FilePath, B.ByteString)] -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
 testDiagnostics'' label name filename maybeLanguageId codeToTest extraFiles cb = it label $ do
-  withLspSession' id name filename codeToTest extraFiles $ \_homeDir -> do
+  lspConfig <- findLspConfig name
+  (pathToUse, closure) <- getPathAndNixEnvironmentClosure
+
+  withLspSession' id lspConfig pathToUse closure filename codeToTest extraFiles $ \_homeDir -> do
     _ <- openDoc filename (fromMaybe (LanguageKind_Custom name) maybeLanguageId)
 
     lastSeenDiagsVar <- newIORef mempty
@@ -157,41 +169,33 @@ testDiagnostics'' label name filename maybeLanguageId codeToTest extraFiles cb =
         logError [i|Exception in testDiagnostics'': #{e}.\n\nLast seen diagnostics: #{A.encode lastSeenDiags}|]
 
 itHasHoverSatisfying :: (
-  LspContext ctx m
+  LspContext ctx m, HasNixEnvironment ctx
   ) => Text -> FilePath -> Maybe LanguageKind -> Text -> Position -> (Hover -> ExampleT ctx m ()) -> SpecFree ctx m ()
 itHasHoverSatisfying name filename maybeLanguageId codeToTest pos cb = it [i|#{name}: #{show codeToTest} (hover)|] $ do
-  withLspSession name filename codeToTest [] $ \_homeDir -> do
+  lspConfig <- findLspConfig name
+  (pathToUse, closure) <- getPathAndNixEnvironmentClosure
+
+  withLspSession lspConfig pathToUse closure filename codeToTest [] $ \_homeDir -> do
     ident <- openDoc filename (fromMaybe (LanguageKind_Custom name) maybeLanguageId)
     getHover ident pos >>= \case
       Nothing -> expectationFailure [i|Expected a hover.|]
       Just x -> lift $ cb x
 
 withLspSession :: (
   LspContext ctx m
-  ) => Text -> FilePath -> Text -> [(FilePath, B.ByteString)] -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
-withLspSession = withLspSession' (handle (\(e :: SessionException) -> expectationFailure [i|LSP session failed with SessionException: #{e}|]))
+  ) => LanguageServerConfig -> FilePath -> [FilePath] -> FilePath -> Text -> [(FilePath, B.ByteString)] -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
+withLspSession = withLspSession' handleSessionException
+
+handleSessionException :: MonadUnliftIO m => ExampleT ctx m a -> ExampleT ctx m a
+handleSessionException = handle (\(e :: SessionException) -> expectationFailure [i|LSP session failed with SessionException: #{e}|])
 
 withLspSession' :: (
   LspContext ctx m
-  ) => (ExampleT ctx m a -> ExampleT ctx m a) -> Text -> FilePath -> Text -> [(FilePath, B.ByteString)] -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
-withLspSession' handleFn name filename codeToTest extraFiles session = do
+  ) => (ExampleT ctx m a -> ExampleT ctx m a) -> LanguageServerConfig -> FilePath -> [FilePath] -> FilePath -> Text -> [(FilePath, B.ByteString)] -> (FilePath -> Session (ExampleT ctx m) a) -> ExampleT ctx m a
+withLspSession' handleFn config pathToUse fullClosure filename codeToTest extraFiles session = do
   Just currentFolder <- getCurrentFolder
 
-  languageServersPath <- (</> "lib" </> "codedown" </> "language-servers") <$> getContext nixEnvironment
-  languageServerFiles <- filter (\x -> ".yaml" `T.isSuffixOf` T.pack x) <$> listDirectory languageServersPath
-  lspConfigs :: [LanguageServerConfig] <- (mconcat <$>) $ forM languageServerFiles $ \((languageServersPath </>) -> path) -> do
-    liftIO (A.eitherDecodeFileStrict path) >>= \case
-      Left err -> expectationFailure [i|Failed to decode language server path '#{path}': #{err}|]
-      Right x -> return x
-
-  config <- case L.find (\x -> lspConfigName x == name) lspConfigs of
-    Nothing -> expectationFailure [i|Couldn't find LSP config: #{name}. Had: #{fmap lspConfigName lspConfigs}|]
-    Just x -> return x
-  info [i|LSP config: #{A.encode config}|]
-
   homeDir <- liftIO $ createTempDirectory currentFolder "home"
-  pathToUse <- bracket (openFile "/dev/null" WriteMode) hClose $ \devNullHandle ->
-    (T.unpack . T.strip . T.pack) <$> readCreateProcess ((proc "nix" ["run", ".#print-basic-path"]) { std_err = UseHandle devNullHandle }) ""
 
   forM_ extraFiles $ \(path, bytes) -> do
     unless (isAbsolute path) $ do
@@ -220,16 +224,6 @@ withLspSession' handleFn name filename codeToTest extraFiles session = do
                            , cwd = Just homeDir }
       return (proc cmd args, modifyCp)
     Just bwrapBinary -> do
-      -- Get the full closure of the Nix environment and jupyter runner
-      nixEnv <- getContext nixEnvironment
-      fullClosure <- (Prelude.filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (
-        proc "nix" (["path-info", "-r"
-                    , nixEnv
-                    ]
-                    <> (splitSearchPath pathToUse)
-                   )
-        ) ""
-
       let bwrapArgs = ["--tmpfs", "/tmp"
                       , "--bind", homeDir, homeDir
                       , "--clearenv"
@@ -241,7 +235,7 @@ withLspSession' handleFn name filename codeToTest extraFiles session = do
                       , "--proc", "/proc"
                       , "--dev", "/dev"
                       ]
-                      <> mconcat [["--ro-bind", x, x] | x <- fmap T.unpack fullClosure]
+                      <> mconcat [["--ro-bind", x, x] | x <- fullClosure]
                       <> mconcat [["--setenv", T.unpack n, T.unpack v] | (n, v) <- M.toList (fromMaybe mempty (lspConfigEnv config))]
                       <> ["--"]
                       <> (cmd : args)
@@ -260,6 +254,50 @@ withLspSession' handleFn name filename codeToTest extraFiles session = do
 
   handleFn $ runSessionWithConfigCustomProcess modifyCp sessionConfig cp caps homeDir (session homeDir)
 
+findLspConfig :: (
+  MonadIO m, MonadLogger m, MonadReader context m, Sandwich.HasLabel context "nixEnvironment" FilePath
+  ) => Text -> m LanguageServerConfig
+findLspConfig name = do
+  languageServersPath <- (</> "lib" </> "codedown" </> "language-servers") <$> getContext nixEnvironment
+  languageServerFiles <- filter (\x -> ".yaml" `T.isSuffixOf` T.pack x) <$> listDirectory languageServersPath
+  lspConfigs :: [LanguageServerConfig] <- (mconcat <$>) $ forM languageServerFiles $ \((languageServersPath </>) -> path) -> do
+    liftIO (A.eitherDecodeFileStrict path) >>= \case
+      Left err -> expectationFailure [i|Failed to decode language server path '#{path}': #{err}|]
+      Right x -> return x
+
+  config <- case L.find (\x -> lspConfigName x == name) lspConfigs of
+    Nothing -> expectationFailure [i|Couldn't find LSP config: #{name}. Had: #{fmap lspConfigName lspConfigs}|]
+    Just x -> do
+      info [i|LSP config: #{A.encode x}|]
+      return x
+
+  return config
+
+getBasicPath :: (
+  MonadUnliftIO m, MonadLogger m, MonadReader context m, Sandwich.HasLabel context "nixEnvironment" FilePath
+  ) => m FilePath
+getBasicPath = do
+  bracket (openFile "/dev/null" WriteMode) hClose $ \devNullHandle ->
+    (T.unpack . T.strip . T.pack) <$> readCreateProcess ((proc "nix" ["run", ".#print-basic-path"]) { std_err = UseHandle devNullHandle }) ""
+
+getPathAndNixEnvironmentClosure :: (
+  MonadUnliftIO m, MonadLogger m, MonadReader context m, Sandwich.HasLabel context "nixEnvironment" FilePath
+  ) => m (FilePath, [FilePath])
+getPathAndNixEnvironmentClosure = do
+  pathToUse <- getBasicPath
+
+  -- Get the full closure of the Nix environment and jupyter runner
+  nixEnv <- getContext nixEnvironment
+  closure <- (fmap T.unpack . Prelude.filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (
+    proc "nix" (["path-info", "-r"
+                , nixEnv
+                ]
+                <> (splitSearchPath pathToUse)
+               )
+    ) ""
+
+  return (pathToUse, closure)
+
 assertDiagnosticRanges :: (HasCallStack, MonadIO m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text))] -> ExampleT ctx m ()
 assertDiagnosticRanges diagnostics desired = if
   | found == desired -> return ()