-- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Hashing.V2.ABT
  ( Unison.ABT.Term,
    HashingWarning (..),
    crashOnHashingWarning,
    hash,
    hashComponents,
  )
where

import Control.Exception (throw)
import Data.List hiding (cycle, find)
import Data.List qualified as List (sort)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as Map
import Data.Set qualified as Set
import Unison.ABT
import Unison.Hash (Hash)
import Unison.Hashing.V2.Tokenizable (Hashable1, hash1)
import Unison.Hashing.V2.Tokenizable qualified as Hashable
import Unison.Prelude
import Prelude hiding (abs, cycle)

data HashingWarning
  = -- | two or more component elements can not be completely ordered with respect to one another
    -- https://github.com/unisonweb/unison/issues/2787
    IncompleteElementOrderingError (NonEmpty (NonEmpty String {- Each list is a set of structurally equivalent component elements -}))
  deriving stock (HashingWarning -> HashingWarning -> Bool
(HashingWarning -> HashingWarning -> Bool)
-> (HashingWarning -> HashingWarning -> Bool) -> Eq HashingWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HashingWarning -> HashingWarning -> Bool
== :: HashingWarning -> HashingWarning -> Bool
$c/= :: HashingWarning -> HashingWarning -> Bool
/= :: HashingWarning -> HashingWarning -> Bool
Eq, Eq HashingWarning
Eq HashingWarning =>
(HashingWarning -> HashingWarning -> Ordering)
-> (HashingWarning -> HashingWarning -> Bool)
-> (HashingWarning -> HashingWarning -> Bool)
-> (HashingWarning -> HashingWarning -> Bool)
-> (HashingWarning -> HashingWarning -> Bool)
-> (HashingWarning -> HashingWarning -> HashingWarning)
-> (HashingWarning -> HashingWarning -> HashingWarning)
-> Ord HashingWarning
HashingWarning -> HashingWarning -> Bool
HashingWarning -> HashingWarning -> Ordering
HashingWarning -> HashingWarning -> HashingWarning
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HashingWarning -> HashingWarning -> Ordering
compare :: HashingWarning -> HashingWarning -> Ordering
$c< :: HashingWarning -> HashingWarning -> Bool
< :: HashingWarning -> HashingWarning -> Bool
$c<= :: HashingWarning -> HashingWarning -> Bool
<= :: HashingWarning -> HashingWarning -> Bool
$c> :: HashingWarning -> HashingWarning -> Bool
> :: HashingWarning -> HashingWarning -> Bool
$c>= :: HashingWarning -> HashingWarning -> Bool
>= :: HashingWarning -> HashingWarning -> Bool
$cmax :: HashingWarning -> HashingWarning -> HashingWarning
max :: HashingWarning -> HashingWarning -> HashingWarning
$cmin :: HashingWarning -> HashingWarning -> HashingWarning
min :: HashingWarning -> HashingWarning -> HashingWarning
Ord)
  deriving anyclass (Show HashingWarning
Typeable HashingWarning
(Typeable HashingWarning, Show HashingWarning) =>
(HashingWarning -> SomeException)
-> (SomeException -> Maybe HashingWarning)
-> (HashingWarning -> String)
-> Exception HashingWarning
SomeException -> Maybe HashingWarning
HashingWarning -> String
HashingWarning -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: HashingWarning -> SomeException
toException :: HashingWarning -> SomeException
$cfromException :: SomeException -> Maybe HashingWarning
fromException :: SomeException -> Maybe HashingWarning
$cdisplayException :: HashingWarning -> String
displayException :: HashingWarning -> String
Exception)

instance Show HashingWarning where
  show :: HashingWarning -> String
show HashingWarning
hf = String -> ShowS
reportBug String
"E253299" (HashingWarning -> String
renderHashingFailure HashingWarning
hf)
    where
      renderHashingFailure :: HashingWarning -> String
      renderHashingFailure :: HashingWarning -> String
renderHashingFailure = \case
        IncompleteElementOrderingError NonEmpty (NonEmpty String)
equivalenceSets ->
          [String] -> String
unlines
            [ String
"🐞",
              String
"",
              String
"Sorry, you've encountered a weird situation that we are aware of and are currently working on a fix for.",
              String
"I'll explain what happened and how you can work around it.",
              String
"",
              String
"The following cyclic definition sets could not be completely ordered:",
              NonEmpty (NonEmpty String) -> [NonEmpty String]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (NonEmpty String)
equivalenceSets
                [NonEmpty String] -> (NonEmpty String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ( \NonEmpty String
vs ->
                        String
"  * " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty String
vs)
                    )
                [String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [String] -> String
unlines,
              String
"",
              String
"This happens when multiple definitions in a mutually recursive cycle have a very similar structure.",
              String
"",
              String
"You can work around this by restructuring them to be less similar, e.g. by adding a pure expression to distinguish them, like:",
              String
"_ = \"this is the foo definition\""
            ]

-- | Crash if hashing produced any warnings.
--
-- In the future we will hopefully prevent this error entirely.
crashOnHashingWarning :: (HasCallStack) => ([HashingWarning], a) -> a
crashOnHashingWarning :: forall a. HasCallStack => ([HashingWarning], a) -> a
crashOnHashingWarning = \case
  ([], a
a) -> a
a
  (HashingWarning
hf : [HashingWarning]
_, a
_) -> HashingWarning -> a
forall a e. Exception e => e -> a
throw HashingWarning
hf

-- Hash a strongly connected component and sort its definitions into a canonical order.
hashComponent ::
  forall a f v.
  (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Ord v) =>
  Map.Map v (Term f v a) ->
  ([HashingWarning], (Hash, [(v, Term f v a)]))
hashComponent :: forall a (f :: * -> *) v.
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Ord v) =>
Map v (Term f v a) -> ([HashingWarning], (Hash, [(v, Term f v a)]))
hashComponent Map v (Term f v a)
byName = do
  let ts :: [(v, Term f v a)]
ts = Map v (Term f v a) -> [(v, Term f v a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map v (Term f v a)
byName
  -- First, compute a canonical hash ordering of the component, as well as an environment in which we can hash
  -- individual names.
  ([Hash]
hashes, [Either [v] v]
env) <- [Either [v] v]
-> [(v, Term f v a)]
-> ([HashingWarning], ([Hash], [Either [v] v]))
forall a (f :: * -> *) v.
(Eq v, Functor f, Hashable1 f, Show v) =>
[Either [v] v]
-> [(v, Term f v a)]
-> ([HashingWarning], ([Hash], [Either [v] v]))
doHashCycle [] [(v, Term f v a)]
ts
  -- Construct a list of tokens that is shared by all members of the component. They are disambiguated only by their
  -- name that gets tumbled into the hash.
  let commonTokens :: [Hashable.Token]
      commonTokens :: [Token]
commonTokens = Word8 -> Token
Hashable.Tag Word8
1 Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (Hash -> Token) -> [Hash] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Hash -> Token
Hashable.Hashed [Hash]
hashes
      -- Use a helper function that hashes a single term given its name, now that we have an environment in which we can
      -- look the name up, as well as the common tokens.
      hashName :: v -> Hash
      hashName :: v -> Hash
hashName v
v = [Token] -> Hash
Hashable.accumulate ([Token]
commonTokens [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Hash -> Token
Hashable.Hashed ([Either [v] v] -> Term f v () -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env (v -> Term f v ()
forall v (f :: * -> *). v -> Term f v ()
var v
v :: Term f v ()))])
      ([Hash]
hashes', [(v, Term f v a)]
permutedTerms) =
        [(v, Term f v a)]
ts
          -- Pair each term with its hash
          [(v, Term f v a)]
-> ([(v, Term f v a)] -> [(Hash, (v, Term f v a))])
-> [(Hash, (v, Term f v a))]
forall a b. a -> (a -> b) -> b
& ((v, Term f v a) -> (Hash, (v, Term f v a)))
-> [(v, Term f v a)] -> [(Hash, (v, Term f v a))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v, Term f v a)
t -> (v -> Hash
hashName ((v, Term f v a) -> v
forall a b. (a, b) -> a
fst (v, Term f v a)
t), (v, Term f v a)
t))
          -- Sort again to get the final canonical ordering
          [(Hash, (v, Term f v a))]
-> ([(Hash, (v, Term f v a))] -> [(Hash, (v, Term f v a))])
-> [(Hash, (v, Term f v a))]
forall a b. a -> (a -> b) -> b
& ((Hash, (v, Term f v a)) -> Hash)
-> [(Hash, (v, Term f v a))] -> [(Hash, (v, Term f v a))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Hash, (v, Term f v a)) -> Hash
forall a b. (a, b) -> a
fst
          [(Hash, (v, Term f v a))]
-> ([(Hash, (v, Term f v a))] -> ([Hash], [(v, Term f v a)]))
-> ([Hash], [(v, Term f v a)])
forall a b. a -> (a -> b) -> b
& [(Hash, (v, Term f v a))] -> ([Hash], [(v, Term f v a)])
forall a b. [(a, b)] -> ([a], [b])
unzip
      overallHash :: Hash
overallHash = [Token] -> Hash
Hashable.accumulate ((Hash -> Token) -> [Hash] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Hash -> Token
Hashable.Hashed [Hash]
hashes')
  (Hash, [(v, Term f v a)])
-> ([HashingWarning], (Hash, [(v, Term f v a)]))
forall a. a -> ([HashingWarning], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash
overallHash, [(v, Term f v a)]
permutedTerms)

-- Group the definitions into strongly connected components and hash
-- each component. Substitute the hash of each component into subsequent
-- components (using the `termFromHash` function). Requires that the
-- overall component has no free variables.
hashComponents ::
  forall f v a.
  (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) =>
  (Hash -> Word64 -> Term f v ()) ->
  Map.Map v (Term f v a) ->
  ([HashingWarning], [(Hash, [(v, Term f v a)])])
hashComponents :: forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) =>
(Hash -> Word64 -> Term f v ())
-> Map v (Term f v a)
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
hashComponents Hash -> Word64 -> Term f v ()
termFromHash Map v (Term f v a)
termsByName = do
  let bound :: Set v
bound = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList (Map v (Term f v a) -> [v]
forall k a. Map k a -> [k]
Map.keys Map v (Term f v a)
termsByName)
      escapedVars :: Set v
escapedVars = [Set v] -> Set v
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Term f v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
freeVars (Term f v a -> Set v) -> [Term f v a] -> [Set v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map v (Term f v a) -> [Term f v a]
forall k a. Map k a -> [a]
Map.elems Map v (Term f v a)
termsByName) Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set v
bound
      sccs :: [[(v, Term f v a)]]
sccs = [(v, Term f v a)] -> [[(v, Term f v a)]]
forall v (f :: * -> *) a.
Var v =>
[(v, Term f v a)] -> [[(v, Term f v a)]]
components (Map v (Term f v a) -> [(v, Term f v a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map v (Term f v a)
termsByName)
      go :: Map v (Term f v ()) -> [[(v, Term f v a)]] -> ([HashingWarning], [(Hash, [(v, Term f v a)])])
      go :: Map v (Term f v ())
-> [[(v, Term f v a)]]
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
go Map v (Term f v ())
_ [] = [(Hash, [(v, Term f v a)])]
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
forall a. a -> ([HashingWarning], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Hash, [(v, Term f v a)])]
 -> ([HashingWarning], [(Hash, [(v, Term f v a)])]))
-> [(Hash, [(v, Term f v a)])]
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
forall a b. (a -> b) -> a -> b
$ []
      go Map v (Term f v ())
prevHashes ([(v, Term f v a)]
component : [[(v, Term f v a)]]
rest) = do
        let sub :: Term f v a -> Term f v a
sub = [(v, Term f v ())] -> Term f v a -> Term f v a
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v b)] -> Term f v a -> Term f v a
substsInheritAnnotation (Map v (Term f v ()) -> [(v, Term f v ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map v (Term f v ())
prevHashes)
        (Hash
h, [(v, Term f v a)]
sortedComponent) <- Map v (Term f v a) -> ([HashingWarning], (Hash, [(v, Term f v a)]))
forall a (f :: * -> *) v.
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Ord v) =>
Map v (Term f v a) -> ([HashingWarning], (Hash, [(v, Term f v a)]))
hashComponent (Map v (Term f v a)
 -> ([HashingWarning], (Hash, [(v, Term f v a)])))
-> Map v (Term f v a)
-> ([HashingWarning], (Hash, [(v, Term f v a)]))
forall a b. (a -> b) -> a -> b
$ [(v, Term f v a)] -> Map v (Term f v a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v
v, Term f v a -> Term f v a
forall {a}. Term f v a -> Term f v a
sub Term f v a
t) | (v
v, Term f v a
t) <- [(v, Term f v a)]
component]
        let curHashes :: Map v (Term f v ())
curHashes = [(v, Term f v ())] -> Map v (Term f v ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v
v, Hash -> Word64 -> Term f v ()
termFromHash Hash
h Word64
i) | ((v
v, Term f v a
_), Word64
i) <- [(v, Term f v a)]
sortedComponent [(v, Term f v a)] -> [Word64] -> [((v, Term f v a), Word64)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Word64
0 ..]]
            newHashes :: Map v (Term f v ())
newHashes = Map v (Term f v ())
prevHashes Map v (Term f v ()) -> Map v (Term f v ()) -> Map v (Term f v ())
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map v (Term f v ())
curHashes
            newHashesL :: [(v, Term f v ())]
newHashesL = Map v (Term f v ()) -> [(v, Term f v ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map v (Term f v ())
newHashes
            sortedComponent' :: [(v, Term f v a)]
sortedComponent' = [(v
v, [(v, Term f v ())] -> Term f v a -> Term f v a
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v b)] -> Term f v a -> Term f v a
substsInheritAnnotation [(v, Term f v ())]
newHashesL Term f v a
t) | (v
v, Term f v a
t) <- [(v, Term f v a)]
sortedComponent]
        [(Hash, [(v, Term f v a)])]
sortedRest <- Map v (Term f v ())
-> [[(v, Term f v a)]]
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
go Map v (Term f v ())
newHashes [[(v, Term f v a)]]
rest
        pure $ ((Hash
h, [(v, Term f v a)]
sortedComponent') (Hash, [(v, Term f v a)])
-> [(Hash, [(v, Term f v a)])] -> [(Hash, [(v, Term f v a)])]
forall a. a -> [a] -> [a]
: [(Hash, [(v, Term f v a)])]
sortedRest)
   in if Set v -> Bool
forall a. Set a -> Bool
Set.null Set v
escapedVars
        then Map v (Term f v ())
-> [[(v, Term f v a)]]
-> ([HashingWarning], [(Hash, [(v, Term f v a)])])
go Map v (Term f v ())
forall k a. Map k a
Map.empty [[(v, Term f v a)]]
sccs
        else
          String -> ([HashingWarning], [(Hash, [(v, Term f v a)])])
forall a. HasCallStack => String -> a
error (String -> ([HashingWarning], [(Hash, [(v, Term f v a)])]))
-> String -> ([HashingWarning], [(Hash, [(v, Term f v a)])])
forall a b. (a -> b) -> a -> b
$
            String
"can't hashComponents if bindings have free variables:\n  "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((v -> String) -> [v] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map v -> String
forall a. Show a => a -> String
show (Set v -> [v]
forall a. Set a -> [a]
Set.toList Set v
escapedVars))
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n  "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((v -> String) -> [v] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map v -> String
forall a. Show a => a -> String
show (Map v (Term f v a) -> [v]
forall k a. Map k a -> [k]
Map.keys Map v (Term f v a)
termsByName))

-- | We ignore annotations in the `Term`, as these should never affect the
-- meaning of the term.
hash ::
  forall f v a.
  (Functor f, Hashable1 f, Eq v, Show v) =>
  Term f v a ->
  Hash
hash :: forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
Term f v a -> Hash
hash = [Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' []

hash' ::
  forall f v a.
  (Functor f, Hashable1 f, Eq v, Show v) =>
  [Either [v] v] ->
  Term f v a ->
  Hash
hash' :: forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env = \case
  Var' v
v -> Hash -> (Int -> Hash) -> Maybe Int -> Hash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hash
forall {a}. a
die Int -> Hash
hashInt Maybe Int
ind
    where
      lookup :: Either (t v) v -> Bool
lookup (Left t v
cycle) = v
v v -> t v -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t v
cycle
      lookup (Right v
v') = v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v'
      ind :: Maybe Int
ind = (Either [v] v -> Bool) -> [Either [v] v] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex Either [v] v -> Bool
forall {t :: * -> *}. Foldable t => Either (t v) v -> Bool
lookup [Either [v] v]
env
      hashInt :: Int -> Hash
      hashInt :: Int -> Hash
hashInt Int
i = [Token] -> Hash
Hashable.accumulate [Word64 -> Token
Hashable.Nat (Word64 -> Token) -> Word64 -> Token
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i]
      die :: a
die =
        String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
          String
"unknown var in environment: "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" environment = "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Either [v] v] -> String
forall a. Show a => a -> String
show [Either [v] v]
env
  Cycle' [v]
vs f (Term f v a)
t -> ([Term f v a] -> ([Hash], Term f v a -> Hash))
-> (Term f v a -> Hash) -> f (Term f v a) -> Hash
forall a.
([a] -> ([Hash], a -> Hash)) -> (a -> Hash) -> f a -> Hash
forall (f :: * -> *) a.
Hashable1 f =>
([a] -> ([Hash], a -> Hash)) -> (a -> Hash) -> f a -> Hash
hash1 ([v]
-> [Either [v] v] -> [Term f v a] -> ([Hash], Term f v a -> Hash)
hashCycle [v]
vs [Either [v] v]
env) Term f v a -> Hash
forall a. HasCallStack => a
undefined f (Term f v a)
t
  Abs'' v
v Term f v a
t -> [Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' (v -> Either [v] v
forall a b. b -> Either a b
Right v
v Either [v] v -> [Either [v] v] -> [Either [v] v]
forall a. a -> [a] -> [a]
: [Either [v] v]
env) Term f v a
t
  Tm' f (Term f v a)
t -> ([Term f v a] -> ([Hash], Term f v a -> Hash))
-> (Term f v a -> Hash) -> f (Term f v a) -> Hash
forall a.
([a] -> ([Hash], a -> Hash)) -> (a -> Hash) -> f a -> Hash
forall (f :: * -> *) a.
Hashable1 f =>
([a] -> ([Hash], a -> Hash)) -> (a -> Hash) -> f a -> Hash
hash1 (\[Term f v a]
ts -> ([Hash] -> [Hash]
forall a. Ord a => [a] -> [a]
List.sort ((Term f v a -> Hash) -> [Term f v a] -> [Hash]
forall a b. (a -> b) -> [a] -> [b]
map ([Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env) [Term f v a]
ts), [Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env)) ([Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env) f (Term f v a)
t
  where
    hashCycle :: [v] -> [Either [v] v] -> [Term f v a] -> (([Hash], Term f v a -> Hash))
    hashCycle :: [v]
-> [Either [v] v] -> [Term f v a] -> ([Hash], Term f v a -> Hash)
hashCycle [v]
cycle [Either [v] v]
env [Term f v a]
ts =
      -- We ignore incomplete element ordering warnings when calling in from hash';
      -- we don't want to error on that when hashing internal let-bindings.
      let ([HashingWarning]
_warnings, ([Hash]
ts', [Either [v] v]
env')) = [Either [v] v]
-> [(v, Term f v a)]
-> ([HashingWarning], ([Hash], [Either [v] v]))
forall a (f :: * -> *) v.
(Eq v, Functor f, Hashable1 f, Show v) =>
[Either [v] v]
-> [(v, Term f v a)]
-> ([HashingWarning], ([Hash], [Either [v] v]))
doHashCycle [Either [v] v]
env ([v] -> [Term f v a] -> [(v, Term f v a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
cycle [Term f v a]
ts)
       in ([Hash]
ts', [Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
env')

-- | @doHashCycle env terms@ hashes cycle @terms@ in environment @env@, and returns the canonical ordering of the hashes
-- of those terms, as well as an updated environment with each of the terms' bindings in the canonical ordering.
doHashCycle ::
  forall a f v.
  (Eq v, Functor f, Hashable1 f, Show v) =>
  [Either [v] v] ->
  [(v, Term f v a)] ->
  -- Hashing always succeeds even if it generates warnings.
  ([HashingWarning], ([Hash], [Either [v] v]))
doHashCycle :: forall a (f :: * -> *) v.
(Eq v, Functor f, Hashable1 f, Show v) =>
[Either [v] v]
-> [(v, Term f v a)]
-> ([HashingWarning], ([Hash], [Either [v] v]))
doHashCycle [Either [v] v]
env [(v, Term f v a)]
namedTerms = do
  -- Ensure that all of the hashes we use for ordering components are unique;
  -- if not, we have an incomplete ordering of the elements in the cycle.
  -- Report a warning if there are any structurally equivalent elements,
  -- the caller can choose what to do with the warning.
  Maybe (NonEmpty (NonEmpty v))
-> (NonEmpty (NonEmpty v) -> ([HashingWarning], ()))
-> ([HashingWarning], ())
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (NonEmpty (NonEmpty v))
structurallyEquivalentElements \NonEmpty (NonEmpty v)
vs ->
    -- Accumulate errors using the tuple monad.
    ([NonEmpty (NonEmpty String) -> HashingWarning
IncompleteElementOrderingError (NonEmpty (NonEmpty v)
vs NonEmpty (NonEmpty v)
-> (NonEmpty v -> NonEmpty String) -> NonEmpty (NonEmpty String)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (NonEmpty String -> NonEmpty String
forall a. Ord a => NonEmpty a -> NonEmpty a
NEL.sort (NonEmpty String -> NonEmpty String)
-> (NonEmpty v -> NonEmpty String) -> NonEmpty v -> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> String) -> NonEmpty v -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> String
forall a. Show a => a -> String
show) NonEmpty (NonEmpty String)
-> (NonEmpty (NonEmpty String) -> NonEmpty (NonEmpty String))
-> NonEmpty (NonEmpty String)
forall a b. a -> (a -> b) -> b
& NonEmpty (NonEmpty String) -> NonEmpty (NonEmpty String)
forall a. Ord a => NonEmpty a -> NonEmpty a
NEL.sort)], ())
  pure $ ((Term f v a -> Hash) -> [Term f v a] -> [Hash]
forall a b. (a -> b) -> [a] -> [b]
map ([Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
newEnv) [Term f v a]
permutedTerms, [Either [v] v]
newEnv)
  where
    names :: [v]
names = ((v, Term f v a) -> v) -> [(v, Term f v a)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term f v a) -> v
forall a b. (a, b) -> a
fst [(v, Term f v a)]
namedTerms
    -- The environment in which we compute the canonical permutation of terms
    permutationEnv :: [Either [v] v]
permutationEnv = [v] -> Either [v] v
forall a b. a -> Either a b
Left [v]
names Either [v] v -> [Either [v] v] -> [Either [v] v]
forall a. a -> [a] -> [a]
: [Either [v] v]
env
    namedHashes :: [(v, Hash)]
    namedHashes :: [(v, Hash)]
namedHashes = (Term f v a -> Hash) -> (v, Term f v a) -> (v, Hash)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Either [v] v] -> Term f v a -> Hash
forall (f :: * -> *) v a.
(Functor f, Hashable1 f, Eq v, Show v) =>
[Either [v] v] -> Term f v a -> Hash
hash' [Either [v] v]
permutationEnv) ((v, Term f v a) -> (v, Hash)) -> [(v, Term f v a)] -> [(v, Hash)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Term f v a)]
namedTerms
    hashes :: [Hash]
    hashes :: [Hash]
hashes = (v, Hash) -> Hash
forall a b. (a, b) -> b
snd ((v, Hash) -> Hash) -> [(v, Hash)] -> [Hash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Hash)]
namedHashes
    ([v]
permutedNames, [Term f v a]
permutedTerms) =
      [(v, Term f v a)] -> [Hash] -> [((v, Term f v a), Hash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(v, Term f v a)]
namedTerms [Hash]
hashes
        [((v, Term f v a), Hash)]
-> ([((v, Term f v a), Hash)] -> [((v, Term f v a), Hash)])
-> [((v, Term f v a), Hash)]
forall a b. a -> (a -> b) -> b
& (((v, Term f v a), Hash) -> Hash)
-> [((v, Term f v a), Hash)] -> [((v, Term f v a), Hash)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((v, Term f v a), Hash) -> Hash
forall a b. (a, b) -> b
snd
        [((v, Term f v a), Hash)]
-> ([((v, Term f v a), Hash)] -> [(v, Term f v a)])
-> [(v, Term f v a)]
forall a b. a -> (a -> b) -> b
& (((v, Term f v a), Hash) -> (v, Term f v a))
-> [((v, Term f v a), Hash)] -> [(v, Term f v a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((v, Term f v a), Hash) -> (v, Term f v a)
forall a b. (a, b) -> a
fst
        [(v, Term f v a)]
-> ([(v, Term f v a)] -> ([v], [Term f v a]))
-> ([v], [Term f v a])
forall a b. a -> (a -> b) -> b
& [(v, Term f v a)] -> ([v], [Term f v a])
forall a b. [(a, b)] -> ([a], [b])
unzip
    -- The new environment, which includes the names of all of the terms in the cycle, now that we have computed their
    -- canonical ordering
    newEnv :: [Either [v] v]
newEnv = (v -> Either [v] v) -> [v] -> [Either [v] v]
forall a b. (a -> b) -> [a] -> [b]
map v -> Either [v] v
forall a b. b -> Either a b
Right [v]
permutedNames [Either [v] v] -> [Either [v] v] -> [Either [v] v]
forall a. [a] -> [a] -> [a]
++ [Either [v] v]
env
    structurallyEquivalentElements :: Maybe (NonEmpty (NonEmpty v))
    structurallyEquivalentElements :: Maybe (NonEmpty (NonEmpty v))
structurallyEquivalentElements =
      [(v, Hash)]
namedHashes
        [(v, Hash)] -> ((v, Hash) -> (Hash, [v])) -> [(Hash, [v])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(v
v, Hash
h) -> (Hash
h, [v
v]))
        [(Hash, [v])] -> ([(Hash, [v])] -> Map Hash [v]) -> Map Hash [v]
forall a b. a -> (a -> b) -> b
& ([v] -> [v] -> [v]) -> [(Hash, [v])] -> Map Hash [v]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
(<>)
        Map Hash [v]
-> (Map Hash [v] -> Map Hash (NonEmpty v)) -> Map Hash (NonEmpty v)
forall a b. a -> (a -> b) -> b
& ([v] -> Maybe (NonEmpty v))
-> Map Hash [v] -> Map Hash (NonEmpty v)
forall a b. (a -> Maybe b) -> Map Hash a -> Map Hash b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (\[v]
xs -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Maybe () -> Maybe (NonEmpty v) -> Maybe (NonEmpty v)
forall a b. Maybe a -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [v] -> Maybe (NonEmpty v)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [v]
xs)
        Map Hash (NonEmpty v)
-> (Map Hash (NonEmpty v) -> [NonEmpty v]) -> [NonEmpty v]
forall a b. a -> (a -> b) -> b
& Map Hash (NonEmpty v) -> [NonEmpty v]
forall k a. Map k a -> [a]
Map.elems
        [NonEmpty v]
-> ([NonEmpty v] -> Maybe (NonEmpty (NonEmpty v)))
-> Maybe (NonEmpty (NonEmpty v))
forall a b. a -> (a -> b) -> b
& [NonEmpty v] -> Maybe (NonEmpty (NonEmpty v))
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty