Skip to content

Commit 27462f6

Browse files
ChrisPennerChrisPenner
authored
Merge pull request #123 from unisoncomputing/cp/batched-definition-search
Batchify definition search
2 parents 9d70332 + 8784035 commit 27462f6

File tree

4 files changed

+88
-98
lines changed

4 files changed

+88
-98
lines changed

‎src/Share/Web/Share/Diffs/Impl.hs

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,6 @@ import Unison.NameSegment (NameSegment)
3636
import Unison.PrettyPrintEnvDecl qualified as PPED
3737
import Unison.Referent qualified as Referent
3838
import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff
39-
import Unison.Server.NameSearch.Postgres qualified as PGNameSearch
4039
import Unison.Server.Share.Definitions qualified as Definitions
4140
import Unison.Server.Types
4241
import Unison.ShortHash (ShortHash)
@@ -250,11 +249,10 @@ getTermDefinitionsOf :: (PG.QueryM m) => Codebase.CodebaseEnv -> Codebase.Codeba
250249
getTermDefinitionsOf codebase rt namesPerspective trav s = do
251250
s
252251
& asListOfDeduped trav %%~ \names -> do
253-
Definitions.termDefinitionByNamesOf codebase ppedBuilder nameSearch renderWidth rt includeDocs traversed names
252+
Definitions.termDefinitionByNamesOf codebase ppedBuilder namesPerspective renderWidth rt includeDocs traversed names
254253
where
255254
includeDocs = False
256255
ppedBuilder deps = PPEPostgres.ppedForReferences namesPerspective deps
257-
nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
258256
renderWidth :: Width
259257
renderWidth = 80
260258

@@ -295,8 +293,7 @@ diffTypes !_authZReceipt old@(_, _, _, oldTypeName) new@(_, _, _, newTypeName) =
295293
getTypeDefinition :: (PG.QueryM m) => (Codebase.CodebaseEnv, Codebase.CodebaseRuntime s IO, NamesPerspective m, Name) -> m (Maybe TypeDefinition)
296294
getTypeDefinition (codebase, rt, namesPerspective, name) = do
297295
let ppedBuilder deps = (PPED.biasTo [name]) <$> (PPEPostgres.ppedForReferences namesPerspective deps)
298-
let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
299-
Definitions.typeDefinitionByName codebase ppedBuilder nameSearch renderWidth rt includeDocs name
296+
Definitions.typeDefinitionByName codebase ppedBuilder namesPerspective renderWidth rt includeDocs name
300297
where
301298
includeDocs = False
302299
renderWidth :: Width

‎src/Unison/Server/NameSearch/Postgres.hs

Lines changed: 59 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -1,20 +1,23 @@
11
module Unison.Server.NameSearch.Postgres
22
( NameSearch (..),
33
nameSearchForPerspective,
4+
5+
-- * Searches are also exported A'la carte.
6+
termRefsByHQNamesOf,
7+
typeRefsByHQNamesOf,
48
)
59
where
610

711
import Control.Lens
812
import Data.Set qualified as Set
9-
import Share.Codebase qualified as Codebase
13+
import Share.Postgres (QueryM)
1014
import Share.Postgres qualified as PG
1115
import Share.Postgres.NameLookups.Conversions qualified as CV
1216
import Share.Postgres.NameLookups.Ops as NLOps
1317
import Share.Postgres.NameLookups.Queries (ShouldSuffixify (NoSuffixify))
1418
import Share.Postgres.NameLookups.Types
1519
import Share.Postgres.NamesPerspective.Types (NamesPerspective, perspectiveCurrentMountPathPrefix)
1620
import Share.Prelude
17-
import Unison.Codebase.Path qualified as Path
1821
import Unison.HashQualifiedPrime qualified as HQ'
1922
import Unison.Name (Name)
2023
import Unison.Name qualified as Name
@@ -25,6 +28,7 @@ import Unison.Reference qualified as V1Reference
2528
import Unison.Referent qualified as V1Referent
2629
import Unison.Server.NameSearch (NameSearch (..), Search (..))
2730
import Unison.Server.SearchResult qualified as SR
31+
import Unison.ShortHash qualified as V1ShortHash
2832

2933
nameSearchForPerspective :: forall m. (PG.QueryM m) => NamesPerspective m -> NameSearch m
3034
nameSearchForPerspective namesPerspective =
@@ -39,7 +43,7 @@ nameSearchForPerspective namesPerspective =
3943
{ lookupNames = lookupNamesForTypes,
4044
lookupRelativeHQRefs' = \searchType hqname ->
4145
case searchType of
42-
ExactName -> hqTypeSearch . fmap stripMountPathPrefix $ hqname
46+
ExactName -> typeRefsByHQNamesOf namesPerspective id . fmap stripMountPathPrefix $ hqname
4347
-- We can implement this, but it's not currently used anywhere on share.
4448
IncludeSuffixes -> error "Suffix search not yet implemented on Share",
4549
makeResult = \hqname r names -> pure $ SR.typeResult hqname r names,
@@ -50,7 +54,7 @@ nameSearchForPerspective namesPerspective =
5054
{ lookupNames = lookupNamesForTerms,
5155
lookupRelativeHQRefs' = \searchType hqname ->
5256
case searchType of
53-
ExactName -> hqTermSearch . fmap stripMountPathPrefix $ hqname
57+
ExactName -> termRefsByHQNamesOf namesPerspective id . fmap stripMountPathPrefix $ hqname
5458
-- We can implement this, but it's not currently used anywhere on share.
5559
IncludeSuffixes -> error "Suffix search not yet implemented on Share",
5660
makeResult = \hqname r names -> pure $ SR.termResult hqname r names,
@@ -73,68 +77,58 @@ nameSearchForPerspective namesPerspective =
7377
& fmap (\(fqnSegments, _suffixSegments) -> HQ'.HashQualified (reversedSegmentsToName fqnSegments) (V1Referent.toShortHash ref))
7478
& Set.fromList
7579
& pure
76-
-- Search the codebase for matches to the given hq name.
77-
hqTermSearch :: HQ'.HashQualified Name -> m (Set V1Referent.Referent)
78-
hqTermSearch hqName = do
79-
case hqName of
80-
HQ'.NameOnly name -> do
81-
namedRefs <- NLOps.termRefsForExactNamesOf namesPerspective id (coerce $ Name.reverseSegments name)
82-
namedRefs
83-
& fmap (\(NamedRef {ref}) -> ref)
84-
& Set.fromList
85-
& pure
86-
HQ'.HashQualified name sh -> do
87-
let fqn = fullyQualifyName name
88-
termRefsV1 <-
89-
Set.toList <$> Codebase.termReferentsByShortHash sh
90-
termRefsPG <- catMaybes <$> CV.referents1ToPGOf traversed termRefsV1
91-
names <-
92-
NLOps.termNamesForRefsWithinNamespaceOf namesPerspective (Just . coerce $ Name.reverseSegments name) NoSuffixify traversed termRefsPG
93-
<&> (fmap . fmap) fst -- Only need the fqn
94-
zip termRefsV1 names
95-
& mapMaybe
96-
( \(termRef, matches) ->
97-
-- Return a valid ref if at least one match was found.
98-
if any (\n -> ReversedName (coerce @(NonEmpty NameSegment) @(NonEmpty Text) $ Name.reverseSegments fqn) == n) matches
99-
then (Just termRef)
100-
else Nothing
101-
)
102-
& Set.fromList
103-
& pure
104-
105-
-- Search the codebase for matches to the given hq name.
106-
hqTypeSearch :: HQ'.HashQualified Name -> m (Set V1.Reference)
107-
hqTypeSearch hqName = do
108-
case hqName of
109-
HQ'.NameOnly name -> do
110-
namedRefs <- NLOps.typeRefsForExactNamesOf namesPerspective id (coerce $ Name.reverseSegments name)
111-
namedRefs
112-
& fmap (\NamedRef {ref} -> ref)
113-
& Set.fromList
114-
& pure
115-
HQ'.HashQualified name sh -> do
116-
let fqn = fullyQualifyName name
117-
typeRefs <- Set.toList <$> Codebase.typeReferencesByShortHash sh
118-
typeRefsPG <- catMaybes <$> CV.references1ToPGOf traversed typeRefs
119-
names <-
120-
NLOps.typeNamesForRefsWithinNamespaceOf namesPerspective (Just . coerce $ Name.reverseSegments name) NoSuffixify traversed typeRefsPG
121-
<&> (fmap . fmap) fst -- Only need the fqn
122-
zip typeRefs names
123-
& mapMaybe
124-
( \(typeRef, matches) ->
125-
-- Return a valid ref if at least one match was found.
126-
if any (\n -> ReversedName (coerce @(NonEmpty NameSegment) @(NonEmpty Text) $ Name.reverseSegments fqn) == n) matches
127-
then Just typeRef
128-
else Nothing
129-
)
130-
& Set.fromList
131-
& pure
13280

13381
reversedSegmentsToName :: ReversedName -> Name
13482
reversedSegmentsToName = Name.fromReverseSegments . coerce
13583

136-
-- Fully qualify a name by prepending the current namespace perspective's path
137-
fullyQualifyName :: Name -> Name
138-
fullyQualifyName name =
139-
-- TODO: Is it actually correct to do this?
140-
fromMaybe name $ Path.maybePrefixName (Path.AbsolutePath' $ Path.Absolute (Path.fromList . (fmap NameSegment) . into @[Text] $ perspectiveCurrentMountPathPrefix namesPerspective)) name
84+
-- | Search the codebase for terms which exactly match the hq name.
85+
termRefsByHQNamesOf ::
86+
(QueryM m) =>
87+
NamesPerspective m ->
88+
Traversal s t (HQ'.HashQualified Name) (Set V1Referent.Referent) ->
89+
s ->
90+
m t
91+
termRefsByHQNamesOf namesPerspective trav s = do
92+
s
93+
& asListOf trav %%~ \hqNames -> do
94+
let tupled =
95+
hqNames <&> \case
96+
HQ'.NameOnly name -> (coerce @(NonEmpty NameSegment) @ReversedName $ Name.reverseSegments name, Nothing)
97+
HQ'.HashQualified name sh -> (coerce @(NonEmpty NameSegment) @ReversedName $ Name.reverseSegments name, Just sh)
98+
foundTermRefs <- NLOps.termRefsForExactNamesOf namesPerspective (traversed . _1) tupled
99+
foundTermRefs
100+
& over (traversed . _1 . traversed) (\NamedRef {ref} -> ref)
101+
<&> ( \case
102+
(results, Nothing) -> results
103+
(results, Just sh) ->
104+
results
105+
& filter (\ref -> sh `V1ShortHash.isPrefixOf` V1Referent.toShortHash ref)
106+
)
107+
<&> Set.fromList
108+
& pure
109+
110+
-- | Search the codebase for types which exactly match the hq name.
111+
typeRefsByHQNamesOf ::
112+
(QueryM m) =>
113+
NamesPerspective m ->
114+
Traversal s t (HQ'.HashQualified Name) (Set V1Reference.Reference) ->
115+
s ->
116+
m t
117+
typeRefsByHQNamesOf namesPerspective trav s = do
118+
s
119+
& asListOf trav %%~ \hqNames -> do
120+
let tupled =
121+
hqNames <&> \case
122+
HQ'.NameOnly name -> (coerce @(NonEmpty NameSegment) @ReversedName $ Name.reverseSegments name, Nothing)
123+
HQ'.HashQualified name sh -> (coerce @(NonEmpty NameSegment) @ReversedName $ Name.reverseSegments name, Just sh)
124+
foundTypeRefs <- NLOps.typeRefsForExactNamesOf namesPerspective (traversed . _1) tupled
125+
foundTypeRefs
126+
& over (traversed . _1 . traversed) (\NamedRef {ref} -> ref)
127+
<&> ( \case
128+
(results, Nothing) -> results
129+
(results, Just sh) ->
130+
results
131+
& filter (\ref -> sh `V1ShortHash.isPrefixOf` V1Reference.toShortHash ref)
132+
)
133+
<&> Set.fromList
134+
& pure

‎src/Unison/Server/Share/Definitions.hs

Lines changed: 17 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Share.Postgres.Causal.Queries qualified as CausalQ
2222
import Share.Postgres.IDs (CausalId)
2323
import Share.Postgres.NameLookups.Types (pathToPathSegments)
2424
import Share.Postgres.NamesPerspective.Ops qualified as NPOps
25+
import Share.Postgres.NamesPerspective.Types (NamesPerspective)
2526
import Share.Prelude
2627
import Share.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres
2728
import Share.Utils.Caching.JSON qualified as Caching
@@ -46,7 +47,6 @@ import Unison.Reference qualified as V1
4647
import Unison.Referent qualified as Referent
4748
import Unison.Server.Doc qualified as Doc
4849
import Unison.Server.NameSearch (NameSearch (..))
49-
import Unison.Server.NameSearch qualified as NS
5050
import Unison.Server.NameSearch qualified as NameSearch
5151
import Unison.Server.NameSearch.Postgres qualified as PGNameSearch
5252
import Unison.Server.QueryResult (QueryResult (..))
@@ -122,9 +122,8 @@ definitionForHQName codebase@(CodebaseEnv {codebaseOwner}) perspective rootCausa
122122
-- We need to re-lookup the names perspective here because the name we've found
123123
-- may now be in a lib.
124124
(scopedPerspective, relativeName) <- NPOps.relocateNamesToMountsOf perspectiveNP id name
125-
let nameSearch = PGNameSearch.nameSearchForPerspective scopedPerspective
126125
-- TODO: properly batchify this
127-
docRefs <- Docs.docsForDefinitionNamesOf codebase nameSearch id relativeName
126+
docRefs <- Docs.docsForDefinitionNamesOf codebase scopedPerspective id relativeName
128127
-- TODO: properly batchify this
129128
renderDocRefs codebase ppedBuilder width rt docRefs
130129

@@ -212,15 +211,14 @@ mkDefinitionsForQuery codebase nameSearch query = do
212211
termDisplayObjectsByNameOf ::
213212
(QueryM m) =>
214213
Codebase.CodebaseEnv ->
215-
NameSearch m ->
214+
NamesPerspective m ->
216215
Traversal s t Name (Maybe (Either ConstructorReference (TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann)))) ->
217216
s ->
218217
m t
219-
termDisplayObjectsByNameOf codebase nameSearch trav s = do
218+
termDisplayObjectsByNameOf codebase namesPerspective trav s = do
220219
s
221220
& asListOfDeduped trav %%~ \names -> do
222-
-- TODO: batchify this:
223-
allRefs <- traverse (NameSearch.lookupRelativeHQRefs' (termSearch nameSearch) NS.ExactName) (HQ'.NameOnly <$> names)
221+
allRefs <- PGNameSearch.termRefsByHQNamesOf namesPerspective traversed (HQ'.NameOnly <$> names)
224222
let partitionedRefs =
225223
allRefs <&> \refs ->
226224
do
@@ -235,17 +233,17 @@ termDefinitionByNamesOf ::
235233
(QueryM m) =>
236234
CodebaseEnv ->
237235
PPEDBuilder m ->
238-
NameSearch m ->
236+
NamesPerspective m ->
239237
Width ->
240238
CodebaseRuntime sym IO ->
241239
Bool ->
242240
Traversal s t Name (Maybe (Either ConstructorReference TermDefinition)) ->
243241
s ->
244242
m t
245-
termDefinitionByNamesOf codebase ppedBuilder nameSearch width rt includeDocs trav s = do
243+
termDefinitionByNamesOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do
246244
s
247245
& asListOfDeduped trav %%~ \allNames -> do
248-
constructorsAndRendered <- termDisplayObjectsByNameOf codebase nameSearch traversed allNames
246+
constructorsAndRendered <- termDisplayObjectsByNameOf codebase namesPerspective traversed allNames
249247
let addName name = \case
250248
Just (Right (termRef, displayObject)) -> Just (Right (name, termRef, displayObject))
251249
Just (Left constructorRef) -> Just (Left constructorRef)
@@ -260,7 +258,7 @@ termDefinitionByNamesOf codebase ppedBuilder nameSearch width rt includeDocs tra
260258
allRenderedDocs <-
261259
if includeDocs
262260
then do
263-
allDocRefs <- Docs.docsForDefinitionNamesOf codebase nameSearch traversed names
261+
allDocRefs <- Docs.docsForDefinitionNamesOf codebase namesPerspective traversed names
264262
-- TODO: properly batchify this
265263
for allDocRefs $ renderDocRefs codebase ppedBuilder width rt
266264
else pure (names $> [])
@@ -273,9 +271,10 @@ termDisplayObjectLabeledDependencies termRef displayObject = do
273271
& bifoldMap (Type.labeledDependencies) (Term.labeledDependencies)
274272
& Set.insert (LD.TermReference termRef)
275273

276-
typeDisplayObjectByName :: (QueryM m) => Codebase.CodebaseEnv -> NameSearch m -> Name -> m (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann)))
277-
typeDisplayObjectByName codebase nameSearch name = runMaybeT do
278-
refs <- lift $ NameSearch.lookupRelativeHQRefs' (typeSearch nameSearch) NS.ExactName (HQ'.NameOnly name)
274+
typeDisplayObjectByName :: (QueryM m) => Codebase.CodebaseEnv -> NamesPerspective m -> Name -> m (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann)))
275+
typeDisplayObjectByName codebase namesPerspective name = runMaybeT do
276+
-- TODO: batchify this properly
277+
refs <- lift $ PGNameSearch.typeRefsByHQNamesOf namesPerspective id (HQ'.NameOnly name)
279278
ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs
280279
fmap (ref,) . lift $ Backend.displayType codebase ref
281280

@@ -285,21 +284,21 @@ typeDefinitionByName ::
285284
(QueryM m) =>
286285
CodebaseEnv ->
287286
PPEDBuilder m ->
288-
NameSearch m ->
287+
NamesPerspective m ->
289288
Width ->
290289
CodebaseRuntime s IO ->
291290
Bool ->
292291
Name ->
293292
m (Maybe TypeDefinition)
294-
typeDefinitionByName codebase ppedBuilder nameSearch width rt includeDocs name = runMaybeT $ do
295-
(ref, displayObject) <- MaybeT $ typeDisplayObjectByName codebase nameSearch name
293+
typeDefinitionByName codebase ppedBuilder namesPerspective width rt includeDocs name = runMaybeT $ do
294+
(ref, displayObject) <- MaybeT $ typeDisplayObjectByName codebase namesPerspective name
296295
let deps = typeDisplayObjectLabeledDependencies ref displayObject
297296
pped <- lift $ ppedBuilder deps
298297
let biasedPPED = PPED.biasTo [name] pped
299298
renderedDocs <-
300299
if includeDocs
301300
then do
302-
docRefs <- lift $ Docs.docsForDefinitionNamesOf codebase nameSearch id name
301+
docRefs <- lift $ Docs.docsForDefinitionNamesOf codebase namesPerspective id name
303302
lift $ renderDocRefs codebase ppedBuilder width rt docRefs
304303
else pure []
305304
let (_ref, syntaxDO) = Backend.typesToSyntaxOf (Suffixify False) width pped id (ref, displayObject)

‎src/Unison/Server/Share/Docs.hs

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Share.Codebase (loadTypesOfTermsOf)
99
import Share.Codebase qualified as Codebase
1010
import Share.Postgres (QueryM)
1111
import Share.Postgres qualified as PG
12+
import Share.Postgres.NamesPerspective.Types (NamesPerspective)
1213
import Share.Prelude
1314
import Share.Web.Errors (SomeServerError)
1415
import Unison.HashQualifiedPrime qualified as HQ'
@@ -20,6 +21,7 @@ import Unison.Referent qualified as V1Referent
2021
import Unison.Runtime.IOSource qualified as DD
2122
import Unison.Server.NameSearch (NameSearch (..), lookupRelativeHQRefs')
2223
import Unison.Server.NameSearch qualified as NameSearch
24+
import Unison.Server.NameSearch.Postgres qualified as NS
2325
import Unison.Sqlite qualified as Sqlite
2426
import Unison.Symbol (Symbol)
2527
import Unison.Type qualified as Type
@@ -33,21 +35,19 @@ docsForDefinitionNamesOf ::
3335
forall m s t.
3436
(QueryM m) =>
3537
Codebase.CodebaseEnv ->
36-
NameSearch m ->
38+
NamesPerspective m ->
3739
Traversal s t Name [TermReference] ->
3840
s ->
3941
m t
40-
docsForDefinitionNamesOf codebase (NameSearch {termSearch}) trav s = do
42+
docsForDefinitionNamesOf codebase namesPerspective trav s = do
4143
s
4244
& asListOf trav %%~ \names -> do
43-
let potentialDocNames = names <&> \name -> [name, name Cons.:> NameSegment "doc"]
44-
refs <-
45-
for
46-
potentialDocNames
47-
( foldMapM \name ->
48-
lookupRelativeHQRefs' termSearch ExactName (HQ'.NameOnly name)
49-
)
50-
filterForDocs (Set.toList <$> refs)
45+
let potentialDocNames =
46+
names <&> \name ->
47+
[name, name Cons.:> NameSegment "doc"]
48+
<&> HQ'.NameOnly
49+
refs <- NS.termRefsByHQNamesOf namesPerspective (traversed . traversed) potentialDocNames
50+
filterForDocs (Set.toList <$> (fold <$> refs))
5151
where
5252
filterForDocs :: [[V1Referent.Referent]] -> m [[TermReference]]
5353
filterForDocs refs = do

0 commit comments

Comments
 (0)