Merge pull request #76 from unisoncomputing/cp/find-fixups

ChrisPenner · web-flow · commit 715e0031a206 · 2025-05-21T11:48:25.000-07:00
Some basic fixups for search
diff --git a/share-utils/src/Share/Debug.hs b/share-utils/src/Share/Debug.hs
@@ -4,6 +4,7 @@
 
 module Share.Debug
   ( debug,
+    debugOther,
     debugM,
     whenDebug,
     debugLog,
@@ -61,6 +62,14 @@ debug flag msg a =
     then (trace (msg <> ":\n" <> into @String (pShow a)) a)
     else a
 
+-- | Use for trace-style selective debugging.
+-- Like 'debug' but allows debugging something other than the result.
+debugOther :: (Show x) => DebugFlag -> String -> x -> a -> a
+debugOther flag msg x a =
+  if shouldDebug flag
+    then (trace (msg <> ":\n" <> into @String (pShow x)) a)
+    else a
+
 -- | Use for selective debug logging in monadic contexts.
 -- E.g.
 -- do
diff --git a/src/Share/Postgres/NameLookups/Ops.hs b/src/Share/Postgres/NameLookups/Ops.hs
@@ -36,7 +36,6 @@ import U.Codebase.Reference (Reference)
 import U.Codebase.Referent (ConstructorType, Referent)
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
-import Unison.Debug qualified as Debug
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment.Internal (NameSegment (..))
@@ -109,7 +108,6 @@ relocateToNameRoot perspective query rootBh = do
             & Path.fromList
         Nothing -> mempty
   let fullPath = perspective <> nameLocation
-  Debug.debugM Debug.Server "relocateToNameRoot fullPath" fullPath
   namesPerspective@NamesPerspective {relativePerspective} <- namesPerspectiveForRootAndPath rootBh (PathSegments . fmap NameSegment.toUnescapedText . Path.toList $ fullPath)
   let reprefixName name = Name.fromReverseSegments $ (NonEmpty.head $ Name.reverseSegments name) NonEmpty.:| (reverse $ coerce relativePerspective)
   pure (namesPerspective, reprefixName <$> query)
@@ -123,18 +121,20 @@ fuzzySearchDefinitions ::
   -- | Will return at most n terms and n types; i.e. max number of results is 2n
   Int ->
   NonEmpty Text ->
+  Text ->
   m ([(Q.FuzzySearchScore, NameLookups.NamedRef (Referent, Maybe ConstructorType))], [(Q.FuzzySearchScore, NamedRef Reference)])
-fuzzySearchDefinitions includeDependencies NamesPerspective {nameLookupBranchHashId, relativePerspective, nameLookupReceipt} limit querySegments = do
+fuzzySearchDefinitions includeDependencies NamesPerspective {nameLookupBranchHashId, relativePerspective, nameLookupReceipt} limit querySegments lastQuerySegment = do
   pgTermNames <-
-    Q.fuzzySearchTerms nameLookupReceipt includeDependencies nameLookupBranchHashId (into @Int64 limit) relativePerspective querySegments
+    Q.fuzzySearchTerms nameLookupReceipt includeDependencies nameLookupBranchHashId (into @Int64 limit) relativePerspective querySegments lastQuerySegment
       <&> fmap \termName ->
         termName
           & second (stripPrefixFromNamedRef relativePerspective)
   pgTypeNames <-
-    Q.fuzzySearchTypes nameLookupReceipt includeDependencies nameLookupBranchHashId (into @Int64 limit) relativePerspective querySegments
+    Q.fuzzySearchTypes nameLookupReceipt includeDependencies nameLookupBranchHashId (into @Int64 limit) relativePerspective querySegments lastQuerySegment
       <&> fmap \typeName ->
         typeName
           & second (stripPrefixFromNamedRef relativePerspective)
+
   termNames <- pgTermNames & (traversed . _2 . traversed . _1) %%~ CV.referentPGTo2
   typeNames <- pgTypeNames & (traversed . _2 . traversed) %%~ CV.referencePGTo2
   pure (termNames, typeNames)
diff --git a/src/Share/Postgres/NameLookups/Queries.hs b/src/Share/Postgres/NameLookups/Queries.hs
@@ -25,7 +25,6 @@ where
 
 import Control.Lens hiding (from)
 import Data.Foldable qualified as Foldable
-import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as Text
 import Share.Postgres
 import Share.Postgres qualified as PG
@@ -307,13 +306,35 @@ listNameLookupMounts !_nameLookupReceipt rootBranchHashId =
          in (mountPath, mountedRootBranchHashId)
 
 -- | Larger is better.
-type FuzzySearchScore = (Bool, Bool, Int64, Int64)
+data FuzzySearchScore
+  = FuzzySearchScore
+  { exactLastSegmentMatch :: Bool,
+    lastSegmentInfixMatch :: Bool,
+    lastSegmentMatchPos :: Int64,
+    inverseNameLength :: Int64
+  }
+  deriving (Show, Eq)
+
+instance Ord FuzzySearchScore where
+  compare (FuzzySearchScore exact1 infix1 pos1 len1) (FuzzySearchScore exact2 infix2 pos2 len2) =
+    exact1 `compare` exact2
+      <> infix1 `compare` infix2
+      <> pos1 `compare` pos2
+      <> len1 `compare` len2
+
+instance DecodeRow FuzzySearchScore where
+  decodeRow =
+    FuzzySearchScore
+      <$> PG.decodeField
+      <*> PG.decodeField
+      <*> PG.decodeField
+      <*> PG.decodeField
 
 -- | Searches for all names within the given name lookup which contain the provided list of segments
 -- in order.
 -- Search is case insensitive.
-fuzzySearchTerms :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef (PGReferent, Maybe ConstructorType))]
-fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace querySegments = do
+fuzzySearchTerms :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> Text -> m [(FuzzySearchScore, NamedRef (PGReferent, Maybe ConstructorType))]
+fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace querySegments lastSearchTerm = do
   fmap unRow
     <$> PG.queryListRows
       [PG.sql|
@@ -322,7 +343,7 @@ fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace qu
       FROM (
         SELECT reversed_name, referent_builtin, referent_component_hash_id, referent_component_index, referent_constructor_index, referent_constructor_type, last_name_segment,
               (last_name_segment = #{lastSearchTerm}) AS exact_last_segment_match,
-              (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%') AS last_segment_infix_match,
+              (last_name_segment ILIKE ('%' || like_escape(#{lastSearchTerm}) || '%')) AS last_segment_infix_match,
               (-POSITION(#{lastSearchTerm} IN last_name_segment)) AS last_segment_match_pos,
               (-length(reversed_name)) AS inverse_name_length
           FROM scoped_term_name_lookup
@@ -335,22 +356,21 @@ fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace qu
       -- Exact last-segment matches first, then last-segment infix matches sorting prefix
       -- matches first, then prefer shorter names.
       ORDER BY (last_name_segment = #{lastSearchTerm},
-               (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%'),
+               (#{lastSearchTerm} ILIKE ('%' || like_escape(last_name_segment) || '%')),
                (-POSITION(#{lastSearchTerm} IN last_name_segment)),
                (-length(reversed_name))
                ) DESC
       LIMIT #{limit}
             |]
   where
-    lastSearchTerm = NEL.last querySegments
     namespacePrefix = toNamespacePrefix namespace
     -- Union in the dependencies if required.
     dependenciesSql =
       [PG.sql|
       UNION ALL
         SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash_id, referent_component_index, referent_constructor_index, referent_constructor_type, last_name_segment,
              (last_name_segment = #{lastSearchTerm}) AS exact_last_segment_match,
-             (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%') AS last_segment_infix_match,
+             (last_name_segment ILIKE ('%' || like_escape(#{lastSearchTerm}) || '%')) AS last_segment_infix_match,
              (-POSITION(#{lastSearchTerm} IN last_name_segment)) AS last_segment_match_pos,
              (-length(reversed_name)) AS inverse_name_length
         FROM name_lookup_mounts mount
@@ -372,8 +392,8 @@ fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace qu
 -- in order.
 --
 -- Search is case insensitive.
-fuzzySearchTypes :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef PGReference)]
-fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace querySegments = do
+fuzzySearchTypes :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> Text -> m [(FuzzySearchScore, NamedRef PGReference)]
+fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace querySegments lastSearchTerm = do
   fmap unRow
     <$> PG.queryListRows
       [PG.sql|
@@ -383,7 +403,7 @@ fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace qu
       FROM (
         SELECT reversed_name, reference_builtin, reference_component_hash_id, reference_component_index, last_name_segment,
              (last_name_segment = #{lastSearchTerm}) AS exact_last_segment_match,
-             (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%') AS last_segment_infix_match,
+             (last_name_segment ILIKE ('%' || like_escape(#{lastSearchTerm}) || '%')) AS last_segment_infix_match,
              (-POSITION(#{lastSearchTerm} IN last_name_segment)) AS last_segment_match_pos,
              (-length(reversed_name)) AS inverse_name_length
         FROM scoped_type_name_lookup
@@ -396,14 +416,13 @@ fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace qu
       -- Exact last-segment matches first, then last-segment prefix matches, then prefer
       -- shorter names.
       ORDER BY (last_name_segment = #{lastSearchTerm},
-               (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%'),
+               (#{lastSearchTerm} ILIKE ('%' || like_escape(last_name_segment) || '%')),
                (-POSITION(#{lastSearchTerm} IN last_name_segment)),
                (-length(reversed_name))
                ) DESC
       LIMIT #{limit}
           |]
   where
-    lastSearchTerm = NEL.last querySegments
     unRow :: (NamedRef PGReference PG.:. FuzzySearchScore) -> (FuzzySearchScore, NamedRef PGReference)
     unRow (namedRef PG.:. score) = (score, namedRef)
     namespacePrefix = toNamespacePrefix namespace
@@ -413,7 +432,7 @@ fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace qu
       UNION ALL
         SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash_id, reference_component_index, last_name_segment,
              (last_name_segment = #{lastSearchTerm}) AS exact_last_segment_match,
-             (#{lastSearchTerm} ILIKE like_escape('%' || last_name_segment) || '%') AS last_segment_infix_match,
+             (last_name_segment ILIKE ('%' || like_escape('%' || #{lastSearchTerm}) || '%')) AS last_segment_infix_match,
              (-POSITION(#{lastSearchTerm} IN last_name_segment)) AS last_segment_match_pos,
              (-length(reversed_name)) AS inverse_name_length
         FROM name_lookup_mounts mount
diff --git a/src/Unison/Server/Share/FuzzyFind.hs b/src/Unison/Server/Share/FuzzyFind.hs
@@ -18,6 +18,7 @@ import Data.List qualified as List
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.Ord qualified as Ord
 import Data.Text qualified as Text
+import Safe (lastMay)
 import Servant
   ( QueryParam,
     (:>),
@@ -37,9 +38,11 @@ import Unison.Codebase.Editor.DisplayObject
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.ShortCausalHash qualified as SCH
 import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
+import Unison.HashQualifiedPrime qualified as HQ'
 import Unison.NameSegment.Internal (NameSegment (..))
 import Unison.PrettyPrintEnvDecl qualified as PPED
 import Unison.Server.Backend (termEntryLabeledDependencies, typeEntryLabeledDependencies)
+import Unison.Server.Backend qualified as UBackend
 import Unison.Server.Syntax (SyntaxText)
 import Unison.Server.Types
   ( APIGet,
@@ -48,9 +51,8 @@ import Unison.Server.Types
     NamedTerm,
     NamedType,
     UnisonName,
-    mayDefaultWidth,
   )
-import Unison.Symbol (Symbol)
+import Unison.Syntax.Name qualified as Name
 import Unison.Util.Pretty (Width)
 
 type FuzzyFindAPI =
@@ -122,16 +124,18 @@ serveFuzzyFind inScratch searchDependencies rootCausal perspective mayLimit type
   -- Include dependencies if they were explicitly requested OR if we're running a search
   -- from a scratch root
   let includeDependencies = isScratchRootSearch || searchDependencies
-  (dbTermMatches, dbTypeMatches) <- case NonEmpty.nonEmpty preparedQuery of
+  let (querySegments, mayLastQuerySegment) = prepareQuery (Text.unpack query)
+  (dbTermMatches, dbTypeMatches) <- case (NonEmpty.nonEmpty querySegments, mayLastQuerySegment) of
     -- Just return no results if the query is empty
-    Nothing -> empty
-    Just preparedQuery -> do
-      (terms, types) <- NameLookupOps.fuzzySearchDefinitions includeDependencies namesPerspective limit preparedQuery
+    (Nothing, _) -> empty
+    (_, Nothing) -> empty
+    (Just preparedQuery, Just lastSegment) -> do
+      (terms, types) <- NameLookupOps.fuzzySearchDefinitions includeDependencies namesPerspective limit preparedQuery lastSegment
       pure (terms, types)
   let prepareMatch :: NamedRef Backend.FoundRef -> (PathSegments, Alignment, UnisonName, [Backend.FoundRef])
       prepareMatch name@(NamedRef {reversedSegments}) =
         let renderedName = NameLookups.reversedNameToNamespaceText reversedSegments
-            segments = computeMatchSegments preparedQuery name
+            segments = computeMatchSegments querySegments name
             alignment =
               Alignment
                 { -- We used to return a score, but now we just sort all the results server-side.
@@ -168,7 +172,6 @@ serveFuzzyFind inScratch searchDependencies rootCausal perspective mayLimit type
           & fmap snd
   (join <$> traverse (lift . loadEntry includeDependencies bhId namesPerspective) alignments)
   where
-    preparedQuery = prepareQuery (Text.unpack query)
     limit = fromMaybe 10 mayLimit
     loadEntry :: Bool -> BranchHashId -> NameLookups.NamesPerspective -> (PathSegments, Alignment, Text, [Backend.FoundRef]) -> CodebaseM e [(Alignment, FoundResult)]
     loadEntry includeDependencies bhId searchPerspective (pathToMatch, a, n, refs) = do
@@ -194,17 +197,19 @@ serveFuzzyFind inScratch searchDependencies rootCausal perspective mayLimit type
       pped <- PPED.ppedForReferences namesPerspective allLabeledDependencies
       let ppe = PPED.suffixifiedPPE pped
       for entries \case
-        Left (r, termEntry) ->
+        Left (_r, termEntry) ->
           pure
             ( a,
               FoundTermResult
                 . FoundTerm
-                  (Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r)
+                  -- Use the name from the search here rather than the pretty printer best-name
+                  (Name.toText $ HQ'.toName $ UBackend.termEntryHQName termEntry)
                 $ Backend.termEntryToNamedTerm ppe typeWidth termEntry
             )
         Right (r, typeEntry) -> do
           let namedType = Backend.typeEntryToNamedType typeEntry
-          let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r
+          -- Use the name from the search here rather than the pretty printer best-name
+          let typeName = (Name.toText $ HQ'.toName $ UBackend.typeEntryHQName typeEntry)
           typeHeader <- Backend.typeDeclHeader ppe r
           let ft = FoundType typeName typeHeader namedType
           pure (a, FoundTypeResult ft)
@@ -296,39 +301,42 @@ computeMatchSegments query (NamedRef {reversedSegments}) =
 -- names.
 --
 -- >>> prepareQuery "foo bar baz"
--- ["foo","bar","baz"]
+-- (["foo","bar","baz"],Just "baz")
 --
 -- Split camel-case style words into segments.
 -- >>> prepareQuery "fMap"
--- ["f","Map"]
+-- (["f","Map"],Just "fMap")
 --
 -- Collapse multiple spaces
 -- >>> prepareQuery "foo barBaz    boom"
--- ["foo","bar","Baz","boom"]
+-- (["foo","bar","Baz","boom"],Just "boom")
 --
 -- Split namespaces into segments with a required dot in between.
 -- >>> prepareQuery "List.map"
--- ["List",".","map"]
+-- (["List",".","map"],Just "map")
 --
 -- Shouldn't get multiple splits for capitalized letters
 -- >>> prepareQuery "List.Map"
--- ["List",".","Map"]
-prepareQuery :: String -> [Text]
-prepareQuery query = do
-  word <- words query
-  xs <-
-    word
-      & List.foldl'
-        ( \acc next -> case next of
-            c
-              | Char.isUpper c -> [c] : acc
-              | Char.isSpace c -> "" : acc
-              | c == '.' -> "" : "." : acc
-              | otherwise -> case acc of
-                  [] -> [[c]]
-                  (last : rest) -> (last ++ [c]) : rest
-        )
-        []
-      & reverse
-      & filter (not . null)
-  pure $ Text.pack xs
+-- (["List",".","Map"],Just "Map")
+prepareQuery :: String -> ([Text], Maybe Text)
+prepareQuery query = (querySegments, lastSegment)
+  where
+    lastSegment = lastMay (Text.words (Text.pack query) >>= Text.splitOn ".")
+    querySegments = do
+      word <- words query
+      xs <-
+        word
+          & List.foldl'
+            ( \acc next -> case next of
+                c
+                  | Char.isUpper c -> [c] : acc
+                  | Char.isSpace c -> "" : acc
+                  | c == '.' -> "" : "." : acc
+                  | otherwise -> case acc of
+                      [] -> [[c]]
+                      (last : rest) -> (last ++ [c]) : rest
+            )
+            []
+          & reverse
+          & filter (not . null)
+      pure $ (Text.pack xs)
diff --git a/transcripts/share-apis/branch-browse/branch-find.json b/transcripts/share-apis/branch-browse/branch-find.json
diff --git a/transcripts/share-apis/code-browse/codebase-find.json b/transcripts/share-apis/code-browse/codebase-find.json
