diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 09d101923..6ca0b0733 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,6 +59,7 @@ import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge) import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade) import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges +import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm) import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject) import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) @@ -947,6 +948,7 @@ loop e = do UpgradeI old new -> handleUpgrade old new UpgradeCommitI -> handleCommitUpgrade LibInstallI remind libdep -> handleInstallLib remind libdep + DebugSynhashTermI name -> handleDebugSynhashTerm name inputDescription :: Input -> Cli Text inputDescription input = @@ -1059,7 +1061,17 @@ inputDescription input = CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) ClearI {} -> pure "clear" DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) - -- + DebugTermI verbose hqName -> + if verbose + then pure ("debug.term.verbose " <> HQ.toText hqName) + else pure ("debug.term " <> HQ.toText hqName) + DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName) + DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges" + DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) + DebugFormatI -> pure "debug.format" + EditNamespaceI paths -> + pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) + -- wat land ApiI -> wat AuthLoginI {} -> wat BranchI {} -> wat @@ -1071,18 +1083,11 @@ inputDescription input = DebugDoctorI {} -> wat DebugDumpNamespaceSimpleI {} -> wat DebugDumpNamespacesI {} -> wat - DebugTermI verbose hqName -> - if verbose - then pure ("debug.term.verbose " <> HQ.toText hqName) - else pure ("debug.term " <> HQ.toText hqName) - DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName) - DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges" + DebugLSPNameCompletionI {} -> wat DebugNameDiffI {} -> wat DebugNumberedArgsI {} -> wat - DebugTabCompletionI _input -> wat - DebugLSPNameCompletionI _prefix -> wat - DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) - DebugFormatI -> pure "debug.format" + DebugSynhashTermI {} -> wat + DebugTabCompletionI {} -> wat DebugTypecheckedUnisonFileI {} -> wat DiffNamespaceI {} -> wat DisplayI {} -> wat @@ -1090,15 +1095,13 @@ inputDescription input = DocsToHtmlI {} -> wat FindI {} -> wat FindShallowI {} -> wat - StructuredFindI {} -> wat - StructuredFindReplaceI {} -> wat HistoryI {} -> wat LibInstallI {} -> wat ListDependenciesI {} -> wat ListDependentsI {} -> wat LoadI {} -> wat - MergeI {} -> wat MergeCommitI {} -> wat + MergeI {} -> wat NamesI {} -> wat NamespaceDependenciesI {} -> wat PopBranchI {} -> wat @@ -1114,16 +1117,16 @@ inputDescription input = QuitI {} -> wat ReleaseDraftI {} -> wat ShowDefinitionI {} -> wat - EditNamespaceI paths -> - pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) ShowReflogI {} -> wat + StructuredFindI {} -> wat + StructuredFindReplaceI {} -> wat SwitchBranchI {} -> wat TestI {} -> wat TodoI {} -> wat UiI {} -> wat UpI {} -> wat - UpgradeI {} -> wat UpgradeCommitI {} -> wat + UpgradeI {} -> wat VersionI -> wat where hp' :: Either SCH.ShortCausalHash Path' -> Cli Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs new file mode 100644 index 000000000..8f2a24e30 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs @@ -0,0 +1,65 @@ +-- | @debug.synhash.term@ input handler. +module Unison.Codebase.Editor.HandleInput.DebugSynhashTerm + ( handleDebugSynhashTerm, + ) +where + +import Control.Monad.Reader (ask) +import U.Util.Base32Hex qualified as Base32Hex +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.Pretty (prettyBase32Hex, prettyHash) +import Unison.Cli.PrettyPrintUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.Output (Output (..)) +import Unison.Hash (Hash) +import Unison.Hashable qualified as Hashable +import Unison.Merge.Synhash (hashBuiltinTermTokens, hashDerivedTermTokens) +import Unison.Name (Name) +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) +import Unison.Reference qualified as Reference +import Unison.Util.Pretty (ColorText, Pretty) +import Unison.Util.Pretty qualified as Pretty +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Unison.Syntax.Name as Name + +handleDebugSynhashTerm :: Name -> Cli () +handleDebugSynhashTerm name = do + namespace <- Cli.getCurrentBranch0 + let names = Branch.toNames namespace + pped <- Cli.prettyPrintEnvDeclFromNames names + + for_ (Names.refTermsNamed names name) \ref -> do + maybeTokens <- + case ref of + Reference.Builtin builtin -> pure (Just (hashBuiltinTermTokens builtin)) + Reference.DerivedId refId -> do + env <- ask + Cli.runTransaction (Codebase.getTerm env.codebase refId) <&> \case + Nothing -> Nothing + Just term -> Just (hashDerivedTermTokens pped.unsuffixifiedPPE term) + whenJust maybeTokens \tokens -> do + let filename = Name.toText name <> "-" <> Reference.toText ref <> "-synhash-tokens.txt" + let renderedTokens = + tokens + & map prettyToken + & Pretty.lines + & Pretty.toAnsiUnbroken + & Text.pack + liftIO (Text.writeFile (Text.unpack filename) renderedTokens) + Cli.respond (Output'DebugSynhashTerm ref (Hashable.accumulate tokens) filename) + +prettyToken :: Hashable.Token Hash -> Pretty ColorText +prettyToken = \case + Hashable.Bytes bytes -> "0x" <> prettyBase32Hex (Base32Hex.fromByteString bytes) + Hashable.Double n -> Pretty.string (show n) + Hashable.Hashed h -> prettyHash h + Hashable.Int n -> (if n >= 0 then "+" else mempty) <> Pretty.string (show n) + Hashable.Nat n -> Pretty.string (show n) + Hashable.Tag n -> "@" <> Pretty.string (show n) + Hashable.Text s -> Pretty.string (show s) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index ceee0aa83..f263bd660 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -1,3 +1,4 @@ +-- | @merge@ input handler. module Unison.Codebase.Editor.HandleInput.Merge2 ( handleMerge, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index b0dd664a2..25f6de570 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -1,3 +1,4 @@ +-- | @update@ input handler. module Unison.Codebase.Editor.HandleInput.Update2 ( handleUpdate2, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 7785e386d..70e247544 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -1,3 +1,4 @@ +-- | @upgrade@ input handler. module Unison.Codebase.Editor.HandleInput.Upgrade ( handleUpgrade, ) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index d9278b058..c2ac1a407 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -230,6 +230,7 @@ data Input !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) | UpgradeCommitI | MergeCommitI + | DebugSynhashTermI !Name deriving (Eq, Show) -- | The source of a `branch` command: what to make the new branch from. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 78d2cac1c..1eb7fda3c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -50,6 +50,7 @@ import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Hash (Hash) import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.LabeledDependency (LabeledDependency) @@ -186,15 +187,15 @@ data Output | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction - -- | what we were trying to do (e.g. "run", "io.test") Text - -- | name of function + -- ^ what we were trying to do (e.g. "run", "io.test") (HQ.HashQualified Name) - -- | bad type of function + -- ^ name of function (Type Symbol Ann) + -- ^ bad type of function PPE.PrettyPrintEnv - -- | acceptable type(s) of function [Type Symbol Ann] + -- ^ acceptable type(s) of function | BranchEmpty WhichBranchEmpty | LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path' | CreatedNewBranch Path.Absolute @@ -231,12 +232,12 @@ data Output -- for terms. This additional info is used to provide an enhanced -- error message. SearchTermsNotFoundDetailed - -- | @True@ if we are searching for a term, @False@ if we are searching for a type Bool - -- | Misses (search terms that returned no hits for terms or types) + -- ^ @True@ if we are searching for a term, @False@ if we are searching for a type [HQ.HashQualified Name] - -- | Hits for types if we are searching for terms or terms if we are searching for types + -- ^ Misses (search terms that returned no hits for terms or types) [HQ.HashQualified Name] + -- ^ Hits for types if we are searching for terms or terms if we are searching for types | -- ask confirmation before deleting the last branch that contains some defns -- `Path` is one of the paths the user has requested to delete, and is paired -- with whatever named definitions would not have any remaining names if @@ -385,8 +386,8 @@ data Output | CalculatingDiff | -- | The `local` in a `clone remote local` is ambiguous AmbiguousCloneLocal - -- | Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) + -- ^ Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) | -- | The `remote` in a `clone remote local` is ambiguous AmbiguousCloneRemote ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -426,6 +427,7 @@ data Output | UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName) | PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | NoMergeInProgress + | Output'DebugSynhashTerm !TermReference !Hash !Text data UpdateOrUpgrade = UOUUpdate | UOUUpgrade @@ -665,6 +667,7 @@ isFailure o = case o of UseLibInstallNotPull {} -> False PullIntoMissingBranch {} -> True NoMergeInProgress {} -> True + Output'DebugSynhashTerm {} -> False isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index a09a6595c..1c8f5a990 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -3332,6 +3332,19 @@ upgradeCommitInputPattern = args -> wrongArgsLength "no arguments" args } +debugSynhashTermInputPattern :: InputPattern +debugSynhashTermInputPattern = + InputPattern + { patternName = "debug.synhash.term", + aliases = [], + visibility = I.Hidden, + args = [("term", Required, exactDefinitionTermQueryArg)], + help = mempty, + parse = \case + [arg] -> Input.DebugSynhashTermI <$> handleNameArg arg + args -> wrongArgsLength "exactly one argument" args + } + validInputs :: [InputPattern] validInputs = sortOn @@ -3358,6 +3371,7 @@ validInputs = debugDoctor, debugDumpNamespace, debugDumpNamespaceSimple, + debugSynhashTermInputPattern, debugTerm, debugTermVerbose, debugType, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 7c5553c57..c06408578 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2159,6 +2159,16 @@ notifyUser dir = \case Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch) NoMergeInProgress -> pure . P.wrap $ "It doesn't look like there's a merge in progress." + Output'DebugSynhashTerm ref synhash filename -> + pure $ + "Hash: " + <> P.syntaxToColor (prettyReference 120 ref) + <> P.newline + <> "Synhash: " + <> prettyHash synhash + <> P.newline + <> "Synhash tokens: " + <> P.text filename expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty expectedEmptyPushDest namespace = diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 97441927c..d0b19db6a 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -59,6 +59,7 @@ library Unison.Codebase.Editor.HandleInput.CommitUpgrade Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugFoldRanges + Unison.Codebase.Editor.HandleInput.DebugSynhashTerm Unison.Codebase.Editor.HandleInput.DeleteBranch Unison.Codebase.Editor.HandleInput.DeleteProject Unison.Codebase.Editor.HandleInput.EditNamespace diff --git a/unison-core/src/Unison/Hashable.hs b/unison-core/src/Unison/Hashable.hs index b0d32ce2a..69f7173be 100644 --- a/unison-core/src/Unison/Hashable.hs +++ b/unison-core/src/Unison/Hashable.hs @@ -31,6 +31,7 @@ data Token h | Double !Double | Hashed !h | Nat !Word64 + deriving stock (Show) class Accumulate h where accumulate :: [Token h] -> h diff --git a/unison-merge/package.yaml b/unison-merge/package.yaml index 68cb7d072..c31adfcd5 100644 --- a/unison-merge/package.yaml +++ b/unison-merge/package.yaml @@ -36,6 +36,7 @@ dependencies: - unison-util-cache - unison-util-relation - vector + - witch - witherable library: diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index 6acf835a7..da9a98844 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -30,10 +30,15 @@ module Unison.Merge.Synhash synhashTerm, synhashBuiltinDecl, synhashDerivedDecl, + + -- * Exported for debugging + hashBuiltinTermTokens, + hashDerivedTermTokens, ) where import Data.Char (ord) +import Data.List qualified as List import Data.Text qualified as Text import U.Codebase.Reference (TypeReference) import Unison.ABT qualified as ABT @@ -61,7 +66,7 @@ import Unison.Term qualified as Term import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Var (Var) -import Unison.Var qualified as Var +import Witch (unsafeFrom) type Token = H.Token Hash @@ -80,8 +85,12 @@ synhashBuiltinDecl name = H.accumulate [isBuiltinTag, isDeclTag, H.Text name] hashBuiltinTerm :: Text -> Hash -hashBuiltinTerm name = - H.accumulate [isBuiltinTag, isTermTag, H.Text name] +hashBuiltinTerm = + H.accumulate . hashBuiltinTermTokens + +hashBuiltinTermTokens :: Text -> [Token] +hashBuiltinTermTokens name = + [isBuiltinTag, isTermTag, H.Text name] hashCaseTokens :: PrettyPrintEnv -> Term.MatchCase loc a -> [Token] hashCaseTokens ppe (Term.MatchCase pat Nothing _) = H.Tag 0 : hashPatternTokens ppe pat @@ -108,8 +117,21 @@ hashConstructorNameToken declName conName = in H.Text (Name.toText strippedConName) hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash -hashDerivedTerm ppe t = - H.accumulate $ isNotBuiltinTag : isTermTag : hashTermTokens ppe t +hashDerivedTerm ppe term = + H.accumulate (hashDerivedTermTokens ppe term) + +hashDerivedTermTokens :: forall a v. Var v => PrettyPrintEnv -> Term v a -> [Token] +hashDerivedTermTokens ppe = + (isNotBuiltinTag :) . (isTermTag :) . go [] + where + go :: [v] -> Term v a -> [Token] + go bound t = + H.Tag 255 : case ABT.out t of + ABT.Var v -> [H.Tag 0, hashVarToken bound v] + -- trick: encode the structure, followed the children as a flat list + ABT.Tm f -> H.Tag 1 : hashTermFTokens ppe (void f) <> (toList f >>= go bound) + ABT.Cycle c -> H.Tag 2 : go bound c + ABT.Abs v body -> H.Tag 3 : go (v : bound) body hashConstructorType :: ConstructorType -> Token hashConstructorType = \case @@ -117,18 +139,15 @@ hashConstructorType = \case CT.Data -> H.Tag 1 hashDataDeclTokens :: Var v => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token] -hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ vs ctors) = - hashModifierTokens modifier <> goVs <> (ctors >>= hashConstructorTokens ppe declName) - where - goVs = - hashLengthToken vs : map hashVarToken vs +hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ bound ctors) = + hashModifierTokens modifier <> (ctors >>= hashConstructorTokens ppe declName bound) -- separating constructor types with tag of 99, which isn't used elsewhere -hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> (a, v, Type v a) -> [Token] -hashConstructorTokens ppe declName (_, conName, ty) = +hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token] +hashConstructorTokens ppe declName bound (_, conName, ty) = H.Tag 99 : hashConstructorNameToken declName (Name.unsafeParseVar conName) - : hashTypeTokens ppe ty + : hashTypeTokens ppe bound ty hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token] hashDeclTokens ppe name decl = @@ -205,19 +224,6 @@ synhashTerm loadTerm ppe = \case ReferenceBuiltin builtin -> pure (hashBuiltinTerm builtin) ReferenceDerived ref -> hashDerivedTerm ppe <$> loadTerm ref -hashTermTokens :: forall v a. Var v => PrettyPrintEnv -> Term v a -> [Token] -hashTermTokens ppe = - go - where - go :: Term v a -> [Token] - go t = - H.Tag 255 : case ABT.out t of - ABT.Var v -> [H.Tag 0, hashVarToken v] - -- trick: encode the structure, followed the children as a flat list - ABT.Tm f -> H.Tag 1 : hashTermFTokens ppe (void f) <> (toList f >>= go) - ABT.Cycle c -> H.Tag 2 : go c - ABT.Abs v body -> H.Tag 3 : hashVarToken v : go body - hashTermFTokens :: Var v => PrettyPrintEnv -> Term.F v a a () -> [Token] hashTermFTokens ppe = \case Term.Int n -> [H.Tag 0, H.Int n] @@ -233,7 +239,7 @@ hashTermFTokens ppe = \case Term.Request cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Effect)] Term.Handle {} -> [H.Tag 8] Term.App {} -> [H.Tag 9] - Term.Ann _ ty -> H.Tag 10 : hashTypeTokens ppe ty + Term.Ann _ ty -> H.Tag 10 : hashTypeTokens ppe [] ty Term.List xs -> [H.Tag 11, hashLengthToken xs] Term.If {} -> [H.Tag 12] Term.And {} -> [H.Tag 13] @@ -250,20 +256,20 @@ hashTermFTokens ppe = \case -- Two types will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash -synhashType ppe t = - H.accumulate $ hashTypeTokens ppe t +synhashType ppe ty = + H.accumulate $ hashTypeTokens ppe [] ty -hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> Type v a -> [Token] +hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token] hashTypeTokens ppe = go where - go :: Type v a -> [Token] - go t = + go :: [v] -> Type v a -> [Token] + go bound t = H.Tag 254 : case ABT.out t of - ABT.Var v -> [H.Tag 0, hashVarToken v] + ABT.Var v -> [H.Tag 0, hashVarToken bound v] -- trick: encode the structure, followed the children as a flat list - ABT.Tm f -> H.Tag 1 : (hashTypeFTokens ppe (void f) <> (toList f >>= go)) - ABT.Cycle c -> H.Tag 2 : go c - ABT.Abs v body -> H.Tag 3 : hashVarToken v : go body + ABT.Tm f -> H.Tag 1 : (hashTypeFTokens ppe (void f) <> (toList f >>= go bound)) + ABT.Cycle c -> H.Tag 2 : go bound c + ABT.Abs v body -> H.Tag 3 : go (v : bound) body hashTypeFTokens :: PrettyPrintEnv -> Type.F () -> [Token] hashTypeFTokens ppe = \case @@ -280,6 +286,8 @@ hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token hashTypeReferenceToken ppe = hashHQNameToken . PPE.typeNameOrHashOnlyFq ppe -hashVarToken :: Var v => v -> Token -hashVarToken = - H.Text . Var.name +hashVarToken :: Var v => [v] -> v -> Token +hashVarToken bound v = + case List.elemIndex v bound of + Nothing -> error (reportBug "E633940" ("var " ++ show v ++ " not bound in " ++ show bound)) + Just index -> H.Nat (unsafeFrom @Int @Word64 index) diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index ee5b36f48..83131b33b 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -105,6 +105,7 @@ library , unison-util-cache , unison-util-relation , vector + , witch , witherable default-language: Haskell2010 if !os(windows) diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index 164b458f5..4a84996f4 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -1645,3 +1645,65 @@ project/bob> merge /alice project/carol> merge /bob project/carol> history ``` + +```ucm:hide +.> project.delete project +``` + +### Variables named `_` + +This test demonstrates a change in syntactic hashing that fixed a bug due to auto-generated variable names for ignored +results. + +```ucm:hide +scratch/alice> builtins.mergeio lib.builtins +``` + +```unison +ignore : a -> () +ignore _ = () + +foo : Nat +foo = 18 + +bar : Nat +bar = + ignore "hi" + foo + foo +``` + +```ucm +scratch/alice> add +scratch/alice> branch bob +``` + +```unison +bar : Nat +bar = + ignore "hi" + foo + foo + foo +``` + +```ucm +scratch/bob> update +``` + +Previously, this update to `foo` would also cause a "real update" on `bar`, its dependent. Now it doesn't, so the merge +will succeed. + +```unison +foo : Nat +foo = 19 +``` + +```ucm +scratch/alice> update +``` + +```ucm +scratch/alice> merge /bob +``` + +```ucm:hide +.> project.delete scratch +``` diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index d0251764e..a8a97adb6 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -2121,3 +2121,124 @@ project/carol> history 3. #dm4u1eokg1 ``` +### Variables named `_` + +This test demonstrates a change in syntactic hashing that fixed a bug due to auto-generated variable names for ignored +results. + +```unison +ignore : a -> () +ignore _ = () + +foo : Nat +foo = 18 + +bar : Nat +bar = + ignore "hi" + foo + foo +``` + +```ucm + + Loading changes detected in scratch.u. + + 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`: + + bar : Nat + foo : Nat + ignore : a -> () + +``` +```ucm +scratch/alice> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + ignore : a -> () + +scratch/alice> branch bob + + Done. I've created the bob branch based off of alice. + + Tip: To merge your work back into the alice branch, first + `switch /alice` then `merge /bob`. + +``` +```unison +bar : Nat +bar = + ignore "hi" + foo + foo + foo +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bar : Nat + +``` +```ucm +scratch/bob> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +``` +Previously, this update to `foo` would also cause a "real update" on `bar`, its dependent. Now it doesn't, so the merge +will succeed. + +```unison +foo : Nat +foo = 19 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat + +``` +```ucm +scratch/alice> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +``` +```ucm +scratch/alice> merge /bob + + I merged scratch/bob into scratch/alice. + +```