mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
synhash var bugfix: hash debruijn indexes, not var names
also adds a debug.synhash.term command for debugging
This commit is contained in:
parent
60bb91a50a
commit
9cc6c2bd8a
@ -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
|
||||
|
@ -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
|
||||
( handleMerge,
|
||||
|
||||
|
@ -1,3 +1,4 @@
|
||||
-- | @update@ input handler.
|
||||
module Unison.Codebase.Editor.HandleInput.Update2
|
||||
( handleUpdate2,
|
||||
|
||||
|
@ -1,3 +1,4 @@
|
||||
-- | @upgrade@ input handler.
|
||||
module Unison.Codebase.Editor.HandleInput.Upgrade
|
||||
( handleUpgrade,
|
||||
)
|
||||
|
@ -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.
|
||||
|
@ -50,8 +50,10 @@ 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.Hashable qualified as Hashable
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -186,15 +188,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 +233,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 +387,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 +428,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 +668,7 @@ isFailure o = case o of
|
||||
UseLibInstallNotPull {} -> False
|
||||
PullIntoMissingBranch {} -> True
|
||||
NoMergeInProgress {} -> True
|
||||
Output'DebugSynhashTerm {} -> False
|
||||
|
||||
isNumberedFailure :: NumberedOutput -> Bool
|
||||
isNumberedFailure = \case
|
||||
|
@ -3326,6 +3326,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
|
||||
@ -3352,6 +3365,7 @@ validInputs =
|
||||
debugDoctor,
|
||||
debugDumpNamespace,
|
||||
debugDumpNamespaceSimple,
|
||||
debugSynhashTermInputPattern,
|
||||
debugTerm,
|
||||
debugTermVerbose,
|
||||
debugType,
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -31,6 +31,7 @@ data Token h
|
||||
| Double !Double
|
||||
| Hashed !h
|
||||
| Nat !Word64
|
||||
deriving stock (Show)
|
||||
|
||||
class Accumulate h where
|
||||
accumulate :: [Token h] -> h
|
||||
|
@ -36,6 +36,7 @@ dependencies:
|
||||
- unison-util-cache
|
||||
- unison-util-relation
|
||||
- vector
|
||||
- witch
|
||||
- witherable
|
||||
|
||||
library:
|
||||
|
@ -30,6 +30,10 @@ module Unison.Merge.Synhash
|
||||
synhashTerm,
|
||||
synhashBuiltinDecl,
|
||||
synhashDerivedDecl,
|
||||
|
||||
-- * Exported for debugging
|
||||
hashBuiltinTermTokens,
|
||||
hashDerivedTermTokens,
|
||||
)
|
||||
where
|
||||
|
||||
@ -55,13 +59,14 @@ import Unison.Reference (Reference' (..), TypeReferenceId)
|
||||
import Unison.Reference qualified as V1
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Witch (unsafeFrom)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.Term (Term)
|
||||
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 qualified Data.List as List
|
||||
|
||||
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)
|
||||
|
@ -105,6 +105,7 @@ library
|
||||
, unison-util-cache
|
||||
, unison-util-relation
|
||||
, vector
|
||||
, witch
|
||||
, witherable
|
||||
default-language: Haskell2010
|
||||
if !os(windows)
|
||||
|
Loading…
Reference in New Issue
Block a user