From a867ab013736d12753386396cb7a81ef46c0f649 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 7 Dec 2023 12:39:04 -0800 Subject: [PATCH] Propagate search type to Backend. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 14 +++--- unison-share-api/src/Unison/Server/Backend.hs | 17 +++---- .../src/Unison/Server/Local/Definitions.hs | 2 +- .../src/Unison/Server/NameSearch.hs | 9 ++-- .../src/Unison/Server/NameSearch/FromNames.hs | 4 +- .../src/Unison/Server/NameSearch/Sqlite.hs | 47 +++++-------------- 6 files changed, 35 insertions(+), 58 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 88aeccc86b..0fadfebce1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -238,7 +238,7 @@ loop e = do doRemoveReplacement from patchPath isTerm = do let patchPath' = fromMaybe Cli.defaultPatchPath patchPath patch <- Cli.getPatchAt patchPath' - QueryResult misses allHits <- hqNameQuery [from] + QueryResult misses allHits <- hqNameQuery NamesWithHistory.IncludeSuffixes [from] let tpRefs = Set.fromList $ typeReferences allHits tmRefs = Set.fromList $ termReferences allHits (hits, opHits) = @@ -936,8 +936,8 @@ loop e = do let patchPath' = fromMaybe Cli.defaultPatchPath patchPath patch <- Cli.getPatchAt patchPath' - QueryResult fromMisses' fromHits <- hqNameQuery [from] - QueryResult toMisses' toHits <- hqNameQuery [to] + QueryResult fromMisses' fromHits <- hqNameQuery NamesWithHistory.IncludeSuffixes [from] + QueryResult toMisses' toHits <- hqNameQuery NamesWithHistory.IncludeSuffixes [to] let termsFromRefs = termReferences fromHits termsToRefs = termReferences toHits typesFromRefs = typeReferences fromHits @@ -2024,7 +2024,7 @@ handleShowDefinition outputLoc showDefinitionScope inputQuery = do pure (currentNames, ppe) Backend.DefinitionResults terms types misses <- do let nameSearch = NameSearch.makeNameSearch hqLength names - Cli.runTransaction (Backend.definitionsBySuffixes codebase nameSearch includeCycles query) + Cli.runTransaction (Backend.definitionsByName codebase nameSearch includeCycles NamesWithHistory.IncludeSuffixes query) outputPath <- getOutputPath when (not (null types && null terms)) do -- We need an 'isTest' check in the output layer, so it can prepend "test>" to tests in a scratch file. Since we @@ -3057,8 +3057,8 @@ loadTypeOfTerm _ Referent.Con {} = error $ reportBug "924628772" "Attempt to load a type declaration which is a builtin!" -hqNameQuery :: [HQ.HashQualified Name] -> Cli QueryResult -hqNameQuery query = do +hqNameQuery :: NamesWithHistory.SearchType -> [HQ.HashQualified Name] -> Cli QueryResult +hqNameQuery searchType query = do Cli.Env {codebase} <- ask root' <- Cli.getRootBranch currentPath <- Cli.getCurrentPath @@ -3066,7 +3066,7 @@ hqNameQuery query = do hqLength <- Codebase.hashLength let parseNames = Backend.parseNamesForBranch root' (Backend.AllNames (Path.unabsolute currentPath)) let nameSearch = NameSearch.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames parseNames) - Backend.hqNameQuery codebase nameSearch query + Backend.hqNameQuery codebase nameSearch searchType query -- | Select a definition from the given branch. -- Returned names will match the provided 'Position' type. diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 1f6727aedd..e719281a23 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -27,7 +27,7 @@ module Unison.Server.Backend basicSuffixifiedNames, bestNameForTerm, bestNameForType, - definitionsBySuffixes, + definitionsByName, displayType, docsInBranchToHtmlFiles, expandShortCausalHash, @@ -756,9 +756,10 @@ fixupNamesRelative root names = hqNameQuery :: Codebase m v Ann -> NameSearch Sqlite.Transaction -> + NamesWithHistory.SearchType -> [HQ.HashQualified Name] -> Sqlite.Transaction QueryResult -hqNameQuery codebase NameSearch {typeSearch, termSearch} hqs = do +hqNameQuery codebase NameSearch {typeSearch, termSearch} searchType hqs = do -- Split the query into hash-only and hash-qualified-name queries. let (hashes, hqnames) = partitionEithers (map HQ'.fromHQ2 hqs) -- Find the terms with those hashes. @@ -783,7 +784,7 @@ hqNameQuery codebase NameSearch {typeSearch, termSearch} hqs = do (\(sh, tps) -> mkTypeResult sh <$> toList tps) <$> typeRefs -- Now do the actual name query - resultss <- for hqnames (\name -> liftA2 (<>) (applySearch typeSearch name) (applySearch termSearch name)) + resultss <- for hqnames (\name -> liftA2 (<>) (applySearch typeSearch searchType name) (applySearch termSearch searchType name)) let (misses, hits) = zipWith ( \hqname results -> @@ -1002,8 +1003,7 @@ docsForDefinitionName codebase (NameSearch {termSearch}) name = do Codebase.runTransaction codebase do refs <- potentialDocNames & foldMapM \name -> - -- TODO: Should replace this with an exact name lookup. - lookupRelativeHQRefs' termSearch (HQ'.NameOnly name) + lookupRelativeHQRefs' termSearch NamesWithHistory.ExactName (HQ'.NameOnly name) filterForDocs (toList refs) where filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference] @@ -1229,14 +1229,15 @@ data IncludeCycles = IncludeCycles | DontIncludeCycles -definitionsBySuffixes :: +definitionsByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transaction -> IncludeCycles -> + NamesWithHistory.SearchType -> [HQ.HashQualified Name] -> Sqlite.Transaction DefinitionResults -definitionsBySuffixes codebase nameSearch includeCycles query = do - QueryResult misses results <- hqNameQuery codebase nameSearch query +definitionsByName codebase nameSearch includeCycles searchType query = do + QueryResult misses results <- hqNameQuery codebase nameSearch searchType query -- todo: remember to replace this with getting components directly, -- and maybe even remove getComponentLength from Codebase interface altogether terms <- Map.foldMapM (\ref -> (ref,) <$> displayTerm codebase ref) (searchResultsToTermRefs results) diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 70e6a0d19a..9abd81486f 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -66,7 +66,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings let pped = PPED.biasTo biases unbiasedPPED let nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) (DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do - definitionsBySuffixes codebase nameSearch DontIncludeCycles [query] + definitionsByName codebase nameSearch DontIncludeCycles NamesWithHistory.ExactName [query] let width = mayDefaultWidth renderWidth let docResults :: Name -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults name = do diff --git a/unison-share-api/src/Unison/Server/NameSearch.hs b/unison-share-api/src/Unison/Server/NameSearch.hs index 8cc5e65cd0..0d8b17987c 100644 --- a/unison-share-api/src/Unison/Server/NameSearch.hs +++ b/unison-share-api/src/Unison/Server/NameSearch.hs @@ -6,6 +6,7 @@ import Data.Set qualified as Set import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) +import Unison.NamesWithHistory (SearchType) import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) @@ -21,7 +22,7 @@ import Unison.Server.SearchResult qualified as SR -- You can use the individual methods of a name search or can use 'applySearch'. data Search m r = Search { lookupNames :: r -> m (Set (HQ'.HashQualified Name)), - lookupRelativeHQRefs' :: HQ'.HashQualified Name -> m (Set r), + lookupRelativeHQRefs' :: SearchType -> HQ'.HashQualified Name -> m (Set r), makeResult :: HQ.HashQualified Name -> r -> Set (HQ'.HashQualified Name) -> m SR.SearchResult, matchesNamedRef :: Name -> r -> HQ'.HashQualified Name -> Bool } @@ -32,9 +33,9 @@ data NameSearch m = NameSearch } -- | Interpret a 'Search' as a function from name to search results. -applySearch :: (Show r, Monad m) => Search m r -> HQ'.HashQualified Name -> m [SR.SearchResult] -applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} query = do - refs <- (lookupRelativeHQRefs' query) +applySearch :: (Show r, Monad m) => Search m r -> SearchType -> HQ'.HashQualified Name -> m [SR.SearchResult] +applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} searchType query = do + refs <- (lookupRelativeHQRefs' searchType query) -- a bunch of references will match a HQ ref. for (toList refs) \ref -> do let -- Precondition: the input set is non-empty diff --git a/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs b/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs index 06241b05f0..73e53f27f3 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs @@ -13,7 +13,7 @@ makeTypeSearch :: (Applicative m) => Int -> NamesWithHistory -> Search m Referen makeTypeSearch len names = Search { lookupNames = \ref -> pure $ NamesWithHistory.typeName len ref names, - lookupRelativeHQRefs' = \n -> pure $ NamesWithHistory.lookupRelativeHQType' NamesWithHistory.ExactName n names, + lookupRelativeHQRefs' = \searchType n -> pure $ NamesWithHistory.lookupRelativeHQType' searchType n names, matchesNamedRef = HQ'.matchesNamedReference, makeResult = \hqname r names -> pure $ SR.typeResult hqname r names } @@ -23,7 +23,7 @@ makeTermSearch :: (Applicative m) => Int -> NamesWithHistory -> Search m Referen makeTermSearch len names = Search { lookupNames = \ref -> pure $ NamesWithHistory.termName len ref names, - lookupRelativeHQRefs' = \n -> pure $ NamesWithHistory.lookupRelativeHQTerm' NamesWithHistory.ExactName n names, + lookupRelativeHQRefs' = \searchType n -> pure $ NamesWithHistory.lookupRelativeHQTerm' searchType n names, matchesNamedRef = HQ'.matchesNamedReferent, makeResult = \hqname r names -> pure $ SR.termResult hqname r names } diff --git a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs index f87ed18901..e7fa113fa1 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs @@ -22,6 +22,7 @@ import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment (..)) +import Unison.NamesWithHistory (SearchType (ExactName, IncludeSuffixes)) import Unison.Prelude import Unison.Reference (Reference) import Unison.Reference qualified as Reference @@ -33,11 +34,6 @@ import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite import Unison.Util.Set qualified as Set -data SearchStrategy - = ExactMatch - | SuffixMatch - deriving (Show, Eq) - nameSearchForPerspective :: Codebase m v a -> Ops.NamesPerspective -> (NameSearch Sqlite.Transaction) nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToMountedNameLookup} = do NameSearch {typeSearch, termSearch} @@ -49,14 +45,14 @@ nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToM typeSearch = Search { lookupNames = lookupNamesForTypes, - lookupRelativeHQRefs' = lookupRelativeHQRefsForTypes . fmap stripMountPathPrefix, + lookupRelativeHQRefs' = \searchType n -> hqTypeSearch searchType . fmap stripMountPathPrefix $ n, makeResult = \hqname r names -> pure $ SR.typeResult hqname r names, matchesNamedRef = HQ'.matchesNamedReference } termSearch = Search { lookupNames = lookupNamesForTerms, - lookupRelativeHQRefs' = lookupRelativeHQRefsForTerms . fmap stripMountPathPrefix, + lookupRelativeHQRefs' = \searchType n -> hqTermSearch searchType . fmap stripMountPathPrefix $ n, makeResult = \hqname r names -> pure $ SR.termResult hqname r names, matchesNamedRef = HQ'.matchesNamedReferent } @@ -75,37 +71,16 @@ nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToM & fmap (\segments -> HQ'.HashQualified (reversedSegmentsToName segments) (Referent.toShortHash ref)) & Set.fromList & pure - -- This is a bit messy, but the existing 'lookupRelativeHQRefs' semantics - -- will return ONLY exact matches if any exist, otherwise it falls back on - -- suffix search, so we maintain that behaviour here. It would probably be better - -- to have separate functions in the Search type for each of these, and be more explicit - -- about desired behaviour at the call-site. - lookupRelativeHQRefsForTerms :: HQ'.HashQualified Name -> Sqlite.Transaction (Set Referent) - lookupRelativeHQRefsForTerms hqName = do - exact <- hqTermSearch ExactMatch hqName - if Set.null exact - then do - hqTermSearch SuffixMatch hqName - else do - pure exact - lookupRelativeHQRefsForTypes :: HQ'.HashQualified Name -> Sqlite.Transaction (Set Reference) - lookupRelativeHQRefsForTypes hqName = do - exact <- hqTypeSearch ExactMatch hqName - if Set.null exact - then do - hqTypeSearch SuffixMatch hqName - else do - pure exact -- Search the codebase for matches to the given hq name. -- Supports either an exact match or a suffix match. - hqTermSearch :: SearchStrategy -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Referent) + hqTermSearch :: SearchType -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Referent) hqTermSearch searchStrat hqName = do case hqName of HQ'.NameOnly name -> do namedRefs <- case searchStrat of - ExactMatch -> Ops.termRefsForExactName namesPerspective (coerce $ Name.reverseSegments name) - SuffixMatch -> Ops.termNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) + ExactName -> Ops.termRefsForExactName namesPerspective (coerce $ Name.reverseSegments name) + IncludeSuffixes -> Ops.termNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) namedRefs & fmap ( \(NamedRef.ref -> (ref, mayCT)) -> @@ -120,21 +95,21 @@ nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToM matches <- Ops.termNamesForRefWithinNamespace namesPerspective (Cv.referent1to2 termRef) (Just . coerce $ Name.reverseSegments name) -- Return a valid ref if at least one match was found. Require that it be an exact -- match if specified. - if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactMatch) matches + if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactName) matches then pure (Just termRef) else pure Nothing -- Search the codebase for matches to the given hq name. -- Supports either an exact match or a suffix match. - hqTypeSearch :: SearchStrategy -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Reference) + hqTypeSearch :: SearchType -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Reference) hqTypeSearch searchStrat hqName = do case hqName of HQ'.NameOnly name -> do let fqn = fullyQualifyName name namedRefs <- case searchStrat of - ExactMatch -> Ops.typeRefsForExactName namesPerspective (coerce $ Name.reverseSegments fqn) - SuffixMatch -> Ops.typeNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) + ExactName -> Ops.typeRefsForExactName namesPerspective (coerce $ Name.reverseSegments fqn) + IncludeSuffixes -> Ops.typeNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) namedRefs & fmap (Cv.reference2to1 . NamedRef.ref) & Set.fromList @@ -146,7 +121,7 @@ nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToM matches <- Ops.typeNamesForRefWithinNamespace namesPerspective (Cv.reference1to2 typeRef) (Just . coerce $ Name.reverseSegments name) -- Return a valid ref if at least one match was found. Require that it be an exact -- match if specified. - if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactMatch) matches + if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactName) matches then pure (Just typeRef) else pure Nothing