diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 9c5415fdc..b9797f7f7 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -18,6 +18,7 @@ module Unison.Name endsWithReverseSegments, endsWithSegments, stripReversedPrefix, + tryStripReversedPrefix, reverseSegments, segments, suffixes, @@ -160,18 +161,32 @@ endsWithReverseSegments :: Name -> [NameSegment] -> Bool endsWithReverseSegments (Name _ ss0) ss1 = List.NonEmpty.isPrefixOf ss1 ss0 --- >>> stripReversedPrefix "a.b.c" ["b", "a"] --- Just c --- >>> stripReversedPrefix "x.y" ["b", "a"] --- Nothing --- >>> stripReversedPrefix "a.b" ["b", "a"] +-- >>> stripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] +-- Just (Name Relative (NameSegment {toText = "c"} :| [])) +-- >>> stripReversedPrefix (fromReverseSegments ("y" :| ["x"])) ["b", "a"] -- Nothing +-- +-- >>> stripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] +-- Just (Name Relative (NameSegment {toText = "c"} :| [])) stripReversedPrefix :: Name -> [NameSegment] -> Maybe Name stripReversedPrefix (Name p segs) suffix = do stripped <- List.stripSuffix suffix (toList segs) nonEmptyStripped <- List.NonEmpty.nonEmpty stripped pure $ Name p nonEmptyStripped +-- | Like 'stripReversedPrefix' but if the prefix doesn't match, or if it would strip the +-- entire name away just return the original name. +-- +-- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] +-- Name Relative (NameSegment {toText = "c"} :| []) +-- >>> tryStripReversedPrefix (fromReverseSegments ("y" :| ["x"])) ["b", "a"] +-- Name Relative (NameSegment {toText = "y"} :| [NameSegment {toText = "x"}]) +-- +-- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] +-- Name Relative (NameSegment {toText = "c"} :| []) +tryStripReversedPrefix :: Name -> [NameSegment] -> Name +tryStripReversedPrefix n s = fromMaybe n (stripReversedPrefix n s) + -- | @isPrefixOf x y@ returns whether @x@ is a prefix of (or equivalent to) @y@, which is false if one name is relative -- and the other is absolute. -- diff --git a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs index d72c1cd55..f87ed1890 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs @@ -42,17 +42,21 @@ nameSearchForPerspective :: Codebase m v a -> Ops.NamesPerspective -> (NameSearc nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToMountedNameLookup} = do NameSearch {typeSearch, termSearch} where + -- Some searches will provide a fully-qualified name, so we need to strip off the + -- mount-path before we search or it will fail to find anything. + stripMountPathPrefix :: Name -> Name + stripMountPathPrefix name = Name.tryStripReversedPrefix name (reverse $ coerce pathToMountedNameLookup) typeSearch = Search { lookupNames = lookupNamesForTypes, - lookupRelativeHQRefs' = lookupRelativeHQRefsForTypes, + lookupRelativeHQRefs' = lookupRelativeHQRefsForTypes . fmap stripMountPathPrefix, makeResult = \hqname r names -> pure $ SR.typeResult hqname r names, matchesNamedRef = HQ'.matchesNamedReference } termSearch = Search { lookupNames = lookupNamesForTerms, - lookupRelativeHQRefs' = lookupRelativeHQRefsForTerms, + lookupRelativeHQRefs' = lookupRelativeHQRefsForTerms . fmap stripMountPathPrefix, makeResult = \hqname r names -> pure $ SR.termResult hqname r names, matchesNamedRef = HQ'.matchesNamedReferent } diff --git a/unison-share-api/src/Unison/Server/Share/Definitions.hs b/unison-share-api/src/Unison/Server/Share/Definitions.hs index 8be4a3c13..a56c59f1d 100644 --- a/unison-share-api/src/Unison/Server/Share/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Share/Definitions.hs @@ -90,7 +90,9 @@ definitionForHQName perspective rootHash renderWidth suffixifyBindings rt codeba let width = mayDefaultWidth renderWidth let docResults :: Name -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults name = do + Debug.debugM Debug.Server "definitionForHQName: looking up docs for name" name docRefs <- liftIO $ docsForDefinitionName codebase nameSearch name + Debug.debugM Debug.Server "definitionForHQName: Found these docs" docRefs renderDocRefs ppedBuilder width codebase rt docRefs let drDeps = definitionResultsDependencies dr