Add tests for hover info

ChrisPenner · ChrisPenner · commit 4e0f9f5ac060 · 2025-04-23T12:18:35.000-07:00
diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml
@@ -10,6 +10,7 @@ dependencies:
   - unison-parser-typechecker
   - unison-prelude
   - megaparsec
+  - unliftio
   - directory
 
 library:
@@ -98,7 +99,6 @@ library:
     - unison-util-base32hex
     - unison-util-recursion
     - unison-util-relation
-    - unliftio
     - uuid
     - vector
     - wai
@@ -119,7 +119,9 @@ tests:
       - extra
       - here
       - lens
+      - lsp
       - lsp-types
+      - mtl
       - temporary
       - these
       - unison-cli
diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs
@@ -1,6 +1,17 @@
 {-# LANGUAGE RecordWildCards #-}
 
-module Unison.LSP.FileAnalysis where
+module Unison.LSP.FileAnalysis
+  ( checkFileByUri,
+    checkFileContents,
+    getFileAnalysis,
+    ppedForFile,
+    getFileSummary,
+    ppedForFileHelper,
+    fileAnalysisWorker,
+    getFileDefLocations,
+    getFileNames,
+  )
+where
 
 import Control.Lens
 import Control.Monad.Reader
@@ -76,14 +87,20 @@ import Unison.Var qualified as Var
 import UnliftIO.STM
 import Witherable
 
--- | Lex, parse, and typecheck a file.
-checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis)
-checkFile doc = runMaybeT do
-  pp <- lift getCurrentProjectPath
+-- | Lex, parse, and typecheck a file using a VFS URI
+checkFileByUri :: (HasUri d Uri, Lspish m) => d -> m (Maybe FileAnalysis)
+checkFileByUri doc = runMaybeT do
   let fileUri = doc ^. uri
   (fileVersion, contents) <- VFS.getFileContents fileUri
+  let sourceName = getUri $ fileUri
+  checkFileContents fileUri sourceName fileVersion contents
+
+-- | Lex, parse, and typecheck a file.
+-- This is split off for easier testing without needing to mock the VFS.
+checkFileContents :: (Lspish m) => Uri -> Text -> FileVersion -> Text -> MaybeT m FileAnalysis
+checkFileContents fileUri sourceName fileVersion contents = do
+  pp <- lift getCurrentProjectPath
   parseNames <- lift getCurrentNames
-  let sourceName = getUri $ doc ^. uri
   let lexedSource@(srcText, tokens) = (contents, L.lexer (Text.unpack sourceName) (Text.unpack contents))
   let ambientAbilities = []
   cb <- asks codebase
@@ -131,8 +148,8 @@ checkFile doc = runMaybeT do
                       _ -> mempty
             pure (localBindings, typecheckingNotes, Just parsedFile, maybeTypecheckedFile)
 
-  filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile
-  (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes
+  filePPED <- ppedForFileHelper parsedFile typecheckedFile
+  (errDiagnostics, codeActions) <- analyseFile fileUri srcText filePPED notes
   let codeActionRanges =
         codeActions
           & foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges)
@@ -143,7 +160,7 @@ checkFile doc = runMaybeT do
   let tokenMap = getTokenMap tokens
   conflictWarningDiagnostics <-
     fold <$> for fileSummary \fs ->
-      lift $ computeConflictWarningDiagnostics fileUri fs
+      computeConflictWarningDiagnostics fileUri fs
   let diagnosticRanges =
         (errDiagnostics <> conflictWarningDiagnostics <> unusedBindingDiagnostics)
           & fmap (\d -> (d ^. range, d))
@@ -183,7 +200,7 @@ fileAnalysisWorker = forever do
     pure dirty
   freshlyCheckedFiles <-
     Map.fromList <$> forMaybe (toList dirtyFileIDs) \docUri -> runMaybeT do
-      fileInfo <- MaybeT (checkFile $ TextDocumentIdentifier docUri)
+      fileInfo <- MaybeT (checkFileByUri $ TextDocumentIdentifier docUri)
       pure (docUri, fileInfo)
   Debug.debugM Debug.LSP "Freshly Typechecked " (Map.toList freshlyCheckedFiles)
   -- Overwrite any files we successfully checked
@@ -198,15 +215,15 @@ fileAnalysisWorker = forever do
   for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do
     reportDiagnostics fileUri (Just fileVersion) $ fold diagnostics
 
-analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
+analyseFile :: (Lspish m) => (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> m ([Diagnostic], [RangedCodeAction])
 analyseFile fileUri srcText pped notes = do
   let ppe = PPED.suffixifiedPPE pped
   (noteDiags, noteActions) <- analyseNotes fileUri ppe (Text.unpack srcText) notes
   pure (noteDiags, noteActions)
 
 -- | Returns diagnostics which show a warning diagnostic when editing a term that's conflicted in the
 -- codebase.
-computeConflictWarningDiagnostics :: Uri -> FileSummary -> Lsp [Diagnostic]
+computeConflictWarningDiagnostics :: (Lspish m) => Uri -> FileSummary -> m [Diagnostic]
 computeConflictWarningDiagnostics fileUri fileSummary@FileSummary {fileNames} = do
   let defLocations = fileDefLocations fileSummary
   conflictedNames <- Names.conflicts <$> getCurrentNames
@@ -249,11 +266,11 @@ getTokenMap tokens =
       )
     & fold
 
-analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
+analyseNotes :: forall m f. (Lspish m, Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> m ([Diagnostic], [RangedCodeAction])
 analyseNotes fileUri ppe src notes = do
   foldMapM go notes
   where
-    go :: Note Symbol Ann -> Lsp ([Diagnostic], [RangedCodeAction])
+    go :: Note Symbol Ann -> m ([Diagnostic], [RangedCodeAction])
     go note = case note of
       Result.TypeError errNote@(Context.ErrorNote {cause}) -> do
         let typeErr = TypeError.typeErrorFromNote errNote
@@ -421,7 +438,7 @@ toRangeMap :: (Foldable f) => f (Range, a) -> IntervalMap Position [a]
 toRangeMap vs =
   IM.fromListWith (<>) (toList vs <&> \(r, a) -> (rangeToInterval r, [a]))
 
-getFileAnalysis :: Uri -> MaybeT Lsp FileAnalysis
+getFileAnalysis :: (Lspish m) => Uri -> MaybeT m FileAnalysis
 getFileAnalysis uri = do
   checkedFilesV <- asks checkedFilesVar
   -- Try to get the file analysis, if there's a var, then read it, waiting if necessary
@@ -456,20 +473,20 @@ getFileNames fileUri = do
   FileAnalysis {typecheckedFile = tf, parsedFile = pf} <- getFileAnalysis fileUri
   hoistMaybe (fmap UF.typecheckedToNames tf <|> fmap UF.toNames pf)
 
-getFileSummary :: Uri -> MaybeT Lsp FileSummary
+getFileSummary :: (Lspish m) => Uri -> MaybeT m FileSummary
 getFileSummary uri = do
   FileAnalysis {fileSummary} <- getFileAnalysis uri
   MaybeT . pure $ fileSummary
 
 -- TODO memoize per file
-ppedForFile :: Uri -> Lsp PPED.PrettyPrintEnvDecl
+ppedForFile :: (Lspish m) => Uri -> m PPED.PrettyPrintEnvDecl
 ppedForFile fileUri = do
   runMaybeT (getFileAnalysis fileUri) >>= \case
     Just (FileAnalysis {typecheckedFile = tf, parsedFile = uf}) ->
       ppedForFileHelper uf tf
     _ -> ppedForFileHelper Nothing Nothing
 
-ppedForFileHelper :: Maybe (UF.UnisonFile Symbol a) -> Maybe (UF.TypecheckedUnisonFile Symbol a) -> Lsp PPED.PrettyPrintEnvDecl
+ppedForFileHelper :: (Lspish m) => Maybe (UF.UnisonFile Symbol a) -> Maybe (UF.TypecheckedUnisonFile Symbol a) -> m PPED.PrettyPrintEnvDecl
 ppedForFileHelper uf tf = do
   codebasePPED <- currentPPED
   hashLen <- asks codebase >>= \codebase -> liftIO (Codebase.runTransaction codebase Codebase.hashLength)
diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs
@@ -46,19 +46,19 @@ hoverHandler m respond = do
           _range = Nothing -- TODO add range info
         }
 
-hoverInfo :: Uri -> Position -> MaybeT Lsp Text
+hoverInfo :: forall m. (Lspish m, MonadUnliftIO m) => Uri -> Position -> MaybeT m Text
 hoverInfo uri pos =
   (hoverInfoForRef <|> hoverInfoForLiteral <|> hoverInfoForLocalVar)
   where
     markdownify :: Text -> Text
     markdownify rendered = Text.unlines ["``` unison", rendered, "```"]
     prettyWidth :: Pretty.Width
     prettyWidth = 40
-    hoverInfoForRef :: MaybeT Lsp Text
+    hoverInfoForRef :: (MonadUnliftIO m) => MaybeT m Text
     hoverInfoForRef = do
       symAtCursor <- VFS.identifierAtPosition uri pos
       ref <- LSPQ.refAtPosition uri pos
-      pped <- lift $ ppedForFile uri
+      pped <- ppedForFile uri
       let unsuffixifiedPPE = PPED.unsuffixifiedPPE pped
       let fqn = case ref of
             LD.TypeReference ref -> PPE.typeName unsuffixifiedPPE ref
@@ -109,7 +109,7 @@ hoverInfo uri pos =
       let renderedType = Text.pack $ TypePrinter.prettyStr (Just prettyWidth) (PPED.suffixifiedPPE pped) typ
        in markdownify (name <> " : " <> renderedType)
 
-    hoverInfoForLiteral :: MaybeT Lsp Text
+    hoverInfoForLiteral :: MaybeT m Text
     hoverInfoForLiteral =
       markdownify <$> do
         LSPQ.nodeAtPosition uri pos >>= \case
@@ -121,7 +121,7 @@ hoverInfo uri pos =
             typ <- hoistMaybe $ builtinTypeForPatternLiterals pat
             pure (": " <> typ)
 
-    hoverInfoForLocalVar :: MaybeT Lsp Text
+    hoverInfoForLocalVar :: MaybeT m Text
     hoverInfoForLocalVar = do
       localVar <- LSPQ.nodeAtPositionMatching uri pos \case
         LSPQ.TypeNode {} -> empty
@@ -139,7 +139,7 @@ hoverInfo uri pos =
             _ -> tShow localVar
       pure $ renderTypeSigForHover pped varName typ
 
-    hoistMaybe :: Maybe a -> MaybeT Lsp a
+    hoistMaybe :: Maybe a -> MaybeT m a
     hoistMaybe = MaybeT . pure
 
 -- | Get the type for term literals.
diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs
@@ -64,29 +64,29 @@ import Unison.UnisonFile.Summary (FileSummary (..))
 import Unison.Util.Pretty qualified as Pretty
 
 -- | Returns a reference to whatever the symbol at the given position refers to.
-refAtPosition :: Uri -> Position -> MaybeT Lsp LabeledDependency
+refAtPosition :: forall m. (Lspish m) => Uri -> Position -> MaybeT m LabeledDependency
 refAtPosition uri pos = do
   findInNode <|> findInDecl
   where
-    findInNode :: MaybeT Lsp LabeledDependency
+    findInNode :: MaybeT m LabeledDependency
     findInNode =
       nodeAtPosition uri pos >>= \case
         TermNode term -> hoistMaybe $ refInTerm term
         TypeNode typ -> hoistMaybe $ fmap TypeReference (refInType typ)
         PatternNode pat -> hoistMaybe $ refInPattern pat
-    findInDecl :: MaybeT Lsp LabeledDependency
+    findInDecl :: MaybeT m LabeledDependency
     findInDecl =
       LD.TypeReference <$> do
         let uPos = lspToUPos pos
         (FileSummary {dataDeclsBySymbol, effectDeclsBySymbol}) <- getFileSummary uri
         ( altMap (hoistMaybe . refInDecl uPos . Right . snd) dataDeclsBySymbol
             <|> altMap (hoistMaybe . refInDecl uPos . Left . snd) effectDeclsBySymbol
           )
-    hoistMaybe :: Maybe a -> MaybeT Lsp a
+    hoistMaybe :: Maybe a -> MaybeT m a
     hoistMaybe = MaybeT . pure
 
 -- | Gets the type of a reference from either the parsed file or the codebase.
-getTypeOfReferent :: Uri -> Referent -> MaybeT Lsp (Type Symbol Ann)
+getTypeOfReferent :: (Lspish m) => Uri -> Referent -> MaybeT m (Type Symbol Ann)
 getTypeOfReferent fileUri ref = do
   getFromFile <|> getFromCodebase
   where
@@ -107,11 +107,11 @@ getTypeOfReferent fileUri ref = do
       MaybeT . liftIO $ Codebase.runTransaction codebase $ Codebase.getTypeOfReferent codebase ref
 
 -- | Gets a decl from either the parsed file or the codebase.
-getTypeDeclaration :: Uri -> Reference.Id -> MaybeT Lsp (Decl Symbol Ann)
+getTypeDeclaration :: forall m. (Lspish m) => Uri -> Reference.Id -> MaybeT m (Decl Symbol Ann)
 getTypeDeclaration fileUri refId = do
   getFromFile <|> getFromCodebase
   where
-    getFromFile :: MaybeT Lsp (Decl Symbol Ann)
+    getFromFile :: MaybeT m (Decl Symbol Ann)
     getFromFile = do
       FileSummary {dataDeclsByReference, effectDeclsByReference} <- getFileSummary fileUri
       let datas = dataDeclsByReference ^.. ix refId . folded
@@ -393,15 +393,15 @@ refInDecl p (DD.asDataDecl -> dd) =
 
 -- | Returns the ABT node at the provided position.
 -- Does not return Decl nodes.
-nodeAtPosition :: Uri -> Position -> MaybeT Lsp (SourceNode Ann)
+nodeAtPosition :: (Lspish m) => Uri -> Position -> MaybeT m (SourceNode Ann)
 nodeAtPosition uri pos = nodeAtPositionMatching uri pos pure
 
 -- | Search the ABT for nodes which intersect at a given position, running the
 -- provided selector on them and aligning results to prefer smaller containing nodes first.
 -- The caller may use either 'pure' or 'empty' in the selector to select or ignore a given option.
 --
 -- Does not return Decl nodes.
-nodeAtPositionMatching :: Uri -> Position -> (SourceNode Ann -> MaybeT Lsp a) -> MaybeT Lsp a
+nodeAtPositionMatching :: (Lspish m) => Uri -> Position -> (SourceNode Ann -> MaybeT m a) -> MaybeT m a
 nodeAtPositionMatching uri (lspToUPos -> pos) pred = do
   (FileSummary {termsBySymbol, testWatchSummary, exprWatchSummary}) <- getFileSummary uri
 
@@ -437,12 +437,12 @@ removeInferredTypeAnnotations =
     t -> t
 
 -- | Renders all docs for a given FQN to markdown.
-markdownDocsForFQN :: Uri -> HQ.HashQualified Name -> Lsp [Text]
+markdownDocsForFQN :: (Lspish m) => Uri -> HQ.HashQualified Name -> m [Text]
 markdownDocsForFQN fileUri fqn =
   fromMaybe [] <$> runMaybeT do
     pped <- lift $ ppedForFile fileUri
     name <- MaybeT . pure $ HQ.toName fqn
-    nameSearch <- lift $ getNameSearch
+    nameSearch <- getNameSearch
     Env {codebase, runtime} <- ask
     liftIO $ do
       docRefs <- Codebase.runTransaction codebase $ Backend.docsForDefinitionName codebase nameSearch ExactName name
diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeOperators #-}
@@ -48,6 +49,10 @@ import Unison.UnisonFile qualified as UF
 import Unison.UnisonFile.Summary (FileSummary (..))
 import UnliftIO
 
+-- | Constraints for the lsp monad, but using constraints so we can
+-- swap it out in tests.
+type Lspish m = (MonadReader Env m, MonadIO m)
+
 -- | A custom LSP monad wrapper so we can provide our own environment.
 newtype Lsp a = Lsp {runLspM :: ReaderT Env (LspM Config) a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadReader Env, MonadLsp Config)
@@ -132,19 +137,19 @@ data FileAnalysis = FileAnalysis
   }
   deriving stock (Show)
 
-getCurrentProjectPath :: Lsp PP.ProjectPath
+getCurrentProjectPath :: (Lspish m) => m PP.ProjectPath
 getCurrentProjectPath = asks currentProjectPathCache >>= liftIO
 
 getCodebaseCompletions :: Lsp CompletionTree
 getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar
 
-currentPPED :: Lsp PrettyPrintEnvDecl
+currentPPED :: (Lspish m) => m PrettyPrintEnvDecl
 currentPPED = asks ppedCache >>= liftIO
 
-getNameSearch :: Lsp (NameSearch Sqlite.Transaction)
+getNameSearch :: (Lspish m) => m (NameSearch Sqlite.Transaction)
 getNameSearch = asks nameSearchCache >>= liftIO
 
-getCurrentNames :: Lsp Names
+getCurrentNames :: (MonadReader Env m, MonadIO m) => m Names
 getCurrentNames = asks currentNamesCache >>= liftIO
 
 data Config = Config
diff --git a/unison-cli/src/Unison/LSP/VFS.hs b/unison-cli/src/Unison/LSP/VFS.hs
@@ -34,12 +34,12 @@ usingVFS m = do
   vfsVar' <- asks vfsVar
   modifyMVar vfsVar' $ \vfs -> swap <$> runStateT m vfs
 
-getVirtualFile :: Uri -> MaybeT Lsp VirtualFile
+getVirtualFile :: (Lspish m) => Uri -> MaybeT m VirtualFile
 getVirtualFile fileUri = do
   vfs <- asks vfsVar >>= readMVar
   MaybeT . pure $ vfs ^. vfsMap . at (toNormalizedUri $ fileUri)
 
-getFileContents :: Uri -> MaybeT Lsp (FileVersion, Text)
+getFileContents :: (Lspish m) => Uri -> MaybeT m (FileVersion, Text)
 getFileContents fileUri = do
   vf <- getVirtualFile fileUri
   pure (vf ^. lsp_version, Rope.toText $ vf ^. file_text)
@@ -71,12 +71,12 @@ markAllFilesDirty = do
   markFilesDirty $ Map.keys (vfs ^. vfsMap)
 
 -- | Returns the name or symbol which the provided position is contained in.
-identifierAtPosition :: Uri -> Position -> MaybeT Lsp Text
+identifierAtPosition :: (Lspish m) => Uri -> Position -> MaybeT m Text
 identifierAtPosition uri pos = do
   identifierSplitAtPosition uri pos <&> \(before, after) -> (before <> after)
 
 -- | Returns the prefix and suffix of the symbol which the provided position is contained in.
-identifierSplitAtPosition :: Uri -> Position -> MaybeT Lsp (Text, Text)
+identifierSplitAtPosition :: (Lspish m) => Uri -> Position -> MaybeT m (Text, Text)
 identifierSplitAtPosition uri pos = do
   vf <- getVirtualFile uri
   PosPrefixInfo {fullLine, cursorPos} <- MaybeT (VFS.getCompletionPrefix pos vf)
diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs
diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal
