unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-19 06:17:33 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/trunk' into cp/io-test

Browse Source
This commit is contained in:
Chris Penner 2023-12-13 13:09:40 -08:00
commit 44ee3d604f
34 changed files with 615 additions and 501 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/release.yaml vendored
View File

@ -10,7 +10,7 @@ on:
workflow_dispatch:
inputs:
version:
description: 'Release Version (E.g. M4 or M4a)'
description: 'Release Version (E.g. M4 or M4a or 0.4.1)'
required: true
type: string
target:

28
flake.nix
View File

@ -65,15 +65,27 @@
hpack = unstable.hpack;
};
nixpkgs-devShells = {
only-tools-nixpkgs = unstable.mkShellNoCC {
only-tools-nixpkgs = unstable.mkShell {
name = "only-tools-nixpkgs";
buildInputs = with nixpkgs-packages; [
ghc
ormolu
hls
stack
hpack
];
buildInputs =
let
build-tools = with nixpkgs-packages; [
ghc
ormolu
hls
stack
hpack
];
native-packages = pkgs.lib.optionals pkgs.stdenv.isDarwin
(with unstable.darwin.apple_sdk.frameworks;
[ Cocoa ]);
c-deps = with unstable;
[ pkg-config zlib glibcLocales ];
in
build-tools ++ c-deps ++ native-packages;
shellHook = ''
export LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH
'';
};
};
in

2
parser-typechecker/src/Unison/Codebase/MainTerm.hs
View File

@ -43,7 +43,7 @@ getMainTerm loadTypeOfTerm parseNames mainName mainType =
case HQ.fromString mainName of
Nothing -> pure (NotAFunctionName mainName)
Just hq -> do
let refs = NamesWithHistory.lookupHQTerm hq (NamesWithHistory.NamesWithHistory parseNames mempty)
let refs = NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes hq (NamesWithHistory.NamesWithHistory parseNames mempty)
let a = Parser.Ann.External
case toList refs of
[] -> pure (NotFound mainName)

12
parser-typechecker/src/Unison/Syntax/TermParser.hs
View File

@ -111,7 +111,7 @@ typeLink' :: (Monad m, Var v) => P v m (L.Token Reference)
typeLink' = do
id <- hqPrefixId
ns <- asks names
case NamesWithHistory.lookupHQType (L.payload id) ns of
case NamesWithHistory.lookupHQType NamesWithHistory.IncludeSuffixes (L.payload id) ns of
s
| Set.size s == 1 -> pure $ const (Set.findMin s) <$> id
| otherwise -> customFailure $ UnknownType id s
@ -120,7 +120,7 @@ termLink' :: (Monad m, Var v) => P v m (L.Token Referent)
termLink' = do
id <- hqPrefixId
ns <- asks names
case NamesWithHistory.lookupHQTerm (L.payload id) ns of
case NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes (L.payload id) ns of
s
| Set.size s == 1 -> pure $ const (Set.findMin s) <$> id
| otherwise -> customFailure $ UnknownTerm id s
@ -129,7 +129,7 @@ link' :: (Monad m, Var v) => P v m (Either (L.Token Reference) (L.Token Referent
link' = do
id <- hqPrefixId
ns <- asks names
case (NamesWithHistory.lookupHQTerm (L.payload id) ns, NamesWithHistory.lookupHQType (L.payload id) ns) of
case (NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes (L.payload id) ns, NamesWithHistory.lookupHQType NamesWithHistory.IncludeSuffixes (L.payload id) ns) of
(s, s2) | Set.size s == 1 && Set.null s2 -> pure . Right $ const (Set.findMin s) <$> id
(s, s2) | Set.size s2 == 1 && Set.null s -> pure . Left $ const (Set.findMin s2) <$> id
(s, s2) -> customFailure $ UnknownId id s s2
@ -279,7 +279,7 @@ parsePattern = label "pattern" root
names <- asks names
-- probably should avoid looking up in `names` if `L.payload tok`
-- starts with a lowercase
case NamesWithHistory.lookupHQPattern (L.payload tok) ct names of
case NamesWithHistory.lookupHQPattern NamesWithHistory.IncludeSuffixes (L.payload tok) ct names of
s
| Set.null s -> die tok s
| Set.size s > 1 -> die tok s
@ -420,7 +420,7 @@ resolveHashQualified tok = do
names <- asks names
case L.payload tok of
HQ.NameOnly n -> pure $ Term.var (ann tok) (Name.toVar n)
_ -> case NamesWithHistory.lookupHQTerm (L.payload tok) names of
_ -> case NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes (L.payload tok) names of
s
| Set.null s -> failCommitted $ UnknownTerm tok s
| Set.size s > 1 -> failCommitted $ UnknownTerm tok s
@ -1151,7 +1151,7 @@ substImports ns imports =
-- not in Names, but in a later term binding
[ (suffix, Type.var () full)
| (suffix, full) <- imports,
NamesWithHistory.hasTypeNamed (Name.unsafeFromVar full) ns
NamesWithHistory.hasTypeNamed NamesWithHistory.IncludeSuffixes (Name.unsafeFromVar full) ns
]
block' :: (Monad m, Var v) => IsTop -> String -> P v m (L.Token ()) -> P v m (L.Token ()) -> TermP v m

2
parser-typechecker/src/Unison/Syntax/TypeParser.hs
View File

@ -41,7 +41,7 @@ typeAtom =
HQ.NameOnly n -> pure $ Type.var (ann tok) (Name.toVar n)
hq -> do
names <- asks names
let matches = Names.lookupHQType hq names
let matches = Names.lookupHQType Names.IncludeSuffixes hq names
if Set.size matches /= 1
then P.customFailure (UnknownType tok matches)
else pure $ Type.ref (ann tok) (Set.findMin matches)

56
parser-typechecker/src/Unison/Typechecker.hs
View File

@ -32,8 +32,10 @@ import Control.Monad.State
modify,
)
import Control.Monad.Writer
import Data.Foldable
import Data.Map qualified as Map
import Data.Sequence.NonEmpty qualified as NESeq (toSeq)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Unison.ABT qualified as ABT
import Unison.Blank qualified as B
@ -229,16 +231,13 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
case catMaybes resolutions of
[] -> pure oldType
rs ->
let goAgain =
any ((== 1) . length . dedupe . filter Context.isExact . suggestions) rs
in if goAgain
then do
traverse_ substSuggestion rs
synthesizeAndResolve ppe tdnrEnv
else do
-- The type hasn't changed
liftResult $ suggest rs
pure oldType
applySuggestions rs >>= \case
True -> do
synthesizeAndResolve ppe tdnrEnv
False -> do
-- The type hasn't changed
liftResult $ suggest rs
pure oldType
where
addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) ()
addTypedComponent (Context.TopLevelComponent vtts) =
@ -268,23 +267,50 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
Var.MissingResult -> v
_ -> Var.named name
substSuggestion :: Resolution v loc -> TDNR f v loc ()
extractSubstitution :: [Context.Suggestion v loc] -> Maybe (Either v Referent)
extractSubstitution suggestions =
let groupedByName :: [([Name.Name], Either v Referent)] =
map (\(a, b) -> (b, a))
. Map.toList
. fmap Set.toList
. foldl'
( \b Context.Suggestion {suggestionName, suggestionReplacement} ->
Map.insertWith
Set.union
suggestionReplacement
(Set.singleton (Name.unsafeFromText suggestionName))
b
)
Map.empty
$ filter Context.isExact suggestions
matches :: Set (Either v Referent) = Name.preferShallowLibDepth groupedByName
in case toList matches of
[x] -> Just x
_ -> Nothing
applySuggestions :: [Resolution v loc] -> TDNR f v loc Bool
applySuggestions = foldlM phi False
where
phi b a = do
didSub <- substSuggestion a
pure $! b || didSub
substSuggestion :: Resolution v loc -> TDNR f v loc Bool
substSuggestion
( Resolution
name
_
loc
v
( filter Context.isExact ->
[Context.Suggestion _ _ replacement Context.Exact]
)
(extractSubstitution -> Just replacement)
) =
do
modify (substBlank (Text.unpack name) loc solved)
lift . btw $ Context.Decision (suggestedVar v name) loc solved
pure True
where
solved = either (Term.var loc) (Term.fromReferent loc) replacement
substSuggestion _ = pure ()
substSuggestion _ = pure False
-- Resolve a `Blank` to a term
substBlank :: String -> loc -> Term v loc -> Term v loc -> Term v loc

6
scripts/make-release.sh
View File

@ -17,6 +17,8 @@ usage() {
echo ""
echo "E.g."
echo "$0 M4a"
echo ""
echo "The latest release is: $(git tag --list 'release/*' | sort -r | head -n 1 | sed 's/release\///')"
}
if [[ -z "$1" ]] ; then
@ -29,8 +31,8 @@ if ! command -V "gh" >/dev/null 2>&1; then
exit 1
fi
if ! [[ "$1" =~ ^M[0-9]+[a-z]?$ ]] ; then
echo "Version tag must be of the form 'M4' or 'M4a'"
if ! [[ "$1" =~ ^[0-9]+\.[0-9]+\.[0-9]+$ ]] ; then
echo "Version tag must be of the form 'x.y.z' where x, y, and z are nonnegative integers."
usage
exit 1
fi

39
scripts/previous-tag.sh
View File

@ -17,19 +17,34 @@ if ! ("$awk_exe" --version | grep GNU) >/dev/null 2>&1; then
exit 1
fi
if ! [[ "$1" =~ ^M[0-9]+[a-z]?$ ]] ; then
echo "Version tag must be of the form 'M4' or 'M4a'. E.g."
echo "$0 M4a"
input_version="$1"
if ! [[ "$input_version" =~ ^[0-9]+\.[0-9]+\.[0-9]+$ ]] ; then
echo "Version tag must be of the form 'x.y.z' where x, y, and z are nonnegative integers. e.g."
echo "$0 0.5.11"
exit 1
fi
echo "$1" | $awk_exe '
# This script figures out a previous tag for a given release to make release notes from.
if [[ "$input_version" == "0.5.11" ]]; then
echo "M5j"
else
IFS='.' read -r -a version_parts <<< "$input_version"
major=${version_parts[0]}
minor=${version_parts[1]}
patch=${version_parts[2]}
# The previous release of something like M4a is just M4
match($0, /^(\w[0-9]+)a$/, a) {print a[1]}
# The previous release of something like M4 is M3, since we want to show off everything since the last major release
match($0, /^\w([0-9]+)$/, a) {print "M" a[1] - 1}
# The previous release of something like M4b is M4a
match($0, /^(\w[0-9]+)([b-z])$/, a) {printf a[1]; system("echo " a[2] " | tr b-z a-y")}
'
if [[ "$patch" -gt 0 ]]; then
patch=$((patch - 1))
echo "$major.$minor.$patch"
elif [[ "$minor" -gt 0 ]]; then
minor=$((minor - 1))
tag=$(git tag --list "release/$major.$minor.*" | sort -r | head -n 1)
echo "${tag#release/}"
elif [[ "$major" -gt 0 ]]; then
major=$((major - 1))
tag=$(git tag --list "release/$major.*" | sort -r | head -n 1)
echo "${tag#release/}"
else
echo "Idk what to do with $input_version".
fi
fi

33
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -239,7 +239,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) =
@ -561,16 +561,17 @@ loop e = do
let nameSearch = NameSearch.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames basicPrettyPrintNames)
Cli.Env {codebase, runtime} <- ask
mdText <- liftIO $ do
docRefs <- Backend.docsForDefinitionName codebase nameSearch docName
docRefs <- Backend.docsForDefinitionName codebase nameSearch NamesWithHistory.IncludeSuffixes docName
for docRefs $ \docRef -> do
Identity (_, _, doc) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
pure . Md.toText $ Md.toMarkdown doc
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
DocsToHtmlI namespacePath' sourceDirectory -> do
Cli.Env {codebase, sandboxedRuntime} <- ask
rootBranch <- Cli.getRootBranch
absPath <- Path.unabsolute <$> Cli.resolvePath' namespacePath'
liftIO (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase rootBranch absPath sourceDirectory)
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase rootBranch absPath sourceDirectory)
pure ()
AliasTermI src' dest' -> do
Cli.Env {codebase} <- ask
src <- traverseOf _Right Cli.resolveSplit' src'
@ -715,8 +716,8 @@ loop e = do
pure (currentNames, pped)
let unsuffixifiedPPE = PPED.unsuffixifiedPPE pped
terms = NamesWithHistory.lookupHQTerm query names
types = NamesWithHistory.lookupHQType query names
terms = NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes query names
types = NamesWithHistory.lookupHQType NamesWithHistory.IncludeSuffixes query names
terms' :: [(Referent, [HQ'.HashQualified Name])]
terms' = map (\r -> (r, PPE.allTermNames unsuffixifiedPPE r)) (Set.toList terms)
types' :: [(Reference, [HQ'.HashQualified Name])]
@ -937,8 +938,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
@ -1666,7 +1667,7 @@ lookupRewrite onErr prepare rule = do
ot <- case ot of
Just _ -> pure ot
Nothing -> do
case NamesWithHistory.lookupHQTerm rule currentNames of
case NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes rule currentNames of
s
| Set.size s == 1,
Referent.Ref (Reference.DerivedId r) <- Set.findMin s ->
@ -1969,7 +1970,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
@ -2622,7 +2623,7 @@ displayI prettyPrintNames outputLoc hq = do
case addWatch (HQ.toString hq) latestTypecheckedFile of
Nothing -> do
let parseNames = (`NamesWithHistory.NamesWithHistory` mempty) prettyPrintNames
results = NamesWithHistory.lookupHQTerm hq parseNames
results = NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes hq parseNames
pped <- prettyPrintEnvDecl parseNames
ref <-
Set.asSingleton results & onNothing do
@ -2663,7 +2664,7 @@ docsI srcLoc prettyPrintNames src =
fileByName = do
ns <- maybe mempty UF.typecheckedToNames <$> Cli.getLatestTypecheckedFile
fnames <- pure $ NamesWithHistory.NamesWithHistory ns mempty
case NamesWithHistory.lookupHQTerm dotDoc fnames of
case NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes dotDoc fnames of
s | Set.size s == 1 -> do
-- the displayI command expects full term names, so we resolve
-- the hash back to its full name in the file
@ -2689,7 +2690,7 @@ docsI srcLoc prettyPrintNames src =
codebaseByName :: Cli ()
codebaseByName = do
parseNames <- basicParseNames
case NamesWithHistory.lookupHQTerm dotDoc (NamesWithHistory.NamesWithHistory parseNames mempty) of
case NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes dotDoc (NamesWithHistory.NamesWithHistory parseNames mempty) of
s
| Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc
| Set.size s == 0 -> Cli.respond $ ListOfLinks PPE.empty []
@ -2901,8 +2902,8 @@ executePPE ::
executePPE unisonFile =
suffixifiedPPE =<< displayNames unisonFile
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
@ -2910,7 +2911,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.

3
unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs
View File

@ -25,6 +25,7 @@ import Unison.Name (Name)
import Unison.Names (Names)
import Unison.NamesWithHistory
( NamesWithHistory (..),
SearchType (..),
lookupHQTerm,
)
import Unison.Parser.Ann (Ann)
@ -41,7 +42,7 @@ addHistory :: Names -> NamesWithHistory
addHistory names = NamesWithHistory names mempty
lookupTerm :: HQ.HashQualified Name -> Names -> [Referent]
lookupTerm hq parseNames = toList (lookupHQTerm hq hnames)
lookupTerm hq parseNames = toList (lookupHQTerm IncludeSuffixes hq hnames)
where
hnames = addHistory parseNames

2
unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs
View File

@ -192,7 +192,7 @@ resolveHQNames parseNames hqNames =
getNameFromCodebase parseNames main = do
Cli.Env {codebase} <- ask
mapMaybeT Cli.runTransaction do
(Set.toList (NamesWithHistory.lookupHQTerm main parseNames)) & altMap \ref0 -> do
(Set.toList (NamesWithHistory.lookupHQTerm NamesWithHistory.IncludeSuffixes main parseNames)) & altMap \ref0 -> do
ref <- hoistMaybe (Referent.toTermReferenceId ref0)
typ <- MaybeT (Codebase.getTypeOfReferent codebase (Referent.fromTermReferenceId ref))
pure (ref, typ)

15
unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs
View File

@ -150,7 +150,7 @@ handleUpdate2 = do
Cli.respond Output.UpdateTypecheckingSuccess
pure secondTuf
saveTuf (findCtorNames namesExcludingLibdeps ctorNames Nothing) secondTuf
saveTuf (findCtorNames Output.UOUUpdate namesExcludingLibdeps ctorNames Nothing) secondTuf
Cli.respond Output.Success
-- TODO: find a better module for this function, as it's used in a couple places
@ -284,7 +284,7 @@ buildBigUnisonFile ::
Map ForwardName (Referent, Name) ->
Transaction (UnisonFile Symbol Ann)
buildBigUnisonFile abort c tuf dependents names ctorNames =
addDefinitionsToUnisonFile abort c names ctorNames dependents (UF.discardTypes tuf)
addDefinitionsToUnisonFile Output.UOUUpdate abort c names ctorNames dependents (UF.discardTypes tuf)
-- | @addDefinitionsToUnisonFile abort codebase names ctorNames definitions file@ adds all @definitions@ to @file@, avoiding
-- overwriting anything already in @file@. Every definition is put into the file with every naming it has in @names@ "on
@ -292,6 +292,7 @@ buildBigUnisonFile abort c tuf dependents names ctorNames =
--
-- TODO: find a better module for this function, as it's used in a couple places
addDefinitionsToUnisonFile ::
Output.UpdateOrUpgrade ->
(forall void. Output -> Transaction void) ->
Codebase IO Symbol Ann ->
Names ->
@ -299,7 +300,7 @@ addDefinitionsToUnisonFile ::
Map Reference.Id ReferenceType ->
UnisonFile Symbol Ann ->
Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile abort c names ctorNames dependents initialUnisonFile =
addDefinitionsToUnisonFile operation abort c names ctorNames dependents initialUnisonFile =
-- for each dependent, add its definition with all its names to the UnisonFile
foldM addComponent initialUnisonFile (Map.toList dependents')
where
@ -358,7 +359,7 @@ addDefinitionsToUnisonFile abort c names ctorNames dependents initialUnisonFile
overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames name dd =
let constructorNames :: Transaction [Symbol]
constructorNames = case findCtorNames names ctorNames (Just $ Decl.constructorCount dd) name of
constructorNames = case findCtorNames operation names ctorNames (Just $ Decl.constructorCount dd) name of
Left err -> abort err
Right array ->
case traverse (fmap Name.toVar . Name.stripNamePrefix name) array of
@ -387,8 +388,8 @@ forwardCtorNames names =
]
-- | given a decl name, find names for all of its constructors, in order.
findCtorNames :: Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
findCtorNames names forwardCtorNames ctorCount n =
findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
findCtorNames operation names forwardCtorNames ctorCount n =
let declRef = Set.findMin $ Relation.lookupDom n names.types
f = ForwardName.fromName n
(_, centerRight) = Map.split f forwardCtorNames
@ -407,7 +408,7 @@ findCtorNames names forwardCtorNames ctorCount n =
ctorCountGuess = fromMaybe (Map.size m) ctorCount
in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m . fromIntegral) [0 .. ctorCountGuess - 1]
then Right $ Map.elems m
else Left $ Output.UpdateIncompleteConstructorSet n m ctorCount
else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount
-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly.
-- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux"

215
unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs
View File

@ -34,6 +34,7 @@ import Unison.Codebase.Editor.HandleInput.Update2
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.HashQualified' qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
@ -47,9 +48,14 @@ import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
import Unison.Reference (TermReference, TypeReference)
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.UnisonFile qualified as UnisonFile
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Witch (unsafeFrom)
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
@ -67,10 +73,14 @@ handleUpgrade oldDepName newDepName = do
currentV1Branch <- Cli.getBranch0At projectPath
let currentV1BranchWithoutOldDep = deleteLibdep oldDepName currentV1Branch
oldDepV1Branch <- Cli.expectBranch0AtPath' oldDepPath
_newDepV1Branch <- Cli.expectBranch0AtPath' newDepPath
oldDep <- Cli.expectBranch0AtPath' oldDepPath
let oldDepWithoutDeps = deleteLibdeps oldDep
let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup Name.libSegment (oldDep ^. Branch.children)
let namesExcludingLibdeps = Branch.toNames (currentV1Branch & over Branch.children (Map.delete Name.libSegment))
newDep <- Cli.expectBranch0AtPath' newDepPath
let newDepWithoutDeps = deleteLibdeps newDep
let namesExcludingLibdeps = Branch.toNames (deleteLibdeps currentV1Branch)
let constructorNamesExcludingLibdeps = forwardCtorNames namesExcludingLibdeps
let namesExcludingOldDep = Branch.toNames currentV1BranchWithoutOldDep
@ -101,15 +111,59 @@ handleUpgrade oldDepName newDepName = do
--
-- mything#mything2 = #newfoo + 10
let filterUnchangedTerms :: Relation Referent Name -> Set TermReference
filterUnchangedTerms oldTerms =
let phi ref oldNames = case Referent.toTermReference ref of
Nothing -> Set.empty
Just termRef ->
let newNames = Relation.lookupDom ref newTerms
in case newNames `Set.disjoint` oldNames of
True -> Set.singleton termRef
False -> Set.empty
in Map.foldMapWithKey phi $
Relation.domain oldTerms
where
newTerms = Branch.deepTerms newDepWithoutDeps
let filterUnchangedTypes :: Relation TypeReference Name -> Set TypeReference
filterUnchangedTypes oldTypes =
let phi typeRef oldNames =
let newNames = Relation.lookupDom typeRef newTypes
in case newNames `Set.disjoint` oldNames of
True -> Set.singleton typeRef
False -> Set.empty
in Map.foldMapWithKey phi $
Relation.domain oldTypes
where
newTypes = Branch.deepTypes newDepWithoutDeps
let filterTransitiveTerms :: Relation Referent Name -> Set TermReference
filterTransitiveTerms oldTerms =
Relation.dom oldTerms
& Set.mapMaybe \referent -> do
ref <- Referent.toTermReference referent
guard (not $ Relation.memberDom referent (Branch.deepTerms currentV1BranchWithoutOldDep))
pure ref
let filterTransitiveTypes :: Relation TypeReference Name -> Set TypeReference
filterTransitiveTypes oldTypes =
Relation.dom oldTypes
& Set.filter \typ -> not (Relation.memberDom typ (Branch.deepTypes currentV1BranchWithoutOldDep))
(unisonFile, printPPE) <-
Cli.runTransactionWithRollback \abort -> do
-- Create a Unison file that contains all of our dependents of things in `lib.old`.
-- Create a Unison file that contains all of our dependents of modified defns of `lib.old`. todo: twiddle
unisonFile <- do
dependents <-
Operations.dependentsWithinScope
(Names.referenceIds namesExcludingLibdeps)
(Branch.deepTermReferences oldDepV1Branch <> Branch.deepTypeReferences oldDepV1Branch)
( filterUnchangedTerms (Branch.deepTerms oldDepWithoutDeps)
<> filterUnchangedTypes (Branch.deepTypes oldDepWithoutDeps)
<> filterTransitiveTerms (Branch.deepTerms oldTransitiveDeps)
<> filterTransitiveTypes (Branch.deepTypes oldTransitiveDeps)
)
addDefinitionsToUnisonFile
Output.UOUUpgrade
abort
codebase
namesExcludingLibdeps
@ -117,7 +171,7 @@ handleUpgrade oldDepName newDepName = do
dependents
UnisonFile.emptyUnisonFile
hashLength <- Codebase.hashLength
let primaryPPE = makeOldDepPPE newDepName namesExcludingOldDep oldDepV1Branch
let primaryPPE = makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDeps newDepWithoutDeps
let secondaryPPE = PPED.fromNamesDecl hashLength (NamesWithHistory.fromCurrentNames namesExcludingOldDep)
pure (unisonFile, primaryPPE `PPED.addFallback` secondaryPPE)
@ -136,7 +190,14 @@ handleUpgrade oldDepName newDepName = do
let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentV1BranchWithoutOldDep)
Cli.Env {isTranscript} <- ask
maybePath <- if isTranscript then pure Nothing else Just . fst <$> Cli.expectLatestFile
maybePath <-
if isTranscript
then pure Nothing
else do
maybeLatestFile <- Cli.getLatestFile
case maybeLatestFile of
Nothing -> pure (Just "scratch.u")
Just (file, _) -> pure (Just file)
Cli.respond (Output.DisplayDefinitionsString maybePath prettyUnisonFile)
Cli.respond (Output.UpgradeFailure oldDepName newDepName)
Cli.returnEarlyWithoutOutput
@ -146,7 +207,7 @@ handleUpgrade oldDepName newDepName = do
Codebase.addDefsToCodebase codebase typecheckedUnisonFile
typecheckedUnisonFileToBranchUpdates
abort
(findCtorNames namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
(findCtorNames Output.UOUUpgrade namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
typecheckedUnisonFile
Cli.stepAt
textualDescriptionOfUpgrade
@ -159,97 +220,71 @@ handleUpgrade oldDepName newDepName = do
textualDescriptionOfUpgrade =
Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
-- `makeOldDepPPE newDepName namesExcludingOldDep oldDepBranch` makes a PPE(D) that only knows how to render `old` deps;
-- other names should be provided by some fallback PPE.
--
-- How we render `old` deps is rather subtle and complicated, but the basic idea is that an `upgrade old new` ought to
-- render all of the old things like `lib.old.foo#oldfoo` as `lib.new.foo` to be parsed and typechecked.
--
-- To render some reference #foo, if it's not a reference that's directly part of old's API (i.e. it has some name in
-- `lib.old.*` that isn't in one of old's deps `lib.old.lib.*`, then return the empty list of names. (Again, the
-- fallback PPE will ultimately provide a name for such a #foo).
--
-- Otherwise, we have some #foo that has at least one name in `lib.old.*`; say it's called `lib.old.foo`. The goal is to
-- render this as `lib.new.foo`, regardless of how many other aliases #foo has in the namespace. (It may be the case
-- that #foo has a name outside of the libdeps, like `my.name.for.foo`, or maybe it has a name in another dependency
-- entirely, like `lib.otherdep.othername`).
makeOldDepPPE :: NameSegment -> Names -> Branch0 m -> PrettyPrintEnvDecl
makeOldDepPPE newDepName namesExcludingOldDep oldDepBranch =
makeOldDepPPE ::
NameSegment ->
NameSegment ->
Names ->
Branch0 m ->
Branch0 m ->
Branch0 m ->
PrettyPrintEnvDecl
makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDeps newDepWithoutDeps =
let makePPE suffixifyTerms suffixifyTypes =
PrettyPrintEnv
{ termNames = \ref ->
if Set.member ref termsDirectlyInOldDep
then
-- Say ref is #oldfoo, with two names in `old`:
--
-- [ lib.old.foo, lib.old.fooalias ]
--
-- We start from that same list of names with `new` swapped in for `old`:
--
-- [ lib.new.foo, lib.new.fooalias ]
Names.namesForReferent fakeNames ref
& Set.toList
-- We manually lift those to hashless hash-qualified names, which isn't a very significant
-- implementation detail, we just happen to not want hashes, even if the old name like "lib.old.foo"
-- was conflicted in `old`.
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
-- We find the shortest unique suffix of each name in a naming context which:
--
-- 1. Starts from all names, minus the entire `lib.old` namespace.
--
-- 2. Deletes every name for references directly in `lib.old` (i.e. in `lib.old.*` without having
-- to descend into some `lib.old.lib.*`.
--
-- For example, if there's both
--
-- lib.old.foo#oldfoo
-- someAlias#oldfoo
--
-- then (again, because #oldfoo has a name directly in `lib.old`), we delete names like
-- `someAlias#oldfoo`.
--
-- 3. Adds back in names like `lib.new.*` for every hash directly referenced in `lib.old.*`, which
-- would be
--
-- [ lib.new.foo#oldfoo, lib.new.fooalias#oldfoo ]
& suffixifyTerms
& PPE.Names.prioritize
else [],
let oldDirectNames = Relation.lookupDom ref (Branch.deepTerms oldDepWithoutDeps)
newDirectRefsForOldDirectNames =
Relation.range (Branch.deepTerms newDepWithoutDeps) `Map.restrictKeys` oldDirectNames
in case ( Set.null oldDirectNames,
Map.null newDirectRefsForOldDirectNames,
Set.member ref (Branch.deepReferents oldDep),
Relation.memberRan ref (Names.terms namesExcludingOldDep)
) of
(False, False, _, _) ->
Names.namesForReferent fakeNames ref
& Set.toList
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
& suffixifyTerms
& PPE.Names.prioritize
(_, _, True, False) ->
Names.namesForReferent prefixedOldNames ref
& Set.toList
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
& PPE.Names.prioritize
_ -> [],
typeNames = \ref ->
if Set.member ref typesDirectlyInOldDep
then
Names.namesForReference fakeNames ref
& Set.toList
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
& suffixifyTypes
& PPE.Names.prioritize
else []
let oldDirectNames = Relation.lookupDom ref (Branch.deepTypes oldDepWithoutDeps)
newDirectRefsForOldDirectNames =
Relation.range (Branch.deepTypes newDepWithoutDeps) `Map.restrictKeys` oldDirectNames
in case ( Set.null oldDirectNames,
Map.null newDirectRefsForOldDirectNames,
Set.member ref (Branch.deepTypeReferences oldDep),
Relation.memberRan ref (Names.types namesExcludingOldDep)
) of
(False, False, _, _) ->
Names.namesForReference fakeNames ref
& Set.toList
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
& suffixifyTypes
& PPE.Names.prioritize
(_, _, True, False) ->
Names.namesForReference prefixedOldNames ref
& Set.toList
& map (\name -> (HQ'.fromName name, HQ'.fromName name))
& PPE.Names.prioritize
_ -> []
}
in PrettyPrintEnvDecl
{ unsuffixifiedPPE = makePPE id id,
suffixifiedPPE =
makePPE
( PPE.Names.shortestUniqueSuffixes $
namesExcludingOldDep
& Names.terms
& Relation.subtractRan termsDirectlyInOldDep
& Relation.union (Names.terms fakeNames)
)
( PPE.Names.shortestUniqueSuffixes $
namesExcludingOldDep
& Names.types
& Relation.subtractRan typesDirectlyInOldDep
& Relation.union (Names.types fakeNames)
)
(PPE.Names.shortestUniqueSuffixes (Names.terms namesExcludingOldDep))
(PPE.Names.shortestUniqueSuffixes (Names.types namesExcludingOldDep))
}
where
oldDepWithoutItsDeps = over Branch.children (Map.delete Name.libSegment) oldDepBranch
termsDirectlyInOldDep = Branch.deepReferents oldDepWithoutItsDeps
typesDirectlyInOldDep = Branch.deepTypeReferences oldDepWithoutItsDeps
fakeNames =
oldDepWithoutItsDeps
& Branch.toNames
& Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment]))
oldNames = Branch.toNames oldDep
prefixedOldNames = Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) oldNames
fakeNames = Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment])) oldNames
-- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name
-- like "upgrade-<oldDepName>-to-<newDepName>".
@ -283,3 +318,7 @@ findTemporaryBranchName projectId oldDepName newDepName = do
deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m
deleteLibdep dep =
over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep)
deleteLibdeps :: Branch0 m -> Branch0 m
deleteLibdeps =
over Branch.children (Map.delete Name.libSegment)

5
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -11,6 +11,7 @@ module Unison.Codebase.Editor.Output
TestReportStats (..),
UndoFailureReason (..),
ShareError (..),
UpdateOrUpgrade (..),
isFailure,
isNumberedFailure,
)
@ -391,10 +392,12 @@ data Output
| UpdateStartTypechecking
| UpdateTypecheckingFailure
| UpdateTypecheckingSuccess
| UpdateIncompleteConstructorSet Name (Map ConstructorId Name) (Maybe Int)
| UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int)
| UpgradeFailure !NameSegment !NameSegment
| UpgradeSuccess !NameSegment !NameSegment
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
-- | What did we create a project branch from?
--
-- * Loose code

40
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -2191,25 +2191,27 @@ notifyUser dir = \case
<> "Once the file is compiling, try"
<> makeExample' IP.update
<> "again."
UpdateIncompleteConstructorSet name ctorMap expectedCount ->
pure $
P.lines
[ P.wrap $
"I couldn't complete the update because I couldn't find"
<> fromString (maybe "" show expectedCount)
<> "constructor(s) for"
<> prettyName name
<> "where I expected to."
<> "I found:"
<> fromString (show (Map.toList ctorMap)),
"",
P.wrap $
"You can use"
<> P.indentNAfterNewline 2 (IP.makeExample IP.view [prettyName name])
<> "and"
<> P.indentNAfterNewline 2 (IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"])
<> "to give names to each constructor, and then try again."
]
UpdateIncompleteConstructorSet operation typeName _ctorMap _expectedCount ->
let operationName = case operation of E.UOUUpdate -> "update"; E.UOUUpgrade -> "upgrade"
in pure $
P.lines
[ P.wrap $
"I couldn't complete the"
<> operationName
<> "because the type"
<> prettyName typeName
<> "has unnamed constructors."
<> "(I currently need each constructor to have a name somewhere under the type name.)",
"",
P.wrap $
"You can use"
<> P.indentNAfterNewline 2 (IP.makeExample IP.view [prettyName typeName])
<> "and"
<> P.indentNAfterNewline 2 (IP.makeExample IP.aliasTerm ["<hash>", prettyName typeName <> ".<ConstructorName>"])
<> "to give names to each constructor, and then try the"
<> operationName
<> "again."
]
UpgradeFailure old new ->
pure . P.wrap $
"I couldn't automatically upgrade"

5
unison-cli/src/Unison/LSP/Queries.hs
View File

@ -37,6 +37,7 @@ import Unison.LabeledDependency
import Unison.LabeledDependency qualified as LD
import Unison.Lexer.Pos (Pos (..))
import Unison.Name (Name)
import Unison.NamesWithHistory (SearchType (..))
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Ann
import Unison.Pattern qualified as Pattern
@ -386,7 +387,7 @@ markdownDocsForFQN fileUri fqn =
nameSearch <- lift $ getNameSearch
Env {codebase, runtime} <- ask
liftIO $ do
docRefs <- Backend.docsForDefinitionName codebase nameSearch name
docRefs <- Backend.docsForDefinitionName codebase nameSearch ExactName name
for docRefs $ \docRef -> do
Identity (_, _, doc) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
pure . Md.toText $ Md.toMarkdown doc

57
unison-core/src/Unison/Name.hs
View File

@ -35,16 +35,17 @@ module Unison.Name
unqualified,
-- * To organize later
libSegment,
sortNames,
sortNamed,
sortByText,
searchBySuffix,
searchByRankedSuffix,
suffixFrom,
shortestUniqueSuffix,
commonPrefix,
libSegment,
preferShallowLibDepth,
searchByRankedSuffix,
searchBySuffix,
shortestUniqueSuffix,
sortByText,
sortNamed,
sortNames,
splits,
suffixFrom,
-- * Re-exports
module Unison.Util.Alphabetical,
@ -333,23 +334,29 @@ searchBySuffix suffix rel =
-- Example: foo.bar shadows lib.foo.bar
-- Example: lib.foo.bar shadows lib.blah.lib.foo.bar
searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
searchByRankedSuffix suffix rel = case searchBySuffix suffix rel of
rs | Set.size rs <= 1 -> rs
rs -> case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
-- anything with more than one lib in it is treated the same
Nothing -> rs
Just rs -> Set.fromList rs
where
byDepth =
List.multimap
[ (minLibs ns, r)
| r <- toList rs,
ns <- [filter ok (toList (R.lookupRan r rel))]
]
libCount = length . filter (== libSegment) . toList . reverseSegments
minLibs [] = 0
minLibs ns = minimum (map libCount ns)
ok name = compareSuffix suffix name == EQ
searchByRankedSuffix suffix rel =
let rs = searchBySuffix suffix rel
in case Set.size rs <= 1 of
True -> rs
False ->
let ok name = compareSuffix suffix name == EQ
withNames = map (\r -> (filter ok (toList (R.lookupRan r rel)), r)) (toList rs)
in preferShallowLibDepth withNames
-- | precondition: input list is deduped, and so is the Name list in
-- the tuple
preferShallowLibDepth :: Ord r => [([Name], r)] -> Set r
preferShallowLibDepth = \case
[] -> Set.empty
[x] -> Set.singleton (snd x)
rs ->
let byDepth = List.multimap (map (first minLibs) rs)
libCount = length . filter (== libSegment) . toList . reverseSegments
minLibs [] = 0
minLibs ns = minimum (map libCount ns)
in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
Nothing -> Set.fromList (map snd rs)
Just rs -> Set.fromList rs
libSegment :: NameSegment
libSegment = NameSegment "lib"

106
unison-core/src/Unison/NamesWithHistory.hs
View File

@ -1,6 +1,32 @@
{-# LANGUAGE RecordWildCards #-}
module Unison.NamesWithHistory where
module Unison.NamesWithHistory
( NamesWithHistory (..),
fromCurrentNames,
filterTypes,
diff,
push,
shadowing,
lookupHQType,
lookupHQType',
lookupHQTerm,
lookupHQTerm',
lookupRelativeHQType,
lookupRelativeHQType',
lookupRelativeHQTerm,
lookupRelativeHQTerm',
hasTermNamed,
hasTypeNamed,
typeName,
termNamesByLength,
longestTermName,
termName,
importing,
lookupHQPattern,
Diff (..),
SearchType (..),
)
where
import Data.List.Extra (nubOrd)
import Data.Map qualified as Map
@ -21,6 +47,13 @@ import Unison.ShortHash (ShortHash)
import Unison.Util.List qualified as List
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as R
import Unison.Util.Relation qualified as Relation
-- | Whether to search for exact matches or to find definitions by a suffix of their name.
data SearchType
= IncludeSuffixes
| ExactName
deriving (Eq, Ord, Show)
-- | NamesWithHistory contains two sets of 'Names',
-- One represents names which are currently assigned,
@ -120,63 +153,63 @@ shadowing prio (NamesWithHistory current old) =
-- Find all types whose name has a suffix matching the provided `HashQualified`,
-- returning types with relative names if they exist, and otherwise
-- returning types with absolute names.
lookupRelativeHQType :: HashQualified Name -> NamesWithHistory -> Set Reference
lookupRelativeHQType hq ns@NamesWithHistory {..} =
let rs = lookupHQType hq ns
lookupRelativeHQType :: SearchType -> HashQualified Name -> NamesWithHistory -> Set Reference
lookupRelativeHQType searchType hq ns@NamesWithHistory {..} =
let rs = lookupHQType searchType hq ns
keep r = any (not . Name.isAbsolute) (R.lookupRan r (Names.types currentNames))
in case Set.filter keep rs of
rs'
| Set.null rs' -> rs
| otherwise -> rs'
lookupRelativeHQType' :: HQ'.HashQualified Name -> NamesWithHistory -> Set Reference
lookupRelativeHQType' =
lookupRelativeHQType . HQ'.toHQ
lookupRelativeHQType' :: SearchType -> HQ'.HashQualified Name -> NamesWithHistory -> Set Reference
lookupRelativeHQType' searchType =
lookupRelativeHQType searchType . HQ'.toHQ
-- | Find all types whose name has a suffix matching the provided 'HashQualified'.
lookupHQType :: HashQualified Name -> NamesWithHistory -> Set Reference
lookupHQType =
lookupHQRef Names.types Reference.isPrefixOf
lookupHQType :: SearchType -> HashQualified Name -> NamesWithHistory -> Set Reference
lookupHQType searchType =
lookupHQRef searchType Names.types Reference.isPrefixOf
-- | Find all types whose name has a suffix matching the provided 'HashQualified''. See 'lookupHQType'.
lookupHQType' :: HQ'.HashQualified Name -> NamesWithHistory -> Set Reference
lookupHQType' =
lookupHQType . HQ'.toHQ
lookupHQType' :: SearchType -> HQ'.HashQualified Name -> NamesWithHistory -> Set Reference
lookupHQType' searchType =
lookupHQType searchType . HQ'.toHQ
hasTermNamed :: Name -> NamesWithHistory -> Bool
hasTermNamed n ns = not (Set.null $ lookupHQTerm (HQ.NameOnly n) ns)
hasTermNamed :: SearchType -> Name -> NamesWithHistory -> Bool
hasTermNamed searchType n ns = not (Set.null $ lookupHQTerm searchType (HQ.NameOnly n) ns)
hasTypeNamed :: Name -> NamesWithHistory -> Bool
hasTypeNamed n ns = not (Set.null $ lookupHQType (HQ.NameOnly n) ns)
hasTypeNamed :: SearchType -> Name -> NamesWithHistory -> Bool
hasTypeNamed searchType n ns = not (Set.null $ lookupHQType searchType (HQ.NameOnly n) ns)
-- Find all terms whose name has a suffix matching the provided `HashQualified`,
-- returning terms with relative names if they exist, and otherwise
-- returning terms with absolute names.
lookupRelativeHQTerm :: HashQualified Name -> NamesWithHistory -> Set Referent
lookupRelativeHQTerm hq ns@NamesWithHistory {..} =
let rs = lookupHQTerm hq ns
lookupRelativeHQTerm :: SearchType -> HashQualified Name -> NamesWithHistory -> Set Referent
lookupRelativeHQTerm searchType hq ns@NamesWithHistory {..} =
let rs = lookupHQTerm searchType hq ns
keep r = any (not . Name.isAbsolute) (R.lookupRan r (Names.terms currentNames))
in case Set.filter keep rs of
rs'
| Set.null rs' -> rs
| otherwise -> rs'
lookupRelativeHQTerm' :: HQ'.HashQualified Name -> NamesWithHistory -> Set Referent
lookupRelativeHQTerm' =
lookupRelativeHQTerm . HQ'.toHQ
lookupRelativeHQTerm' :: SearchType -> HQ'.HashQualified Name -> NamesWithHistory -> Set Referent
lookupRelativeHQTerm' searchType =
lookupRelativeHQTerm searchType . HQ'.toHQ
-- | Find all terms whose name has a suffix matching the provided 'HashQualified'.
--
-- If the hash-qualified name does not include a hash, then only current names are searched. Otherwise, old names are
-- searched, too, if searching current names produces no hits.
lookupHQTerm :: HashQualified Name -> NamesWithHistory -> Set Referent
lookupHQTerm =
lookupHQRef Names.terms Referent.isPrefixOf
lookupHQTerm :: SearchType -> HashQualified Name -> NamesWithHistory -> Set Referent
lookupHQTerm searchType =
lookupHQRef searchType Names.terms Referent.isPrefixOf
-- | Find all terms whose name has a suffix matching the provided 'HashQualified''. See 'lookupHQTerm'.
lookupHQTerm' :: HQ'.HashQualified Name -> NamesWithHistory -> Set Referent
lookupHQTerm' =
lookupHQTerm . HQ'.toHQ
lookupHQTerm' :: SearchType -> HQ'.HashQualified Name -> NamesWithHistory -> Set Referent
lookupHQTerm' searchType =
lookupHQTerm searchType . HQ'.toHQ
-- Helper that unifies looking up a set of references/referents by a hash-qualified suffix.
--
@ -184,6 +217,7 @@ lookupHQTerm' =
lookupHQRef ::
forall r.
(Ord r) =>
SearchType ->
-- | A projection of types or terms from a Names.
(Names -> Relation Name r) ->
-- | isPrefixOf, for references or referents
@ -192,20 +226,23 @@ lookupHQRef ::
HashQualified Name ->
NamesWithHistory ->
Set r
lookupHQRef which isPrefixOf hq NamesWithHistory {currentNames, oldNames} =
lookupHQRef searchType which isPrefixOf hq NamesWithHistory {currentNames, oldNames} =
case hq of
HQ.NameOnly n -> Name.searchByRankedSuffix n currentRefs
HQ.NameOnly n -> doSearch n currentRefs
HQ.HashQualified n sh -> matches currentRefs `orIfEmpty` matches oldRefs
where
matches :: Relation Name r -> Set r
matches ns =
Set.filter (isPrefixOf sh) (Name.searchByRankedSuffix n ns)
Set.filter (isPrefixOf sh) (doSearch n ns)
HQ.HashOnly sh -> matches currentRefs `orIfEmpty` matches oldRefs
where
matches :: Relation Name r -> Set r
matches ns =
Set.filter (isPrefixOf sh) (R.ran ns)
where
doSearch = case searchType of
IncludeSuffixes -> Name.searchByRankedSuffix
ExactName -> Relation.lookupDom
currentRefs = which currentNames
oldRefs = which oldNames
@ -261,14 +298,15 @@ termName length r NamesWithHistory {..} =
-- Set HashQualified -> Branch m -> Command m i v Names
-- populate historical names
lookupHQPattern ::
SearchType ->
HQ.HashQualified Name ->
CT.ConstructorType ->
NamesWithHistory ->
Set ConstructorReference
lookupHQPattern hq ctt names =
lookupHQPattern searchType hq ctt names =
Set.fromList
[ r
| Referent.Con r ct <- toList $ lookupHQTerm hq names,
| Referent.Con r ct <- toList $ lookupHQTerm searchType hq names,
ct == ctt
]

4
unison-core/src/Unison/Term.hs
View File

@ -161,14 +161,14 @@ bindNames unsafeVarToName keepFreeTerms ns0 e = do
-- !_ = trace "bindNames.free type vars: " ()
-- !_ = traceShow $ fst <$> freeTyVars
okTm :: (v, a) -> Names.ResolutionResult v a (v, Term v a)
okTm (v, a) = case Names.lookupHQTerm (Name.convert $ unsafeVarToName v) ns of
okTm (v, a) = case Names.lookupHQTerm Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of
rs
| Set.size rs == 1 ->
pure (v, fromReferent a $ Set.findMin rs)
| otherwise -> case NES.nonEmptySet rs of
Nothing -> Left (pure (Names.TermResolutionFailure v a Names.NotFound))
Just refs -> Left (pure (Names.TermResolutionFailure v a (Names.Ambiguous ns0 refs)))
okTy (v, a) = case Names.lookupHQType (Name.convert $ unsafeVarToName v) ns of
okTy (v, a) = case Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of
rs
| Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs)
| otherwise -> case NES.nonEmptySet rs of

2
unison-core/src/Unison/Type/Names.hs
View File

@ -22,7 +22,7 @@ bindNames ::
bindNames unsafeVarToName keepFree ns0 t =
let ns = Names.NamesWithHistory ns0 mempty
fvs = ABT.freeVarOccurrences keepFree t
rs = [(v, a, Names.lookupHQType (Name.convert $ unsafeVarToName v) ns) | (v, a) <- fvs]
rs = [(v, a, Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns) | (v, a) <- fvs]
ok (v, a, rs) =
if Set.size rs == 1
then pure (v, Set.findMin rs)

69
unison-share-api/src/Unison/Server/Backend.hs
View File

@ -27,7 +27,7 @@ module Unison.Server.Backend
basicSuffixifiedNames,
bestNameForTerm,
bestNameForType,
definitionsBySuffixes,
definitionsByName,
displayType,
docsInBranchToHtmlFiles,
expandShortCausalHash,
@ -204,6 +204,7 @@ import Unison.Util.Set qualified as Set
import Unison.Util.SyntaxText qualified as UST
import Unison.Var (Var)
import Unison.WatchKind qualified as WK
import UnliftIO qualified
import UnliftIO.Environment qualified as Env
type SyntaxText = UST.SyntaxText' Reference
@ -756,9 +757,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 +785,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 ->
@ -955,17 +957,22 @@ evalDocRef ::
Rt.Runtime Symbol ->
Codebase IO Symbol Ann ->
TermReference ->
IO (Doc.EvaluatedDoc Symbol)
-- Evaluation always produces a doc, (it just might have error messages in it).
-- We still return the errors for logging and debugging.
IO (Doc.EvaluatedDoc Symbol, [Rt.Error])
evalDocRef rt codebase r = do
let tm = Term.ref () r
Doc.evalDoc terms typeOf eval decls tm
errsVar <- UnliftIO.newTVarIO []
evalResult <- Doc.evalDoc terms typeOf (eval errsVar) decls tm
errs <- UnliftIO.readTVarIO errsVar
pure (evalResult, errs)
where
terms r@(Reference.Builtin _) = pure (Just (Term.ref () r))
terms (Reference.DerivedId r) =
fmap Term.unannotate <$> Codebase.runTransaction codebase (Codebase.getTerm codebase r)
typeOf r = fmap void <$> Codebase.runTransaction codebase (Codebase.getTypeOfReferent codebase r)
eval (Term.amap (const mempty) -> tm) = do
eval errsVar (Term.amap (const mempty) -> tm) = do
-- We use an empty ppe for evalutation, it's only used for adding additional context to errors.
let evalPPE = PPE.empty
let codeLookup = Codebase.toCodeLookup codebase
@ -977,12 +984,17 @@ evalDocRef rt codebase r = do
_ -> do
case r of
-- don't cache when there were decompile errors
Just (errs, tmr) | null errs ->
Codebase.runTransaction codebase do
Codebase.putWatch
WK.RegularWatch
(Hashing.hashClosedTerm tm)
(Term.amap (const mempty) tmr)
Just (errs, tmr)
| null errs ->
Codebase.runTransaction codebase do
Codebase.putWatch
WK.RegularWatch
(Hashing.hashClosedTerm tm)
(Term.amap (const mempty) tmr)
| otherwise -> do
UnliftIO.atomically $ do
UnliftIO.modifyTVar errsVar (errs ++)
pure ()
_ -> pure ()
pure $ r <&> Term.amap (const mempty) . snd
@ -995,15 +1007,15 @@ evalDocRef rt codebase r = do
docsForDefinitionName ::
Codebase IO Symbol Ann ->
NameSearch Sqlite.Transaction ->
NamesWithHistory.SearchType ->
Name ->
IO [TermReference]
docsForDefinitionName codebase (NameSearch {termSearch}) name = do
docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do
let potentialDocNames = [name, name Cons.:> "doc"]
Codebase.runTransaction codebase do
refs <-
potentialDocNames & foldMapM \name ->
-- TODO: Should replace this with an exact name lookup.
lookupRelativeHQRefs' termSearch (HQ'.NameOnly name)
lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name)
filterForDocs (toList refs)
where
filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference]
@ -1022,14 +1034,14 @@ renderDocRefs ::
Codebase IO Symbol Ann ->
Rt.Runtime Symbol ->
t TermReference ->
IO (t (HashQualifiedName, UnisonHash, Doc.Doc))
IO (t (HashQualifiedName, UnisonHash, Doc.Doc, [Rt.Error]))
renderDocRefs pped width codebase rt docRefs = do
eDocs <- for docRefs \ref -> (ref,) <$> (evalDocRef rt codebase ref)
for eDocs \(ref, eDoc) -> do
for eDocs \(ref, (eDoc, docEvalErrs)) -> do
let name = bestNameForTerm @Symbol (PPED.suffixifiedPPE pped) width (Referent.Ref ref)
let hash = Reference.toText ref
let renderedDoc = Doc.renderDoc pped eDoc
pure (name, hash, renderedDoc)
pure (name, hash, renderedDoc, docEvalErrs)
docsInBranchToHtmlFiles ::
Rt.Runtime Symbol ->
@ -1037,7 +1049,9 @@ docsInBranchToHtmlFiles ::
Branch IO ->
Path ->
FilePath ->
IO ()
-- Returns any doc evaluation errors which may have occurred.
-- Note that all docs will still be rendered even if there are errors.
IO [Rt.Error]
docsInBranchToHtmlFiles runtime codebase root currentPath directory = do
let currentBranch = Branch.getAt' currentPath root
let allTerms = (R.toList . Branch.deepTerms . Branch.head) currentBranch
@ -1053,13 +1067,17 @@ docsInBranchToHtmlFiles runtime codebase root currentPath directory = do
let printNamesWithHistory = NamesWithHistory {currentNames = printNames, oldNames = mempty}
let ppe = PPED.fromNamesDecl hqLength printNamesWithHistory
docs <- for docTermsWithNames (renderDoc' ppe runtime codebase)
liftIO $ traverse_ (renderDocToHtmlFile docNamesByRef directory) docs
liftIO $
docs & foldMapM \(name, text, doc, errs) -> do
renderDocToHtmlFile docNamesByRef directory (name, text, doc)
pure errs
where
renderDoc' ppe runtime codebase (docReferent, name) = do
let docReference = Referent.toReference docReferent
doc <- evalDocRef runtime codebase docReference <&> Doc.renderDoc ppe
(eDoc, errs) <- evalDocRef runtime codebase docReference
let renderedDoc = Doc.renderDoc ppe eDoc
let hash = Reference.toText docReference
pure (name, hash, doc)
pure (name, hash, renderedDoc, errs)
cleanPath :: FilePath -> FilePath
cleanPath filePath =
@ -1229,14 +1247,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)

6
unison-share-api/src/Unison/Server/Local/Definitions.hs
View File

@ -66,12 +66,14 @@ 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
docRefs <- docsForDefinitionName codebase nameSearch name
docRefs <- docsForDefinitionName codebase nameSearch NamesWithHistory.ExactName name
renderDocRefs pped width codebase rt docRefs
-- local server currently ignores doc eval errors
<&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc)
let fqnPPE = PPED.unsuffixifiedPPE pped
typeDefinitions <-

3
unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs
View File

@ -71,7 +71,8 @@ namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do
(_localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase (Just rootCausal) namespacePath
let mayReadmeRef = Backend.findDocInBranch readmeNames shallowBranch
renderedReadme <- for mayReadmeRef \readmeRef -> do
eDoc <- liftIO $ evalDocRef runtime codebase readmeRef
-- Local server currently ignores eval errors.
(eDoc, _evalErrs) <- liftIO $ evalDocRef runtime codebase readmeRef
pure $ Doc.renderDoc ppe eDoc
let causalHash = v2CausalBranchToUnisonHash namespaceCausal
pure $ NamespaceDetails namespacePath causalHash renderedReadme

9
unison-share-api/src/Unison/Server/NameSearch.hs
View File

@ -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

4
unison-share-api/src/Unison/Server/NameSearch/FromNames.hs
View File

@ -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' = pure . (`NamesWithHistory.lookupRelativeHQType'` 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' = pure . (`NamesWithHistory.lookupRelativeHQTerm'` names),
lookupRelativeHQRefs' = \searchType n -> pure $ NamesWithHistory.lookupRelativeHQTerm' searchType n names,
matchesNamedRef = HQ'.matchesNamedReferent,
makeResult = \hqname r names -> pure $ SR.termResult hqname r names
}

47
unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs
View File

@ -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

2
unison-src/transcripts/api-getDefinition.md
View File

@ -14,7 +14,7 @@ nested.names.x = 42
```
```api
-- Should find names by suffix
-- Should NOT find names by suffix
GET /api/non-project-code/getDefinition?names=x
-- Term names should strip relativeTo prefix.

190
unison-src/transcripts/api-getDefinition.output.md
View File

@ -6,194 +6,22 @@ nested.names.x = 42
```
```api
-- Should find names by suffix
-- Should NOT find names by suffix
GET /api/non-project-code/getDefinition?names=x
{
"missingDefinitions": [],
"termDefinitions": {
"#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": {
"bestTermName": "x",
"defnTermTag": "Plain",
"signature": [
{
"annotation": {
"contents": "##Nat",
"tag": "TypeReference"
},
"segment": "Nat"
}
],
"termDefinition": {
"contents": [
{
"annotation": {
"contents": "x",
"tag": "HashQualifier"
},
"segment": "x"
},
{
"annotation": {
"tag": "TypeAscriptionColon"
},
"segment": " :"
},
{
"annotation": null,
"segment": " "
},
{
"annotation": {
"contents": "##Nat",
"tag": "TypeReference"
},
"segment": "Nat"
},
{
"annotation": null,
"segment": "\n"
},
{
"annotation": {
"contents": "x",
"tag": "HashQualifier"
},
"segment": "x"
},
{
"annotation": {
"tag": "BindingEquals"
},
"segment": " ="
},
{
"annotation": null,
"segment": " "
},
{
"annotation": {
"tag": "NumericLiteral"
},
"segment": "42"
}
],
"tag": "UserObject"
},
"termDocs": [
[
"doc",
"#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg",
{
"contents": [
{
"contents": "Documentation",
"tag": "Word"
}
],
"tag": "Paragraph"
}
]
],
"termNames": [
"nested.names.x"
]
}
},
"missingDefinitions": [
"x"
],
"termDefinitions": {},
"typeDefinitions": {}
}
-- Term names should strip relativeTo prefix.
GET /api/non-project-code/getDefinition?names=x&relativeTo=nested
{
"missingDefinitions": [],
"termDefinitions": {
"#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": {
"bestTermName": "x",
"defnTermTag": "Plain",
"signature": [
{
"annotation": {
"contents": "##Nat",
"tag": "TypeReference"
},
"segment": "Nat"
}
],
"termDefinition": {
"contents": [
{
"annotation": {
"contents": "x",
"tag": "HashQualifier"
},
"segment": "x"
},
{
"annotation": {
"tag": "TypeAscriptionColon"
},
"segment": " :"
},
{
"annotation": null,
"segment": " "
},
{
"annotation": {
"contents": "##Nat",
"tag": "TypeReference"
},
"segment": "Nat"
},
{
"annotation": null,
"segment": "\n"
},
{
"annotation": {
"contents": "x",
"tag": "HashQualifier"
},
"segment": "x"
},
{
"annotation": {
"tag": "BindingEquals"
},
"segment": " ="
},
{
"annotation": null,
"segment": " "
},
{
"annotation": {
"tag": "NumericLiteral"
},
"segment": "42"
}
],
"tag": "UserObject"
},
"termDocs": [
[
"doc",
"#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg",
{
"contents": [
{
"contents": "Documentation",
"tag": "Word"
}
],
"tag": "Paragraph"
}
]
],
"termNames": [
"names.x"
]
}
},
"missingDefinitions": [
"x"
],
"termDefinitions": {},
"typeDefinitions": {}
}
-- Should find definitions by hash, names should be relative

17
unison-src/transcripts/fix4482.md Normal file
View File

@ -0,0 +1,17 @@
```ucm:hide
.> builtins.merge
```
```unison
lib.foo0.lib.bonk1.bar = 203
lib.foo0.baz = 1
lib.foo1.zonk = 204
lib.foo1.lib.bonk2.qux = 1
mybar = bar + bar
```
```ucm:error
.> project.create myproj
myproj/main> add
myproj/main> upgrade foo0 foo1
```

66
unison-src/transcripts/fix4482.output.md Normal file
View File

@ -0,0 +1,66 @@
```unison
lib.foo0.lib.bonk1.bar = 203
lib.foo0.baz = 1
lib.foo1.zonk = 204
lib.foo1.lib.bonk2.qux = 1
mybar = bar + bar
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
lib.foo0.baz : Nat
lib.foo0.lib.bonk1.bar : Nat
lib.foo1.lib.bonk2.qux : Nat
lib.foo1.zonk : Nat
mybar : Nat
```
```ucm
.> project.create myproj
🎉 I've created the project myproj.
I'll now fetch the latest version of the base Unison
library...
Downloaded 12786 entities.
🎨 Type `ui` to explore this project's code in your browser.
🔭 Discover libraries at https://share.unison-lang.org
📖 Use `help-topic projects` to learn more about projects.
Write your first Unison code with UCM:
1. Open scratch.u.
2. Write some Unison code and save the file.
3. In UCM, type `add` to save it to your new project.
🎉 🥳 Happy coding!
myproj/main> add
⍟ I've added these definitions:
lib.foo0.baz : Nat
lib.foo0.lib.bonk1.bar : Nat
lib.foo1.lib.bonk2.qux : Nat
lib.foo1.zonk : Nat
mybar : Nat
myproj/main> upgrade foo0 foo1
mybar : Nat
mybar =
use Nat +
use lib.foo0.lib.bonk1 bar
bar + bar
I couldn't automatically upgrade foo0 to foo1.
```

16
unison-src/transcripts/fix4498.md Normal file
View File

@ -0,0 +1,16 @@
```ucm:hide
.> builtins.merge
```
```unison
lib.dep0.bonk.foo = 5
lib.dep0.zonk.foo = "hi"
lib.dep0.lib.dep1.foo = 6
myterm = foo + 2
```
```ucm
.> add
.> view myterm
```

39
unison-src/transcripts/fix4498.output.md Normal file
View File

@ -0,0 +1,39 @@
```unison
lib.dep0.bonk.foo = 5
lib.dep0.zonk.foo = "hi"
lib.dep0.lib.dep1.foo = 6
myterm = foo + 2
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
lib.dep0.bonk.foo : Nat
lib.dep0.lib.dep1.foo : Nat
lib.dep0.zonk.foo : Text
myterm : Nat
```
```ucm
.> add
⍟ I've added these definitions:
lib.dep0.bonk.foo : Nat
lib.dep0.lib.dep1.foo : Nat
lib.dep0.zonk.foo : Text
myterm : Nat
.> view myterm
myterm : Nat
myterm =
use Nat +
bonk.foo + 2
```

7
unison-src/transcripts/update-type-missing-constructor.output.md
View File

@ -53,11 +53,12 @@ unique type Foo = Bar Nat Nat
Okay, I'm searching the branch for code that needs to be
updated...
I couldn't complete the update because I couldn't find 1
constructor(s) for Foo where I expected to. I found: []
I couldn't complete the update because the type Foo has
unnamed constructors. (I currently need each constructor to
have a name somewhere under the type name.)
You can use `view Foo` and
`alias.term <hash> Foo.<ConstructorName>` to give names to
each constructor, and then try again.
each constructor, and then try the update again.
```

7
unison-src/transcripts/update-type-stray-constructor.output.md
View File

@ -55,11 +55,12 @@ Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`)
Okay, I'm searching the branch for code that needs to be
updated...
I couldn't complete the update because I couldn't find 1
constructor(s) for Foo where I expected to. I found: []
I couldn't complete the update because the type Foo has
unnamed constructors. (I currently need each constructor to
have a name somewhere under the type name.)
You can use `view Foo` and
`alias.term <hash> Foo.<ConstructorName>` to give names to
each constructor, and then try again.
each constructor, and then try the update again.
```