{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}

module Unison.Runtime.Referenced
  ( Referenced (..),
    dereference,
    Referential (..),
    RefNum (..),
    CanonST (..),
    emptyCST,
    Canonize,
    resolveRef,
    canonicalizeRefs,
    recanonicalizeRefs,
    toReferenced,
  )
where

import Control.Monad.State.Strict
import Data.Foldable (toList)
import Data.Functor.Const
import Data.Functor.Identity
import Data.HashMap.Strict qualified as HM
import Data.Hashable (Hashable)
import Data.Primitive.Array (arrayFromList, indexArray, sizeofArray)
import Data.Sequence (Seq, (|>))
import Unison.ConstructorReference
import Unison.Reference
import Unison.ReferentPrime
import Unison.Runtime.Canonicalizer
import Prelude hiding (lookup)

-- A number for indexing into a list of common references.
newtype RefNum = RefNum Int
  deriving stock (RefNum -> RefNum -> Bool
(RefNum -> RefNum -> Bool)
-> (RefNum -> RefNum -> Bool) -> Eq RefNum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefNum -> RefNum -> Bool
== :: RefNum -> RefNum -> Bool
$c/= :: RefNum -> RefNum -> Bool
/= :: RefNum -> RefNum -> Bool
Eq, Eq RefNum
Eq RefNum =>
(RefNum -> RefNum -> Ordering)
-> (RefNum -> RefNum -> Bool)
-> (RefNum -> RefNum -> Bool)
-> (RefNum -> RefNum -> Bool)
-> (RefNum -> RefNum -> Bool)
-> (RefNum -> RefNum -> RefNum)
-> (RefNum -> RefNum -> RefNum)
-> Ord RefNum
RefNum -> RefNum -> Bool
RefNum -> RefNum -> Ordering
RefNum -> RefNum -> RefNum
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 :: RefNum -> RefNum -> Ordering
compare :: RefNum -> RefNum -> Ordering
$c< :: RefNum -> RefNum -> Bool
< :: RefNum -> RefNum -> Bool
$c<= :: RefNum -> RefNum -> Bool
<= :: RefNum -> RefNum -> Bool
$c> :: RefNum -> RefNum -> Bool
> :: RefNum -> RefNum -> Bool
$c>= :: RefNum -> RefNum -> Bool
>= :: RefNum -> RefNum -> Bool
$cmax :: RefNum -> RefNum -> RefNum
max :: RefNum -> RefNum -> RefNum
$cmin :: RefNum -> RefNum -> RefNum
min :: RefNum -> RefNum -> RefNum
Ord, Int -> RefNum -> ShowS
[RefNum] -> ShowS
RefNum -> [Char]
(Int -> RefNum -> ShowS)
-> (RefNum -> [Char]) -> ([RefNum] -> ShowS) -> Show RefNum
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefNum -> ShowS
showsPrec :: Int -> RefNum -> ShowS
$cshow :: RefNum -> [Char]
show :: RefNum -> [Char]
$cshowList :: [RefNum] -> ShowS
showList :: [RefNum] -> ShowS
Show)
  deriving newtype (Eq RefNum
Eq RefNum =>
(Int -> RefNum -> Int) -> (RefNum -> Int) -> Hashable RefNum
Int -> RefNum -> Int
RefNum -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> RefNum -> Int
hashWithSalt :: Int -> RefNum -> Int
$chash :: RefNum -> Int
hash :: RefNum -> Int
Hashable)

getRefNum :: RefNum -> Int
getRefNum :: RefNum -> Int
getRefNum (RefNum Int
i) = Int
i

-- A value with optional optimization information for serialization.
-- The references are required for serialization V5, and are assumed
-- to be the only references used in the value _up to in-memory
-- uniqueness_.
--
-- This is parameterized so that it can be used with both Value and
-- Code.
--
-- Also note, the stored referenced might not be 'tight' in the sense
-- that they all actually occur in the value. Maintaining this
-- invariant together with actual canonicalization would be onerous
-- and isn't done at this time.
data Referenced t
  = -- types, terms
    WithRefs [Reference] [Reference] (t RefNum)
  | Plain (t Reference)

instance (forall r. (Eq r) => Eq (t r)) => Eq (Referenced t) where
  Plain t Reference
x == :: Referenced t -> Referenced t -> Bool
== Plain t Reference
y = t Reference
x t Reference -> t Reference -> Bool
forall a. Eq a => a -> a -> Bool
== t Reference
y
  WithRefs [Reference]
tysx [Reference]
tmsx t RefNum
x == WithRefs [Reference]
tysy [Reference]
tmsy t RefNum
y =
    [Reference]
tysx [Reference] -> [Reference] -> Bool
forall a. Eq a => a -> a -> Bool
== [Reference]
tysy Bool -> Bool -> Bool
&& [Reference]
tmsx [Reference] -> [Reference] -> Bool
forall a. Eq a => a -> a -> Bool
== [Reference]
tmsy Bool -> Bool -> Bool
&& t RefNum
x t RefNum -> t RefNum -> Bool
forall a. Eq a => a -> a -> Bool
== t RefNum
y
  Referenced t
_ == Referenced t
_ = Bool
False

instance (forall r. (Show r) => Show (t r)) => Show (Referenced t) where
  showsPrec :: Int -> Referenced t -> ShowS
showsPrec Int
p = \case
    Plain t Reference
t -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ([Char] -> ShowS
showString [Char]
"Plain " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t Reference -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 t Reference
t)
    WithRefs [Reference]
tys [Reference]
tms t RefNum
t ->
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        [Char] -> ShowS
showString [Char]
"WithRefs "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> ShowS
forall a. Show a => a -> ShowS
shows [Reference]
tys
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> ShowS
forall a. Show a => a -> ShowS
shows [Reference]
tms
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t RefNum -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 t RefNum
t

-- A class categorizing types that contain something like a codebase
-- reference, providing traversal functions over the references. The
-- difference between just being a Functor/Traversable is that
-- references may be either term or type references, and the
-- traversals make that information available.
--
-- In all cases, the boolean argument is 'is the reference a type,' so
-- `False` indicates a term reference and `True` indicates a type
-- reference.
class Referential t where
  overRefs :: (Bool -> r -> s) -> t r -> t s
  foldMapRefs :: (Monoid m) => (Bool -> r -> m) -> t r -> m
  traverseRefs :: (Applicative f) => (Bool -> r -> f s) -> t r -> f (t s)

  overRefs Bool -> r -> s
f = Identity (t s) -> t s
forall a. Identity a -> a
runIdentity (Identity (t s) -> t s) -> (t r -> Identity (t s)) -> t r -> t s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> r -> Identity s) -> t r -> Identity (t s)
forall (t :: * -> *) (f :: * -> *) r s.
(Referential t, Applicative f) =>
(Bool -> r -> f s) -> t r -> f (t s)
forall (f :: * -> *) r s.
Applicative f =>
(Bool -> r -> f s) -> t r -> f (t s)
traverseRefs (\Bool
isTy -> s -> Identity s
forall a. a -> Identity a
Identity (s -> Identity s) -> (r -> s) -> r -> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> r -> s
f Bool
isTy)
  foldMapRefs Bool -> r -> m
f = Const m (t Any) -> m
forall {k} a (b :: k). Const a b -> a
getConst (Const m (t Any) -> m) -> (t r -> Const m (t Any)) -> t r -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> r -> Const m Any) -> t r -> Const m (t Any)
forall (t :: * -> *) (f :: * -> *) r s.
(Referential t, Applicative f) =>
(Bool -> r -> f s) -> t r -> f (t s)
forall (f :: * -> *) r s.
Applicative f =>
(Bool -> r -> f s) -> t r -> f (t s)
traverseRefs (\Bool
isTy -> m -> Const m Any
forall {k} a (b :: k). a -> Const a b
Const (m -> Const m Any) -> (r -> m) -> r -> Const m Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> r -> m
f Bool
isTy)

instance Referential Referent' where
  overRefs :: forall r s. (Bool -> r -> s) -> Referent' r -> Referent' s
overRefs Bool -> r -> s
f = \case
    Con' (ConstructorReference r
r ConstructorId
j) ConstructorType
i ->
      GConstructorReference s -> ConstructorType -> Referent' s
forall r. GConstructorReference r -> ConstructorType -> Referent' r
Con' (s -> ConstructorId -> GConstructorReference s
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference (Bool -> r -> s
f Bool
True r
r) ConstructorId
j) ConstructorType
i
    Ref' r
r -> s -> Referent' s
forall r. r -> Referent' r
Ref' (Bool -> r -> s
f Bool
False r
r)

  foldMapRefs :: forall m r. Monoid m => (Bool -> r -> m) -> Referent' r -> m
foldMapRefs Bool -> r -> m
f = \case
    Con' (ConstructorReference r
r ConstructorId
_) ConstructorType
_ -> Bool -> r -> m
f Bool
True r
r
    Ref' r
r -> Bool -> r -> m
f Bool
False r
r

  traverseRefs :: forall (f :: * -> *) r s.
Applicative f =>
(Bool -> r -> f s) -> Referent' r -> f (Referent' s)
traverseRefs Bool -> r -> f s
f = \case
    Con' (ConstructorReference r
r ConstructorId
j) ConstructorType
i ->
      (GConstructorReference s -> ConstructorType -> Referent' s)
-> ConstructorType -> GConstructorReference s -> Referent' s
forall a b c. (a -> b -> c) -> b -> a -> c
flip GConstructorReference s -> ConstructorType -> Referent' s
forall r. GConstructorReference r -> ConstructorType -> Referent' r
Con' ConstructorType
i (GConstructorReference s -> Referent' s)
-> (s -> GConstructorReference s) -> s -> Referent' s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> ConstructorId -> GConstructorReference s)
-> ConstructorId -> s -> GConstructorReference s
forall a b c. (a -> b -> c) -> b -> a -> c
flip s -> ConstructorId -> GConstructorReference s
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference ConstructorId
j (s -> Referent' s) -> f s -> f (Referent' s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> r -> f s
f Bool
True r
r
    Ref' r
r -> s -> Referent' s
forall r. r -> Referent' r
Ref' (s -> Referent' s) -> f s -> f (Referent' s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> r -> f s
f Bool
False r
r

dereference :: (Referential t) => Referenced t -> t Reference
dereference :: forall (t :: * -> *). Referential t => Referenced t -> t Reference
dereference (Plain t Reference
x) = t Reference
x
dereference (WithRefs [Reference]
tysl [Reference]
tmsl t RefNum
x) = (Bool -> RefNum -> Reference) -> t RefNum -> t Reference
forall r s. (Bool -> r -> s) -> t r -> t s
forall (t :: * -> *) r s.
Referential t =>
(Bool -> r -> s) -> t r -> t s
overRefs Bool -> RefNum -> Reference
lkup t RefNum
x
  where
    tys :: Array Reference
tys = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tysl
    tms :: Array Reference
tms = [Reference] -> Array Reference
forall a. [a] -> Array a
arrayFromList [Reference]
tmsl
    lkup :: Bool -> RefNum -> Reference
lkup Bool
isTy (RefNum Int
i)
      | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array Reference -> Int
forall a. Array a -> Int
sizeofArray Array Reference
arr = Array Reference -> Int -> Reference
forall a. Array a -> Int -> a
indexArray Array Reference
arr Int
i
      | Bool
otherwise = [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"dereference: index out of bounds"
      where
        arr :: Array Reference
arr = if Bool
isTy then Array Reference
tys else Array Reference
tms

data CanonST = CST
  { CanonST -> Canonicalizer Reference
canon :: Canonicalizer Reference,
    CanonST -> CanonMap Reference RefNum
_tyNums :: CanonMap Reference RefNum,
    CanonST -> CanonMap Reference RefNum
_tmNums :: CanonMap Reference RefNum,
    CanonST -> Seq Reference
_tys :: Seq Reference,
    CanonST -> Seq Reference
_tms :: Seq Reference
  }

emptyCST :: CanonST
emptyCST :: CanonST
emptyCST = Canonicalizer Reference
-> CanonMap Reference RefNum
-> CanonMap Reference RefNum
-> Seq Reference
-> Seq Reference
-> CanonST
CST Canonicalizer Reference
forall a. Canonicalizer a
empty CanonMap Reference RefNum
forall k v. CanonMap k v
emptyCM CanonMap Reference RefNum
forall k v. CanonMap k v
emptyCM Seq Reference
forall a. Monoid a => a
mempty Seq Reference
forall a. Monoid a => a
mempty

type Canonize = StateT CanonST IO

resolveRef :: Bool -> Reference -> Canonize RefNum
resolveRef :: Bool -> Reference -> Canonize RefNum
resolveRef Bool
isTy = [Char] -> Bool -> Reference -> Canonize RefNum
resolveRef0 [Char]
"resolveRef" Bool
isTy

resolveRef0 :: String -> Bool -> Reference -> Canonize RefNum
resolveRef0 :: [Char] -> Bool -> Reference -> Canonize RefNum
resolveRef0 [Char]
funName Bool
isTy Reference
r = (CanonST -> IO (RefNum, CanonST)) -> Canonize RefNum
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \st :: CanonST
st@(CST Canonicalizer Reference
canon CanonMap Reference RefNum
tym CanonMap Reference RefNum
tmm Seq Reference
tys Seq Reference
tms) ->
  let look :: Reference -> IO (Maybe RefNum)
look Reference
r = Reference -> CanonMap Reference RefNum -> IO (Maybe RefNum)
forall k v. Ord k => k -> CanonMap k v -> IO (Maybe v)
lookup Reference
r (if Bool
isTy then CanonMap Reference RefNum
tym else CanonMap Reference RefNum
tmm)
   in Canonicalizer Reference -> Reference -> IO (Canonicity Reference)
forall a. Ord a => Canonicalizer a -> a -> IO (Canonicity a)
categorize Canonicalizer Reference
canon Reference
r IO (Canonicity Reference)
-> (Canonicity Reference -> IO (RefNum, CanonST))
-> IO (RefNum, CanonST)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Canonicity Reference
Canonical ->
          Reference -> IO (Maybe RefNum)
look Reference
r IO (Maybe RefNum)
-> (Maybe RefNum -> IO (RefNum, CanonST)) -> IO (RefNum, CanonST)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just RefNum
rn -> (RefNum, CanonST) -> IO (RefNum, CanonST)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefNum
rn, CanonST
st)
            Maybe RefNum
Nothing -> IO (RefNum, CanonST)
errmsg
        Novel Canonicalizer Reference
canon -> do
          CanonMap Reference RefNum
tym <- if Bool
isTy then Reference
-> RefNum
-> CanonMap Reference RefNum
-> IO (CanonMap Reference RefNum)
forall k v. Ord k => k -> v -> CanonMap k v -> IO (CanonMap k v)
insert Reference
r RefNum
rn CanonMap Reference RefNum
tym else CanonMap Reference RefNum -> IO (CanonMap Reference RefNum)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CanonMap Reference RefNum
tym
          CanonMap Reference RefNum
tmm <- if Bool
isTy then CanonMap Reference RefNum -> IO (CanonMap Reference RefNum)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CanonMap Reference RefNum
tmm else Reference
-> RefNum
-> CanonMap Reference RefNum
-> IO (CanonMap Reference RefNum)
forall k v. Ord k => k -> v -> CanonMap k v -> IO (CanonMap k v)
insert Reference
r RefNum
rn CanonMap Reference RefNum
tmm
          Seq Reference
tys <- Seq Reference -> IO (Seq Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Reference -> IO (Seq Reference))
-> Seq Reference -> IO (Seq Reference)
forall a b. (a -> b) -> a -> b
$ if Bool
isTy then Seq Reference
tys Seq Reference -> Reference -> Seq Reference
forall a. Seq a -> a -> Seq a
|> Reference
r else Seq Reference
tys
          Seq Reference
tms <- Seq Reference -> IO (Seq Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Reference -> IO (Seq Reference))
-> Seq Reference -> IO (Seq Reference)
forall a b. (a -> b) -> a -> b
$ if Bool
isTy then Seq Reference
tms else Seq Reference
tms Seq Reference -> Reference -> Seq Reference
forall a. Seq a -> a -> Seq a
|> Reference
r
          pure (RefNum
rn, Canonicalizer Reference
-> CanonMap Reference RefNum
-> CanonMap Reference RefNum
-> Seq Reference
-> Seq Reference
-> CanonST
CST Canonicalizer Reference
canon CanonMap Reference RefNum
tym CanonMap Reference RefNum
tmm Seq Reference
tys Seq Reference
tms)
          where
            rn :: RefNum
rn
              | Bool
isTy = Int -> RefNum
RefNum (Seq Reference -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Reference
tys)
              | Bool
otherwise = Int -> RefNum
RefNum (Seq Reference -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Reference
tms)
        Equivalent Reference
s Canonicalizer Reference
canon ->
          Reference -> IO (Maybe RefNum)
look Reference
s IO (Maybe RefNum)
-> (Maybe RefNum -> IO (RefNum, CanonST)) -> IO (RefNum, CanonST)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just RefNum
rn -> (RefNum, CanonST) -> IO (RefNum, CanonST)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefNum
rn, CanonST
st {canon = canon})
            Maybe RefNum
Nothing -> IO (RefNum, CanonST)
errmsg
  where
    errmsg :: IO (RefNum, CanonST)
errmsg = [Char] -> IO (RefNum, CanonST)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (RefNum, CanonST)) -> [Char] -> IO (RefNum, CanonST)
forall a b. (a -> b) -> a -> b
$ [Char]
funName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": inconsistent canonization state"

-- Given a reference traversal, canonicalizes the references in a
-- value. The operation is presented as a state transformation, so
-- that it can hook into a larger canonicalization procedure. The
-- lists of canonical references of each sort are yielded as part of
-- the state.
canonicalizeRefs :: (Referential t) => t Reference -> Canonize (t RefNum)
canonicalizeRefs :: forall (t :: * -> *).
Referential t =>
t Reference -> Canonize (t RefNum)
canonicalizeRefs = (Bool -> Reference -> Canonize RefNum)
-> t Reference -> StateT CanonST IO (t RefNum)
forall (t :: * -> *) (f :: * -> *) r s.
(Referential t, Applicative f) =>
(Bool -> r -> f s) -> t r -> f (t s)
forall (f :: * -> *) r s.
Applicative f =>
(Bool -> r -> f s) -> t r -> f (t s)
traverseRefs ((Bool -> Reference -> Canonize RefNum)
 -> t Reference -> StateT CanonST IO (t RefNum))
-> (Bool -> Reference -> Canonize RefNum)
-> t Reference
-> StateT CanonST IO (t RefNum)
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool -> Reference -> Canonize RefNum
resolveRef0 [Char]
"canonicalizeRefs"
{-# INLINE canonicalizeRefs #-}

-- Given a `Referenced` value, this recanonicalizes the references in
-- the wrapped value. The intention is for this to be hooked into a
-- larger canonicalization procedure, so that already canonicalized
-- values can be more efficiently brought in line with other values
-- that are already canonicalized.
--
-- If the `Referenced` value is `Plain`, then all we can do is
-- traverse it, canonicalizing the references. However, if it is
-- tagged with canonical refs, we can see if they all match existing
-- canonical refs. If so, we don't need to traverse the value. Even if
-- not, we can traverse with marginally more efficient lookups.
recanonicalizeRefs ::
  (Referential t) => Referenced t -> Canonize (t RefNum)
recanonicalizeRefs :: forall (t :: * -> *).
Referential t =>
Referenced t -> Canonize (t RefNum)
recanonicalizeRefs = \case
  Plain t Reference
v -> t Reference -> Canonize (t RefNum)
forall (t :: * -> *).
Referential t =>
t Reference -> Canonize (t RefNum)
canonicalizeRefs t Reference
v
  WithRefs [Reference]
tys [Reference]
tms t RefNum
v -> do
    [RefNum]
tyns <- (Reference -> Canonize RefNum)
-> [Reference] -> StateT CanonST IO [RefNum]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Char] -> Bool -> Reference -> Canonize RefNum
resolveRef0 [Char]
"recanonicalizeRefs" Bool
True) [Reference]
tys
    [RefNum]
tmns <- (Reference -> Canonize RefNum)
-> [Reference] -> StateT CanonST IO [RefNum]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Char] -> Bool -> Reference -> Canonize RefNum
resolveRef0 [Char]
"recanonicalizeRefs" Bool
False) [Reference]
tms

    HashMap Int RefNum
rtys <- HashMap Int RefNum -> StateT CanonST IO (HashMap Int RefNum)
forall a. a -> StateT CanonST IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Int RefNum -> StateT CanonST IO (HashMap Int RefNum))
-> ([(Int, RefNum)] -> HashMap Int RefNum)
-> [(Int, RefNum)]
-> StateT CanonST IO (HashMap Int RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, RefNum)] -> HashMap Int RefNum
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Int, RefNum)] -> HashMap Int RefNum)
-> ([(Int, RefNum)] -> [(Int, RefNum)])
-> [(Int, RefNum)]
-> HashMap Int RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, RefNum) -> Bool) -> [(Int, RefNum)] -> [(Int, RefNum)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, RefNum) -> Bool
notSame ([(Int, RefNum)] -> StateT CanonST IO (HashMap Int RefNum))
-> [(Int, RefNum)] -> StateT CanonST IO (HashMap Int RefNum)
forall a b. (a -> b) -> a -> b
$ [Int] -> [RefNum] -> [(Int, RefNum)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [RefNum]
tyns
    HashMap Int RefNum
rtms <- HashMap Int RefNum -> StateT CanonST IO (HashMap Int RefNum)
forall a. a -> StateT CanonST IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Int RefNum -> StateT CanonST IO (HashMap Int RefNum))
-> ([(Int, RefNum)] -> HashMap Int RefNum)
-> [(Int, RefNum)]
-> StateT CanonST IO (HashMap Int RefNum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, RefNum)] -> HashMap Int RefNum
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Int, RefNum)] -> HashMap Int RefNum)
-> ([(Int, RefNum)] -> [(Int, RefNum)])
-> [(Int, RefNum)]
-> HashMap Int RefNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, RefNum) -> Bool) -> [(Int, RefNum)] -> [(Int, RefNum)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, RefNum) -> Bool
notSame ([(Int, RefNum)] -> StateT CanonST IO (HashMap Int RefNum))
-> [(Int, RefNum)] -> StateT CanonST IO (HashMap Int RefNum)
forall a b. (a -> b) -> a -> b
$ [Int] -> [RefNum] -> [(Int, RefNum)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [RefNum]
tmns

    let f :: Bool -> RefNum -> RefNum
f Bool
isTy RefNum
r = RefNum -> Int -> HashMap Int RefNum -> RefNum
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.findWithDefault RefNum
r (RefNum -> Int
getRefNum RefNum
r) HashMap Int RefNum
m
          where
            m :: HashMap Int RefNum
m = if Bool
isTy then HashMap Int RefNum
rtys else HashMap Int RefNum
rtms

    if HashMap Int RefNum -> Bool
forall k v. HashMap k v -> Bool
HM.null HashMap Int RefNum
rtys Bool -> Bool -> Bool
&& HashMap Int RefNum -> Bool
forall k v. HashMap k v -> Bool
HM.null HashMap Int RefNum
rtms
      then t RefNum -> Canonize (t RefNum)
forall a. a -> StateT CanonST IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t RefNum
v -- already canonical
      else t RefNum -> Canonize (t RefNum)
forall a. a -> StateT CanonST IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t RefNum -> Canonize (t RefNum))
-> t RefNum -> Canonize (t RefNum)
forall a b. (a -> b) -> a -> b
$ (Bool -> RefNum -> RefNum) -> t RefNum -> t RefNum
forall r s. (Bool -> r -> s) -> t r -> t s
forall (t :: * -> *) r s.
Referential t =>
(Bool -> r -> s) -> t r -> t s
overRefs Bool -> RefNum -> RefNum
f t RefNum
v
  where
    notSame :: (Int, RefNum) -> Bool
notSame (Int
i, RefNum Int
j) = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j

toReferenced :: Canonize (t RefNum) -> IO (Referenced t)
toReferenced :: forall (t :: * -> *). Canonize (t RefNum) -> IO (Referenced t)
toReferenced Canonize (t RefNum)
act = (t RefNum, CanonST) -> Referenced t
forall {t :: * -> *}. (t RefNum, CanonST) -> Referenced t
finalize ((t RefNum, CanonST) -> Referenced t)
-> IO (t RefNum, CanonST) -> IO (Referenced t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canonize (t RefNum) -> CanonST -> IO (t RefNum, CanonST)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Canonize (t RefNum)
act CanonST
emptyCST
  where
    finalize :: (t RefNum, CanonST) -> Referenced t
finalize (t RefNum
x, CST Canonicalizer Reference
_ CanonMap Reference RefNum
_ CanonMap Reference RefNum
_ Seq Reference
tys Seq Reference
tms) =
      [Reference] -> [Reference] -> t RefNum -> Referenced t
forall (t :: * -> *).
[Reference] -> [Reference] -> t RefNum -> Referenced t
WithRefs (Seq Reference -> [Reference]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Reference
tys) (Seq Reference -> [Reference]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Reference
tms) t RefNum
x
{-# INLINE toReferenced #-}