mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge pull request #5194 from unisonweb/synhash-bugfix
This commit is contained in:
commit
615887fcf4
@ -59,6 +59,7 @@ import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge)
|
|||||||
import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
|
import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
|
||||||
import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
|
import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
|
||||||
import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges
|
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.DeleteBranch (handleDeleteBranch)
|
||||||
import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
|
import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
|
||||||
import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
|
import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
|
||||||
@ -947,6 +948,7 @@ loop e = do
|
|||||||
UpgradeI old new -> handleUpgrade old new
|
UpgradeI old new -> handleUpgrade old new
|
||||||
UpgradeCommitI -> handleCommitUpgrade
|
UpgradeCommitI -> handleCommitUpgrade
|
||||||
LibInstallI remind libdep -> handleInstallLib remind libdep
|
LibInstallI remind libdep -> handleInstallLib remind libdep
|
||||||
|
DebugSynhashTermI name -> handleDebugSynhashTerm name
|
||||||
|
|
||||||
inputDescription :: Input -> Cli Text
|
inputDescription :: Input -> Cli Text
|
||||||
inputDescription input =
|
inputDescription input =
|
||||||
@ -1059,7 +1061,17 @@ inputDescription input =
|
|||||||
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
|
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
|
||||||
ClearI {} -> pure "clear"
|
ClearI {} -> pure "clear"
|
||||||
DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
|
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
|
ApiI -> wat
|
||||||
AuthLoginI {} -> wat
|
AuthLoginI {} -> wat
|
||||||
BranchI {} -> wat
|
BranchI {} -> wat
|
||||||
@ -1071,18 +1083,11 @@ inputDescription input =
|
|||||||
DebugDoctorI {} -> wat
|
DebugDoctorI {} -> wat
|
||||||
DebugDumpNamespaceSimpleI {} -> wat
|
DebugDumpNamespaceSimpleI {} -> wat
|
||||||
DebugDumpNamespacesI {} -> wat
|
DebugDumpNamespacesI {} -> wat
|
||||||
DebugTermI verbose hqName ->
|
DebugLSPNameCompletionI {} -> wat
|
||||||
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"
|
|
||||||
DebugNameDiffI {} -> wat
|
DebugNameDiffI {} -> wat
|
||||||
DebugNumberedArgsI {} -> wat
|
DebugNumberedArgsI {} -> wat
|
||||||
DebugTabCompletionI _input -> wat
|
DebugSynhashTermI {} -> wat
|
||||||
DebugLSPNameCompletionI _prefix -> wat
|
DebugTabCompletionI {} -> wat
|
||||||
DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
|
|
||||||
DebugFormatI -> pure "debug.format"
|
|
||||||
DebugTypecheckedUnisonFileI {} -> wat
|
DebugTypecheckedUnisonFileI {} -> wat
|
||||||
DiffNamespaceI {} -> wat
|
DiffNamespaceI {} -> wat
|
||||||
DisplayI {} -> wat
|
DisplayI {} -> wat
|
||||||
@ -1090,15 +1095,13 @@ inputDescription input =
|
|||||||
DocsToHtmlI {} -> wat
|
DocsToHtmlI {} -> wat
|
||||||
FindI {} -> wat
|
FindI {} -> wat
|
||||||
FindShallowI {} -> wat
|
FindShallowI {} -> wat
|
||||||
StructuredFindI {} -> wat
|
|
||||||
StructuredFindReplaceI {} -> wat
|
|
||||||
HistoryI {} -> wat
|
HistoryI {} -> wat
|
||||||
LibInstallI {} -> wat
|
LibInstallI {} -> wat
|
||||||
ListDependenciesI {} -> wat
|
ListDependenciesI {} -> wat
|
||||||
ListDependentsI {} -> wat
|
ListDependentsI {} -> wat
|
||||||
LoadI {} -> wat
|
LoadI {} -> wat
|
||||||
MergeI {} -> wat
|
|
||||||
MergeCommitI {} -> wat
|
MergeCommitI {} -> wat
|
||||||
|
MergeI {} -> wat
|
||||||
NamesI {} -> wat
|
NamesI {} -> wat
|
||||||
NamespaceDependenciesI {} -> wat
|
NamespaceDependenciesI {} -> wat
|
||||||
PopBranchI {} -> wat
|
PopBranchI {} -> wat
|
||||||
@ -1114,16 +1117,16 @@ inputDescription input =
|
|||||||
QuitI {} -> wat
|
QuitI {} -> wat
|
||||||
ReleaseDraftI {} -> wat
|
ReleaseDraftI {} -> wat
|
||||||
ShowDefinitionI {} -> wat
|
ShowDefinitionI {} -> wat
|
||||||
EditNamespaceI paths ->
|
|
||||||
pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
|
|
||||||
ShowReflogI {} -> wat
|
ShowReflogI {} -> wat
|
||||||
|
StructuredFindI {} -> wat
|
||||||
|
StructuredFindReplaceI {} -> wat
|
||||||
SwitchBranchI {} -> wat
|
SwitchBranchI {} -> wat
|
||||||
TestI {} -> wat
|
TestI {} -> wat
|
||||||
TodoI {} -> wat
|
TodoI {} -> wat
|
||||||
UiI {} -> wat
|
UiI {} -> wat
|
||||||
UpI {} -> wat
|
UpI {} -> wat
|
||||||
UpgradeI {} -> wat
|
|
||||||
UpgradeCommitI {} -> wat
|
UpgradeCommitI {} -> wat
|
||||||
|
UpgradeI {} -> wat
|
||||||
VersionI -> wat
|
VersionI -> wat
|
||||||
where
|
where
|
||||||
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
|
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
|
||||||
|
@ -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)
|
@ -1,3 +1,4 @@
|
|||||||
|
-- | @merge@ input handler.
|
||||||
module Unison.Codebase.Editor.HandleInput.Merge2
|
module Unison.Codebase.Editor.HandleInput.Merge2
|
||||||
( handleMerge,
|
( handleMerge,
|
||||||
|
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
-- | @update@ input handler.
|
||||||
module Unison.Codebase.Editor.HandleInput.Update2
|
module Unison.Codebase.Editor.HandleInput.Update2
|
||||||
( handleUpdate2,
|
( handleUpdate2,
|
||||||
|
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
-- | @upgrade@ input handler.
|
||||||
module Unison.Codebase.Editor.HandleInput.Upgrade
|
module Unison.Codebase.Editor.HandleInput.Upgrade
|
||||||
( handleUpgrade,
|
( handleUpgrade,
|
||||||
)
|
)
|
||||||
|
@ -230,6 +230,7 @@ data Input
|
|||||||
!(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease))
|
!(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease))
|
||||||
| UpgradeCommitI
|
| UpgradeCommitI
|
||||||
| MergeCommitI
|
| MergeCommitI
|
||||||
|
| DebugSynhashTermI !Name
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | The source of a `branch` command: what to make the new branch from.
|
-- | The source of a `branch` command: what to make the new branch from.
|
||||||
|
@ -50,6 +50,7 @@ import Unison.Codebase.ShortCausalHash qualified as SCH
|
|||||||
import Unison.CommandLine.InputPattern qualified as Input
|
import Unison.CommandLine.InputPattern qualified as Input
|
||||||
import Unison.DataDeclaration qualified as DD
|
import Unison.DataDeclaration qualified as DD
|
||||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||||
|
import Unison.Hash (Hash)
|
||||||
import Unison.HashQualified qualified as HQ
|
import Unison.HashQualified qualified as HQ
|
||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
import Unison.LabeledDependency (LabeledDependency)
|
import Unison.LabeledDependency (LabeledDependency)
|
||||||
@ -186,15 +187,15 @@ data Output
|
|||||||
| -- | Function found, but has improper type
|
| -- | Function found, but has improper type
|
||||||
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
|
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
|
||||||
BadMainFunction
|
BadMainFunction
|
||||||
-- | what we were trying to do (e.g. "run", "io.test")
|
|
||||||
Text
|
Text
|
||||||
-- | name of function
|
-- ^ what we were trying to do (e.g. "run", "io.test")
|
||||||
(HQ.HashQualified Name)
|
(HQ.HashQualified Name)
|
||||||
-- | bad type of function
|
-- ^ name of function
|
||||||
(Type Symbol Ann)
|
(Type Symbol Ann)
|
||||||
|
-- ^ bad type of function
|
||||||
PPE.PrettyPrintEnv
|
PPE.PrettyPrintEnv
|
||||||
-- | acceptable type(s) of function
|
|
||||||
[Type Symbol Ann]
|
[Type Symbol Ann]
|
||||||
|
-- ^ acceptable type(s) of function
|
||||||
| BranchEmpty WhichBranchEmpty
|
| BranchEmpty WhichBranchEmpty
|
||||||
| LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path'
|
| LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path'
|
||||||
| CreatedNewBranch Path.Absolute
|
| CreatedNewBranch Path.Absolute
|
||||||
@ -231,12 +232,12 @@ data Output
|
|||||||
-- for terms. This additional info is used to provide an enhanced
|
-- for terms. This additional info is used to provide an enhanced
|
||||||
-- error message.
|
-- error message.
|
||||||
SearchTermsNotFoundDetailed
|
SearchTermsNotFoundDetailed
|
||||||
-- | @True@ if we are searching for a term, @False@ if we are searching for a type
|
|
||||||
Bool
|
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]
|
[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]
|
[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
|
| -- 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
|
-- `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
|
-- with whatever named definitions would not have any remaining names if
|
||||||
@ -385,8 +386,8 @@ data Output
|
|||||||
| CalculatingDiff
|
| CalculatingDiff
|
||||||
| -- | The `local` in a `clone remote local` is ambiguous
|
| -- | The `local` in a `clone remote local` is ambiguous
|
||||||
AmbiguousCloneLocal
|
AmbiguousCloneLocal
|
||||||
-- | Treating `local` as a project. We may know the branch name, if it was provided in `remote`.
|
|
||||||
(ProjectAndBranch ProjectName ProjectBranchName)
|
(ProjectAndBranch ProjectName ProjectBranchName)
|
||||||
|
-- ^ Treating `local` as a project. We may know the branch name, if it was provided in `remote`.
|
||||||
(ProjectAndBranch ProjectName ProjectBranchName)
|
(ProjectAndBranch ProjectName ProjectBranchName)
|
||||||
| -- | The `remote` in a `clone remote local` is ambiguous
|
| -- | The `remote` in a `clone remote local` is ambiguous
|
||||||
AmbiguousCloneRemote ProjectName (ProjectAndBranch ProjectName ProjectBranchName)
|
AmbiguousCloneRemote ProjectName (ProjectAndBranch ProjectName ProjectBranchName)
|
||||||
@ -426,6 +427,7 @@ data Output
|
|||||||
| UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName)
|
| UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName)
|
||||||
| PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
| PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||||
| NoMergeInProgress
|
| NoMergeInProgress
|
||||||
|
| Output'DebugSynhashTerm !TermReference !Hash !Text
|
||||||
|
|
||||||
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
|
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
|
||||||
|
|
||||||
@ -665,6 +667,7 @@ isFailure o = case o of
|
|||||||
UseLibInstallNotPull {} -> False
|
UseLibInstallNotPull {} -> False
|
||||||
PullIntoMissingBranch {} -> True
|
PullIntoMissingBranch {} -> True
|
||||||
NoMergeInProgress {} -> True
|
NoMergeInProgress {} -> True
|
||||||
|
Output'DebugSynhashTerm {} -> False
|
||||||
|
|
||||||
isNumberedFailure :: NumberedOutput -> Bool
|
isNumberedFailure :: NumberedOutput -> Bool
|
||||||
isNumberedFailure = \case
|
isNumberedFailure = \case
|
||||||
|
@ -3332,6 +3332,19 @@ upgradeCommitInputPattern =
|
|||||||
args -> wrongArgsLength "no arguments" args
|
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 :: [InputPattern]
|
||||||
validInputs =
|
validInputs =
|
||||||
sortOn
|
sortOn
|
||||||
@ -3358,6 +3371,7 @@ validInputs =
|
|||||||
debugDoctor,
|
debugDoctor,
|
||||||
debugDumpNamespace,
|
debugDumpNamespace,
|
||||||
debugDumpNamespaceSimple,
|
debugDumpNamespaceSimple,
|
||||||
|
debugSynhashTermInputPattern,
|
||||||
debugTerm,
|
debugTerm,
|
||||||
debugTermVerbose,
|
debugTermVerbose,
|
||||||
debugType,
|
debugType,
|
||||||
|
@ -2159,6 +2159,16 @@ notifyUser dir = \case
|
|||||||
Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch)
|
Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch)
|
||||||
NoMergeInProgress ->
|
NoMergeInProgress ->
|
||||||
pure . P.wrap $ "It doesn't look like there's a merge in progress."
|
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 :: WriteRemoteNamespace Void -> Pretty
|
||||||
expectedEmptyPushDest namespace =
|
expectedEmptyPushDest namespace =
|
||||||
|
@ -59,6 +59,7 @@ library
|
|||||||
Unison.Codebase.Editor.HandleInput.CommitUpgrade
|
Unison.Codebase.Editor.HandleInput.CommitUpgrade
|
||||||
Unison.Codebase.Editor.HandleInput.DebugDefinition
|
Unison.Codebase.Editor.HandleInput.DebugDefinition
|
||||||
Unison.Codebase.Editor.HandleInput.DebugFoldRanges
|
Unison.Codebase.Editor.HandleInput.DebugFoldRanges
|
||||||
|
Unison.Codebase.Editor.HandleInput.DebugSynhashTerm
|
||||||
Unison.Codebase.Editor.HandleInput.DeleteBranch
|
Unison.Codebase.Editor.HandleInput.DeleteBranch
|
||||||
Unison.Codebase.Editor.HandleInput.DeleteProject
|
Unison.Codebase.Editor.HandleInput.DeleteProject
|
||||||
Unison.Codebase.Editor.HandleInput.EditNamespace
|
Unison.Codebase.Editor.HandleInput.EditNamespace
|
||||||
|
@ -31,6 +31,7 @@ data Token h
|
|||||||
| Double !Double
|
| Double !Double
|
||||||
| Hashed !h
|
| Hashed !h
|
||||||
| Nat !Word64
|
| Nat !Word64
|
||||||
|
deriving stock (Show)
|
||||||
|
|
||||||
class Accumulate h where
|
class Accumulate h where
|
||||||
accumulate :: [Token h] -> h
|
accumulate :: [Token h] -> h
|
||||||
|
@ -36,6 +36,7 @@ dependencies:
|
|||||||
- unison-util-cache
|
- unison-util-cache
|
||||||
- unison-util-relation
|
- unison-util-relation
|
||||||
- vector
|
- vector
|
||||||
|
- witch
|
||||||
- witherable
|
- witherable
|
||||||
|
|
||||||
library:
|
library:
|
||||||
|
@ -30,10 +30,15 @@ module Unison.Merge.Synhash
|
|||||||
synhashTerm,
|
synhashTerm,
|
||||||
synhashBuiltinDecl,
|
synhashBuiltinDecl,
|
||||||
synhashDerivedDecl,
|
synhashDerivedDecl,
|
||||||
|
|
||||||
|
-- * Exported for debugging
|
||||||
|
hashBuiltinTermTokens,
|
||||||
|
hashDerivedTermTokens,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Char (ord)
|
import Data.Char (ord)
|
||||||
|
import Data.List qualified as List
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import U.Codebase.Reference (TypeReference)
|
import U.Codebase.Reference (TypeReference)
|
||||||
import Unison.ABT qualified as ABT
|
import Unison.ABT qualified as ABT
|
||||||
@ -61,7 +66,7 @@ import Unison.Term qualified as Term
|
|||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Type qualified as Type
|
import Unison.Type qualified as Type
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import Unison.Var qualified as Var
|
import Witch (unsafeFrom)
|
||||||
|
|
||||||
type Token = H.Token Hash
|
type Token = H.Token Hash
|
||||||
|
|
||||||
@ -80,8 +85,12 @@ synhashBuiltinDecl name =
|
|||||||
H.accumulate [isBuiltinTag, isDeclTag, H.Text name]
|
H.accumulate [isBuiltinTag, isDeclTag, H.Text name]
|
||||||
|
|
||||||
hashBuiltinTerm :: Text -> Hash
|
hashBuiltinTerm :: Text -> Hash
|
||||||
hashBuiltinTerm name =
|
hashBuiltinTerm =
|
||||||
H.accumulate [isBuiltinTag, isTermTag, H.Text name]
|
H.accumulate . hashBuiltinTermTokens
|
||||||
|
|
||||||
|
hashBuiltinTermTokens :: Text -> [Token]
|
||||||
|
hashBuiltinTermTokens name =
|
||||||
|
[isBuiltinTag, isTermTag, H.Text name]
|
||||||
|
|
||||||
hashCaseTokens :: PrettyPrintEnv -> Term.MatchCase loc a -> [Token]
|
hashCaseTokens :: PrettyPrintEnv -> Term.MatchCase loc a -> [Token]
|
||||||
hashCaseTokens ppe (Term.MatchCase pat Nothing _) = H.Tag 0 : hashPatternTokens ppe pat
|
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)
|
in H.Text (Name.toText strippedConName)
|
||||||
|
|
||||||
hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash
|
hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash
|
||||||
hashDerivedTerm ppe t =
|
hashDerivedTerm ppe term =
|
||||||
H.accumulate $ isNotBuiltinTag : isTermTag : hashTermTokens ppe t
|
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 :: ConstructorType -> Token
|
||||||
hashConstructorType = \case
|
hashConstructorType = \case
|
||||||
@ -117,18 +139,15 @@ hashConstructorType = \case
|
|||||||
CT.Data -> H.Tag 1
|
CT.Data -> H.Tag 1
|
||||||
|
|
||||||
hashDataDeclTokens :: Var v => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
|
hashDataDeclTokens :: Var v => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
|
||||||
hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ vs ctors) =
|
hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ bound ctors) =
|
||||||
hashModifierTokens modifier <> goVs <> (ctors >>= hashConstructorTokens ppe declName)
|
hashModifierTokens modifier <> (ctors >>= hashConstructorTokens ppe declName bound)
|
||||||
where
|
|
||||||
goVs =
|
|
||||||
hashLengthToken vs : map hashVarToken vs
|
|
||||||
|
|
||||||
-- separating constructor types with tag of 99, which isn't used elsewhere
|
-- separating constructor types with tag of 99, which isn't used elsewhere
|
||||||
hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> (a, v, Type v a) -> [Token]
|
hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
|
||||||
hashConstructorTokens ppe declName (_, conName, ty) =
|
hashConstructorTokens ppe declName bound (_, conName, ty) =
|
||||||
H.Tag 99
|
H.Tag 99
|
||||||
: hashConstructorNameToken declName (Name.unsafeParseVar conName)
|
: hashConstructorNameToken declName (Name.unsafeParseVar conName)
|
||||||
: hashTypeTokens ppe ty
|
: hashTypeTokens ppe bound ty
|
||||||
|
|
||||||
hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
|
hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
|
||||||
hashDeclTokens ppe name decl =
|
hashDeclTokens ppe name decl =
|
||||||
@ -205,19 +224,6 @@ synhashTerm loadTerm ppe = \case
|
|||||||
ReferenceBuiltin builtin -> pure (hashBuiltinTerm builtin)
|
ReferenceBuiltin builtin -> pure (hashBuiltinTerm builtin)
|
||||||
ReferenceDerived ref -> hashDerivedTerm ppe <$> loadTerm ref
|
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 :: Var v => PrettyPrintEnv -> Term.F v a a () -> [Token]
|
||||||
hashTermFTokens ppe = \case
|
hashTermFTokens ppe = \case
|
||||||
Term.Int n -> [H.Tag 0, H.Int n]
|
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.Request cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Effect)]
|
||||||
Term.Handle {} -> [H.Tag 8]
|
Term.Handle {} -> [H.Tag 8]
|
||||||
Term.App {} -> [H.Tag 9]
|
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.List xs -> [H.Tag 11, hashLengthToken xs]
|
||||||
Term.If {} -> [H.Tag 12]
|
Term.If {} -> [H.Tag 12]
|
||||||
Term.And {} -> [H.Tag 13]
|
Term.And {} -> [H.Tag 13]
|
||||||
@ -250,20 +256,20 @@ hashTermFTokens ppe = \case
|
|||||||
-- Two types will have the same syntactic hash if they would
|
-- Two types will have the same syntactic hash if they would
|
||||||
-- print the the same way under the given pretty-print env.
|
-- print the the same way under the given pretty-print env.
|
||||||
synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash
|
synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash
|
||||||
synhashType ppe t =
|
synhashType ppe ty =
|
||||||
H.accumulate $ hashTypeTokens ppe t
|
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
|
hashTypeTokens ppe = go
|
||||||
where
|
where
|
||||||
go :: Type v a -> [Token]
|
go :: [v] -> Type v a -> [Token]
|
||||||
go t =
|
go bound t =
|
||||||
H.Tag 254 : case ABT.out t of
|
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
|
-- 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.Tm f -> H.Tag 1 : (hashTypeFTokens ppe (void f) <> (toList f >>= go bound))
|
||||||
ABT.Cycle c -> H.Tag 2 : go c
|
ABT.Cycle c -> H.Tag 2 : go bound c
|
||||||
ABT.Abs v body -> H.Tag 3 : hashVarToken v : go body
|
ABT.Abs v body -> H.Tag 3 : go (v : bound) body
|
||||||
|
|
||||||
hashTypeFTokens :: PrettyPrintEnv -> Type.F () -> [Token]
|
hashTypeFTokens :: PrettyPrintEnv -> Type.F () -> [Token]
|
||||||
hashTypeFTokens ppe = \case
|
hashTypeFTokens ppe = \case
|
||||||
@ -280,6 +286,8 @@ hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token
|
|||||||
hashTypeReferenceToken ppe =
|
hashTypeReferenceToken ppe =
|
||||||
hashHQNameToken . PPE.typeNameOrHashOnlyFq ppe
|
hashHQNameToken . PPE.typeNameOrHashOnlyFq ppe
|
||||||
|
|
||||||
hashVarToken :: Var v => v -> Token
|
hashVarToken :: Var v => [v] -> v -> Token
|
||||||
hashVarToken =
|
hashVarToken bound v =
|
||||||
H.Text . Var.name
|
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)
|
||||||
|
@ -105,6 +105,7 @@ library
|
|||||||
, unison-util-cache
|
, unison-util-cache
|
||||||
, unison-util-relation
|
, unison-util-relation
|
||||||
, vector
|
, vector
|
||||||
|
, witch
|
||||||
, witherable
|
, witherable
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
if !os(windows)
|
if !os(windows)
|
||||||
|
@ -1645,3 +1645,65 @@ project/bob> merge /alice
|
|||||||
project/carol> merge /bob
|
project/carol> merge /bob
|
||||||
project/carol> history
|
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
|
||||||
|
```
|
||||||
|
@ -2121,3 +2121,124 @@ project/carol> history
|
|||||||
3. #dm4u1eokg1
|
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.
|
||||||
|
|
||||||
|
```
|
||||||
|
Loading…
Reference in New Issue
Block a user