{-# LANGUAGE DataKinds #-}

-- | Utilities for computing the "syntactic hash" of a decl or term, which is a hash that is computed after substituting
-- references to other terms and decls with names from a pretty-print environment.
--
-- Thus, syntactic hashes can be compared for equality to answer questions like "would these definitions look the same
-- when rendered for a human (even if their underlying references are different)?".
--
-- The merge algorithm currently uses syntactic hashes for determining whether an update was performed by a human, or
-- was the result of auto-propagation. (Critically, this cannot handle renames very well). For example, consider
-- comparing two definitions on Alice's branch; one old one from somewhere in its history, and one new:
--
--   old namespace        new namespace
--   ----------------     ---------------
--   foo = #bar + 3       foo = #bar2 + 3
--
-- Either Alice manually updated #bar to #bar2, or else a dependency of #bar was updated, inducing an update to #bar2.
-- Computing the syntactic hash can help answer that question. Let's combine a pretty-print environment for the old
-- and new namespaces together, substitute references with it, and look again at the terms:
--
--   old namespace        new namespace
--   ----------------     ----------------
--   foo = helper + 3     foo = helper + 3
--
-- We see now that our pretty-print environment has mapped both #bar and #bar2 to the name "helper", so each version of
-- "foo" would have the same syntactic hash. This indicates (to our merge algorithm) that this was an auto-propagated
-- update.
module Unison.Merge.Synhash
  ( synhashType,
    synhashTerm,
    synhashBuiltinTerm,
    synhashDerivedTerm,
    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
import Unison.ConstructorType (ConstructorType)
import Unison.ConstructorType qualified as CT
import Unison.DataDeclaration (DataDeclaration, Decl)
import Unison.DataDeclaration qualified as DD
import Unison.Hash (Hash)
import Unison.HashQualified as HQ
import Unison.Hashable qualified as H
import Unison.Kind qualified as K
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv)
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Reference (Reference' (..), TermReferenceId)
import Unison.Reference qualified as V1
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
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 Witch (unsafeFrom)

type Token = H.Token Hash

-- A few tags for readability

isBuiltinTag, isNotBuiltinTag :: H.Token Hash
isBuiltinTag :: Token
isBuiltinTag = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0
isNotBuiltinTag :: Token
isNotBuiltinTag = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1

isDeclTag, isTermTag :: H.Token Hash
isDeclTag :: Token
isDeclTag = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0
isTermTag :: Token
isTermTag = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1

synhashBuiltinDecl :: Text -> Hash
synhashBuiltinDecl :: Text -> Hash
synhashBuiltinDecl Text
name =
  [Token] -> Hash
forall h. Accumulate h => [Token h] -> h
H.accumulate [Token
isBuiltinTag, Token
isDeclTag, Text -> Token
forall h. Text -> Token h
H.Text Text
name]

synhashBuiltinTerm :: Text -> Hash
synhashBuiltinTerm :: Text -> Hash
synhashBuiltinTerm =
  [Token] -> Hash
forall h. Accumulate h => [Token h] -> h
H.accumulate ([Token] -> Hash) -> (Text -> [Token]) -> Text -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Token]
hashBuiltinTermTokens

hashBuiltinTermTokens :: Text -> [Token]
hashBuiltinTermTokens :: Text -> [Token]
hashBuiltinTermTokens Text
name =
  [Token
isBuiltinTag, Token
isTermTag, Text -> Token
forall h. Text -> Token h
H.Text Text
name]

hashCaseTokens :: PrettyPrintEnv -> Term.MatchCase loc a -> [Token]
hashCaseTokens :: forall loc a. PrettyPrintEnv -> MatchCase loc a -> [Token]
hashCaseTokens PrettyPrintEnv
ppe (Term.MatchCase Pattern loc
pat Maybe a
Nothing a
_) = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
pat
hashCaseTokens PrettyPrintEnv
ppe (Term.MatchCase Pattern loc
pat (Just a
_) a
_) = Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
pat

-- | The hash of a constructor name determined by how it looks when rendered, i.e. without the decl name prefix.
--
-- For example, in the decl "Maybe" with constructors "Maybe.Just" and "Maybe.Nothing", the hash of constructor
-- "Maybe.Nothing" is hash of the string "Nothing".
hashConstructorNameToken :: Name -> Name -> Token
hashConstructorNameToken :: Name -> Name -> Token
hashConstructorNameToken Name
declName Name
conName =
  let strippedConName :: Name
strippedConName =
        Name -> Name -> Maybe Name
Name.stripNamePrefix Name
declName Name
conName
          Maybe Name -> (Maybe Name -> Name) -> Name
forall a b. a -> (a -> b) -> b
& Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe
            ( [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$
                [Char] -> [Char] -> [Char]
reportBug
                  [Char]
"E784201"
                  ( [Char]
"constructor "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (Name -> Text
Name.toText Name
conName)
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not under decl "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (Name -> Text
Name.toText Name
declName)
                  )
            )
   in Text -> Token
forall h. Text -> Token h
H.Text (Name -> Text
Name.toText Name
strippedConName)

synhashDerivedTerm :: (Var v) => PrettyPrintEnv -> Term v a -> Hash
synhashDerivedTerm :: forall v a. Var v => PrettyPrintEnv -> Term v a -> Hash
synhashDerivedTerm PrettyPrintEnv
ppe Term v a
term =
  [Token] -> Hash
forall h. Accumulate h => [Token h] -> h
H.accumulate (PrettyPrintEnv -> Term v a -> [Token]
forall a v. Var v => PrettyPrintEnv -> Term v a -> [Token]
hashDerivedTermTokens PrettyPrintEnv
ppe Term v a
term)

hashDerivedTermTokens :: forall a v. (Var v) => PrettyPrintEnv -> Term v a -> [Token]
hashDerivedTermTokens :: forall a v. Var v => PrettyPrintEnv -> Term v a -> [Token]
hashDerivedTermTokens PrettyPrintEnv
ppe =
  (Token
isNotBuiltinTag Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:) ([Token] -> [Token])
-> (Term v a -> [Token]) -> Term v a -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token
isTermTag Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:) ([Token] -> [Token])
-> (Term v a -> [Token]) -> Term v a -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Term v a -> [Token]
go []
  where
    go :: [v] -> Term v a -> [Token]
    go :: [v] -> Term v a -> [Token]
go [v]
bound Term v a
t =
      Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
255 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: case Term v a -> ABT (F v a a) v (Term v a)
forall (f :: * -> *) v a. Term f v a -> ABT f v (Term f v a)
ABT.out Term v a
t of
        ABT.Var v
v -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0, [v] -> v -> Token
forall v. Var v => [v] -> v -> Token
hashVarToken [v]
bound v
v]
        -- trick: encode the structure, followed the children as a flat list
        ABT.Tm F v a a (Term v a)
f -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> F v a a () -> [Token]
forall v a. Var v => PrettyPrintEnv -> F v a a () -> [Token]
hashTermFTokens PrettyPrintEnv
ppe (F v a a (Term v a) -> F v a a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void F v a a (Term v a)
f) [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> (F v a a (Term v a) -> [Term v a]
forall a. F v a a a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList F v a a (Term v a)
f [Term v a] -> (Term v a -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [v] -> Term v a -> [Token]
go [v]
bound)
        ABT.Cycle Term v a
c -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
2 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [v] -> Term v a -> [Token]
go [v]
bound Term v a
c
        ABT.Abs v
v Term v a
body -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
3 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [v] -> Term v a -> [Token]
go (v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
bound) Term v a
body

hashConstructorType :: ConstructorType -> Token
hashConstructorType :: ConstructorType -> Token
hashConstructorType = \case
  ConstructorType
CT.Effect -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0
  ConstructorType
CT.Data -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1

hashDataDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
hashDataDeclTokens :: forall v a.
Var v =>
PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
hashDataDeclTokens PrettyPrintEnv
ppe Name
declName (DD.DataDeclaration Modifier
modifier a
_ [v]
bound [(a, v, Type v a)]
ctors) =
  Modifier -> [Token]
hashModifierTokens Modifier
modifier [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> ([(a, v, Type v a)]
ctors [(a, v, Type v a)] -> ((a, v, Type v a) -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
forall v a.
Var v =>
PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
hashConstructorTokens PrettyPrintEnv
ppe Name
declName [v]
bound)

-- separating constructor types with tag of 99, which isn't used elsewhere
hashConstructorTokens :: (Var v) => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
hashConstructorTokens :: forall v a.
Var v =>
PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
hashConstructorTokens PrettyPrintEnv
ppe Name
declName [v]
bound (a
_, v
conName, Type v a
ty) =
  Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
99
    Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Name -> Name -> Token
hashConstructorNameToken Name
declName (v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar v
conName)
    Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> [v] -> Type v a -> [Token]
forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token]
hashTypeTokens PrettyPrintEnv
ppe [v]
bound Type v a
ty

hashDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> [Token]
hashDeclTokens :: forall v a. Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
hashDeclTokens PrettyPrintEnv
ppe Name
name Decl v a
decl =
  ConstructorType -> Token
hashConstructorType (Decl v a -> ConstructorType
forall v a. Decl v a -> ConstructorType
DD.constructorType Decl v a
decl) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
forall v a.
Var v =>
PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
hashDataDeclTokens PrettyPrintEnv
ppe Name
name (Decl v a -> DataDeclaration v a
forall v a. Decl v a -> DataDeclaration v a
DD.asDataDecl Decl v a
decl)

-- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if
-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same,
-- the constructors appear in the same order and have the same names, and the constructors' types have the same
-- syntactic hashes.
synhashDerivedDecl :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> Hash
synhashDerivedDecl :: forall v a. Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash
synhashDerivedDecl PrettyPrintEnv
ppe Name
name Decl v a
decl =
  [Token] -> Hash
forall h. Accumulate h => [Token h] -> h
H.accumulate ([Token] -> Hash) -> [Token] -> Hash
forall a b. (a -> b) -> a -> b
$ Token
isNotBuiltinTag Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
isDeclTag Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Name -> Decl v a -> [Token]
forall v a. Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
hashDeclTokens PrettyPrintEnv
ppe Name
name Decl v a
decl

hashHQNameToken :: HashQualified Name -> Token
hashHQNameToken :: HashQualified Name -> Token
hashHQNameToken =
  Text -> Token
forall h. Text -> Token h
H.Text (Text -> Token)
-> (HashQualified Name -> Text) -> HashQualified Name -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ.toTextWith Name -> Text
Name.toText

hashKindTokens :: K.Kind -> [Token]
hashKindTokens :: Kind -> [Token]
hashKindTokens Kind
k = case Kind
k of
  Kind
K.Star -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0]
  K.Arrow Kind
k1 Kind
k2 -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (Kind -> [Token]
hashKindTokens Kind
k1 [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> Kind -> [Token]
hashKindTokens Kind
k2)

hashLengthToken :: (Foldable t) => t a -> Token
hashLengthToken :: forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken =
  Word64 -> Token
forall h. Word64 -> Token h
H.Nat (Word64 -> Token) -> (t a -> Word64) -> t a -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word64 (Int -> Word64) -> (t a -> Int) -> t a -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

hashModifierTokens :: DD.Modifier -> [Token]
hashModifierTokens :: Modifier -> [Token]
hashModifierTokens = \case
  Modifier
DD.Structural -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0]
  DD.Unique Text
txt -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1, Text -> Token
forall h. Text -> Token h
H.Text Text
txt]

hashPatternTokens :: PrettyPrintEnv -> Pattern.Pattern loc -> [Token]
hashPatternTokens :: forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe = \case
  Pattern.Unbound {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0]
  Pattern.Var {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1]
  Pattern.Boolean loc
_ Bool
b -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
2, if Bool
b then Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0 else Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1]
  Pattern.Int loc
_ Int64
n -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
3, Int64 -> Token
forall h. Int64 -> Token h
H.Int Int64
n]
  Pattern.Nat loc
_ Word64
n -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
4, Word64 -> Token
forall h. Word64 -> Token h
H.Nat Word64
n]
  Pattern.Float loc
_ Double
f -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
5, Double -> Token
forall h. Double -> Token h
H.Double Double
f]
  Pattern.Text loc
_ Text
t -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
6, Text -> Token
forall h. Text -> Token h
H.Text Text
t]
  Pattern.Char loc
_ Char
c -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
7, Word64 -> Token
forall h. Word64 -> Token h
H.Nat (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))]
  Pattern.Constructor loc
_ ConstructorReference
cr [Pattern loc]
ps ->
    Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
8
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
cr ConstructorType
CT.Data)
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Pattern loc] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [Pattern loc]
ps
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: ([Pattern loc]
ps [Pattern loc] -> (Pattern loc -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe)
  Pattern.As loc
_ Pattern loc
p -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
9 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
p
  Pattern.EffectPure loc
_ Pattern loc
p -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
10 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
p
  Pattern.EffectBind loc
_ ConstructorReference
cr [Pattern loc]
ps Pattern loc
k ->
    Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
11
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
cr ConstructorType
CT.Effect)
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Pattern loc] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [Pattern loc]
ps
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
k [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> ([Pattern loc]
ps [Pattern loc] -> (Pattern loc -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe)
  Pattern.SequenceLiteral loc
_ [Pattern loc]
ps -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
12 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Pattern loc] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [Pattern loc]
ps Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: ([Pattern loc]
ps [Pattern loc] -> (Pattern loc -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe)
  Pattern.SequenceOp loc
_ Pattern loc
p SeqOp
op Pattern loc
q -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
16 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: SeqOp -> Token
forall {h}. SeqOp -> Token h
top SeqOp
op Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
p [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> PrettyPrintEnv -> Pattern loc -> [Token]
forall loc. PrettyPrintEnv -> Pattern loc -> [Token]
hashPatternTokens PrettyPrintEnv
ppe Pattern loc
q
    where
      top :: SeqOp -> Token h
top = \case
        SeqOp
Pattern.Concat -> Word8 -> Token h
forall h. Word8 -> Token h
H.Tag Word8
0
        SeqOp
Pattern.Snoc -> Word8 -> Token h
forall h. Word8 -> Token h
H.Tag Word8
1
        SeqOp
Pattern.Cons -> Word8 -> Token h
forall h. Word8 -> Token h
H.Tag Word8
2

hashReferentToken :: PrettyPrintEnv -> Referent -> Token
hashReferentToken :: PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe =
  HashQualified Name -> Token
hashHQNameToken (HashQualified Name -> Token)
-> (Referent -> HashQualified Name) -> Referent -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
PPE.termNameOrHashOnlyFq PrettyPrintEnv
ppe

synhashTerm ::
  forall m v a.
  (Monad m, Var v) =>
  (TermReferenceId -> m (Term v a)) ->
  PrettyPrintEnv ->
  V1.TermReference ->
  m Hash
synhashTerm :: forall (m :: * -> *) v a.
(Monad m, Var v) =>
(TermReferenceId -> m (Term v a))
-> PrettyPrintEnv -> TermReference -> m Hash
synhashTerm TermReferenceId -> m (Term v a)
loadTerm PrettyPrintEnv
ppe = \case
  ReferenceBuiltin Text
builtin -> Hash -> m Hash
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Hash
synhashBuiltinTerm Text
builtin)
  ReferenceDerived TermReferenceId
ref -> PrettyPrintEnv -> Term v a -> Hash
forall v a. Var v => PrettyPrintEnv -> Term v a -> Hash
synhashDerivedTerm PrettyPrintEnv
ppe (Term v a -> Hash) -> m (Term v a) -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermReferenceId -> m (Term v a)
loadTerm TermReferenceId
ref

hashTermFTokens :: (Var v) => PrettyPrintEnv -> Term.F v a a () -> [Token]
hashTermFTokens :: forall v a. Var v => PrettyPrintEnv -> F v a a () -> [Token]
hashTermFTokens PrettyPrintEnv
ppe = \case
  Term.Int Int64
n -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0, Int64 -> Token
forall h. Int64 -> Token h
H.Int Int64
n]
  Term.Nat Word64
n -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1, Word64 -> Token
forall h. Word64 -> Token h
H.Nat Word64
n]
  Term.Float Double
n -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
2, Double -> Token
forall h. Double -> Token h
H.Double Double
n]
  Term.Boolean Bool
b -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
3, if Bool
b then Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0 else Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1]
  Term.Text Text
t -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
4, Text -> Token
forall h. Text -> Token h
H.Text Text
t]
  Term.Char Char
c -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
5, Word64 -> Token
forall h. Word64 -> Token h
H.Nat (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))]
  Term.Blank {} -> [Char] -> [Token]
forall a. HasCallStack => [Char] -> a
error [Char]
"tried to hash a term with blanks, something's very wrong"
  -- note: these are all hashed the same, just based on the name
  Term.Ref TermReference
r -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
7, PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe (TermReference -> Referent
Referent.Ref TermReference
r)]
  Term.Constructor ConstructorReference
cr -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
7, PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
cr ConstructorType
CT.Data)]
  Term.Request ConstructorReference
cr -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
7, PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
cr ConstructorType
CT.Effect)]
  Term.Handle {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
8]
  Term.App {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
9]
  Term.Ann ()
_ Type v a
ty -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
10 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: PrettyPrintEnv -> [v] -> Type v a -> [Token]
forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token]
hashTypeTokens PrettyPrintEnv
ppe [] Type v a
ty
  Term.List Seq ()
xs -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
11, Seq () -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken Seq ()
xs]
  Term.If {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
12]
  Term.And {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
13]
  Term.Or {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
14]
  Term.Lam {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
15]
  Term.LetRec Bool
_ [()]
bs ()
_ -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
16, [()] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [()]
bs]
  Term.Let {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
17]
  Term.Match ()
_scrute [MatchCase a ()]
cases ->
    Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
18 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [MatchCase a ()] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [MatchCase a ()]
cases Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: ([MatchCase a ()]
cases [MatchCase a ()] -> (MatchCase a () -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrettyPrintEnv -> MatchCase a () -> [Token]
forall loc a. PrettyPrintEnv -> MatchCase loc a -> [Token]
hashCaseTokens PrettyPrintEnv
ppe)
  Term.TermLink Referent
rf -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
19, PrettyPrintEnv -> Referent -> Token
hashReferentToken PrettyPrintEnv
ppe Referent
rf]
  Term.TypeLink TermReference
r -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
20, PrettyPrintEnv -> TermReference -> Token
hashTypeReferenceToken PrettyPrintEnv
ppe TermReference
r]

-- | Syntactically hash a type, using reference names rather than hashes.
-- 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 :: forall v a. Var v => PrettyPrintEnv -> Type v a -> Hash
synhashType PrettyPrintEnv
ppe Type v a
ty =
  [Token] -> Hash
forall h. Accumulate h => [Token h] -> h
H.accumulate ([Token] -> Hash) -> [Token] -> Hash
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> [v] -> Type v a -> [Token]
forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token]
hashTypeTokens PrettyPrintEnv
ppe [] Type v a
ty

hashTypeTokens :: forall v a. (Var v) => PrettyPrintEnv -> [v] -> Type v a -> [Token]
hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token]
hashTypeTokens PrettyPrintEnv
ppe = [v] -> Type v a -> [Token]
go
  where
    go :: [v] -> Type v a -> [Token]
    go :: [v] -> Type v a -> [Token]
go [v]
bound Type v a
t =
      Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
254 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: case Type v a -> ABT F v (Type v a)
forall (f :: * -> *) v a. Term f v a -> ABT f v (Term f v a)
ABT.out Type v a
t of
        ABT.Var v
v -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0, [v] -> v -> Token
forall v. Var v => [v] -> v -> Token
hashVarToken [v]
bound v
v]
        -- trick: encode the structure, followed the children as a flat list
        ABT.Tm F (Type v a)
f -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (PrettyPrintEnv -> F () -> [Token]
hashTypeFTokens PrettyPrintEnv
ppe (F (Type v a) -> F ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void F (Type v a)
f) [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> (F (Type v a) -> [Type v a]
forall a. F a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList F (Type v a)
f [Type v a] -> (Type v a -> [Token]) -> [Token]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [v] -> Type v a -> [Token]
go [v]
bound))
        ABT.Cycle Type v a
c -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
2 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [v] -> Type v a -> [Token]
go [v]
bound Type v a
c
        ABT.Abs v
v Type v a
body -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
3 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [v] -> Type v a -> [Token]
go (v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
bound) Type v a
body

hashTypeFTokens :: PrettyPrintEnv -> Type.F () -> [Token]
hashTypeFTokens :: PrettyPrintEnv -> F () -> [Token]
hashTypeFTokens PrettyPrintEnv
ppe = \case
  Type.Ref TermReference
r -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
0, PrettyPrintEnv -> TermReference -> Token
hashTypeReferenceToken PrettyPrintEnv
ppe TermReference
r]
  Type.Arrow {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
1]
  Type.Ann ()
_ Kind
k -> Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
2 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Kind -> [Token]
hashKindTokens Kind
k
  Type.App {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
3]
  Type.Effect {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
4]
  Type.Effects [()]
es -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
5, [()] -> Token
forall (t :: * -> *) a. Foldable t => t a -> Token
hashLengthToken [()]
es]
  Type.Forall {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
6]
  Type.IntroOuter {} -> [Word8 -> Token
forall h. Word8 -> Token h
H.Tag Word8
7]

hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token
hashTypeReferenceToken :: PrettyPrintEnv -> TermReference -> Token
hashTypeReferenceToken PrettyPrintEnv
ppe =
  HashQualified Name -> Token
hashHQNameToken (HashQualified Name -> Token)
-> (TermReference -> HashQualified Name) -> TermReference -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> TermReference -> HashQualified Name
PPE.typeNameOrHashOnlyFq PrettyPrintEnv
ppe

hashVarToken :: (Var v) => [v] -> v -> Token
hashVarToken :: forall v. Var v => [v] -> v -> Token
hashVarToken [v]
bound v
v =
  case v -> [v] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex v
v [v]
bound of
    Maybe Int
Nothing -> [Char] -> Token
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char] -> [Char]
reportBug [Char]
"E633940" ([Char]
"var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not bound in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
bound))
    Just Int
index -> Word64 -> Token
forall h. Word64 -> Token h
H.Nat (forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Int @Word64 Int
index)