{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
#if __GLASGOW_HASKELL__ >= 810
-- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically
-- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the
-- doctests. See #874 for more details.
{-# OPTIONS_GHC -fbyte-code #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Data.Lens
-- Copyright   :  (C) 2012-2016 Edward Kmett, (C) 2006-2012 Neil Mitchell
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  Rank2Types
--
-- Smart and naïve generic traversals given 'Data' instances.
--
-- 'template', 'uniplate', and 'biplate' each build up information about what
-- types can be contained within another type to speed up 'Traversal'.
--
----------------------------------------------------------------------------
module Data.Data.Lens
  (
  -- * Generic Traversal
    template
  , tinplate
  , uniplate
  , biplate
  -- * Field Accessor Traversal
  , upon
  , upon'
  , onceUpon
  , onceUpon'
  -- * Data Traversal
  , gtraverse
  ) where

import           Control.Applicative
import           Control.Exception as E
import           Control.Lens.Internal.Context
import           Control.Lens.Internal.Indexed
import           Control.Lens.Lens
import           Control.Lens.Setter
import           Control.Lens.Traversal
import           Control.Lens.Type
import           Data.Data
import           GHC.IO
import           Data.Maybe
import           Data.Foldable
import qualified Data.HashMap.Strict as M
import           Data.HashMap.Strict (HashMap, (!))
import qualified Data.HashSet as S
import           Data.HashSet (HashSet)
import           Data.IORef
import           Data.Monoid
import           GHC.Exts (realWorld#)
import           Prelude

import qualified Data.Proxy as X (Proxy (..))
import qualified Data.Typeable as X (typeRep, eqT)
import qualified Data.Type.Equality as X

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens

-------------------------------------------------------------------------------
-- Generic Traversal
-------------------------------------------------------------------------------

-- | A generic applicative transformation that maps over the immediate subterms.
--
-- 'gtraverse' is to 'traverse' what 'gmapM' is to 'mapM'
--
-- This really belongs in @Data.Data@.
gtraverse :: (Applicative f, Data a) => (forall d. Data d => d -> f d) -> a -> f a
gtraverse :: (forall d. Data d => d -> f d) -> a -> f a
gtraverse forall d. Data d => d -> f d
f = (forall d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> a -> f a
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl (\f (d -> b)
x d
y -> f (d -> b)
x f (d -> b) -> f d -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
f d
y) forall g. g -> f g
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE gtraverse #-}

-------------------------------------------------------------------------------
-- Naïve Traversal
-------------------------------------------------------------------------------

-- | Naïve 'Traversal' using 'Data'. This does not attempt to optimize the traversal.
--
-- This is primarily useful when the children are immediately obvious, and for benchmarking.
tinplate :: (Data s, Typeable a) => Traversal' s a
tinplate :: Traversal' s a
tinplate a -> f a
f = (forall d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> s -> f s
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl ((a -> f a) -> f (d -> b) -> d -> f b
forall s a (f :: * -> *) r.
(Applicative f, Typeable a, Data s) =>
(a -> f a) -> f (s -> r) -> s -> f r
step a -> f a
f) forall g. g -> f g
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE tinplate #-}

step :: forall s a f r. (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r
step :: (a -> f a) -> f (s -> r) -> s -> f r
step a -> f a
f f (s -> r)
w s
s = f (s -> r)
w f (s -> r) -> f s -> f r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case Maybe (s :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
X.eqT :: Maybe (s X.:~: a) of
  Just s :~: a
X.Refl -> a -> f a
f s
a
s
  Maybe (s :~: a)
Nothing   -> (a -> f a) -> s -> f s
forall s a. (Data s, Typeable a) => Traversal' s a
tinplate a -> f a
f s
s
{-# INLINE step #-}

-------------------------------------------------------------------------------
-- Smart Traversal
-------------------------------------------------------------------------------

-- | Find every occurrence of a given type @a@ recursively that doesn't require
-- passing through something of type @a@ using 'Data', while avoiding traversal
-- of areas that cannot contain a value of type @a@.
--
-- This is 'uniplate' with a more liberal signature.
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template :: Traversal' s a
template = (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData (Oracle a -> forall c. Typeable c => c -> Answer c a
forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = s -> a -> Oracle a
forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (s
forall a. HasCallStack => a
undefined :: s) (a
forall a. HasCallStack => a
undefined :: a)
{-# INLINE template #-}

-- | Find descendants of type @a@ non-transitively, while avoiding computation of areas that cannot contain values of
-- type @a@ using 'Data'.
--
-- 'uniplate' is a useful default definition for 'Control.Lens.Plated.plate'
uniplate :: Data a => Traversal' a a
uniplate :: Traversal' a a
uniplate = (a -> f a) -> a -> f a
forall s a. (Data s, Typeable a) => Traversal' s a
template
{-# INLINE uniplate #-}

-- | 'biplate' performs like 'template', except when @s ~ a@, it returns itself and nothing else.
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate :: Traversal' s a
biplate = (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData (Oracle a -> forall c. Typeable c => c -> Answer c a
forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = s -> a -> Oracle a
forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (s
forall a. HasCallStack => a
undefined :: s) (a
forall a. HasCallStack => a
undefined :: a)
{-# INLINE biplate #-}

------------------------------------------------------------------------------
-- Automatic Traversal construction from field accessors
------------------------------------------------------------------------------

data FieldException a = FieldException !Int a deriving Typeable

instance Show (FieldException a) where
  showsPrec :: Int -> FieldException a -> ShowS
showsPrec Int
d (FieldException Int
i a
_) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"<field " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'>'

instance Typeable a => Exception (FieldException a)

lookupon :: Typeable a => LensLike' (Indexing Identity) s a -> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon :: LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
l s -> a
field s
s = case IO (Either SomeException a) -> Either SomeException a
forall a. IO a -> a
unsafePerformIO (IO (Either SomeException a) -> Either SomeException a)
-> IO (Either SomeException a) -> Either SomeException a
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ s -> a
field (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& LensLike' (Indexing Identity) s a
-> Indexed Int a (Identity a) -> s -> Identity s
forall (p :: * -> * -> *) a (f :: * -> *) b s t.
Indexable Int p =>
((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t
indexing LensLike' (Indexing Identity) s a
l (Indexed Int a (Identity a) -> s -> Identity s)
-> (Int -> a -> a) -> s -> s
forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ \Int
i (a
a::a) -> FieldException a -> a
forall a e. Exception e => e -> a
E.throw (Int -> a -> FieldException a
forall a. Int -> a -> FieldException a
FieldException Int
i a
a) of
  Right a
_ -> Maybe (Int, Context a a s)
forall a. Maybe a
Nothing
  Left SomeException
e -> case SomeException -> Maybe (FieldException a)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Maybe (FieldException a)
Nothing -> Maybe (Int, Context a a s)
forall a. Maybe a
Nothing
    Just (FieldException Int
i a
a) -> (Int, Context a a s) -> Maybe (Int, Context a a s)
forall a. a -> Maybe a
Just (Int
i, (a -> s) -> a -> Context a a s
forall a b t. (b -> t) -> a -> Context a b t
Context (\a
a' -> ASetter s s a a -> a -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set (LensLike' (Indexing Identity) s a
-> Int -> IndexedLensLike Int Identity s s a a
forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike' (Indexing Identity) s a
l Int
i) a
a' s
s) a
a)
{-# INLINE lookupon #-}


-- | This automatically constructs a 'Traversal'' from an function.
--
-- >>> (2,4) & upon fst *~ 5
-- (10,4)
--
-- There are however, caveats on how this function can be used!
--
-- First, the user supplied function must access only one field of the specified type. That is to say the target
-- must be a single element that would be visited by @'holesOnOf' 'template' 'uniplate'@
--
-- Note: this even permits a number of functions to be used directly.
--
-- >>> [1,2,3,4] & upon head .~ 0
-- [0,2,3,4]
--
-- >>> [1,2,3,4] & upon last .~ 5
-- [1,2,3,5]
--
-- >>> [1,2,3,4] ^? upon tail
-- Just [2,3,4]
--
-- >>> "" ^? upon tail
-- Nothing
--
-- Accessing parents on the way down to children is okay:
--
-- >>> [1,2,3,4] & upon (tail.tail) .~ [10,20]
-- [1,2,10,20]
--
-- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data'
--
-- @'upon' :: ('Data' s, 'Data' a) => (s -> a) -> 'IndexedTraversal'' [Int] s a@
upon :: forall p f s a. (Indexable [Int] p, Applicative f, Data s, Data a) => (s -> a) -> p a (f a) -> s -> f s
upon :: (s -> a) -> p a (f a) -> s -> f s
upon s -> a
field p a (f a)
f s
s = case LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing -> s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
  Just (Int
i, Context a -> s
k0 a
a0) ->
    let
      go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s
      go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go [Int]
is Traversal' s a
l a -> s
k a
a = case LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (LensLike' (Indexing Identity) s a
Traversal' s a
lLensLike' (Indexing Identity) s a
-> ((a -> Indexing Identity a) -> a -> Indexing Identity a)
-> LensLike' (Indexing Identity) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Indexing Identity a) -> a -> Indexing Identity a
forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
        Maybe (Int, Context a a s)
Nothing                 -> a -> s
k (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> [Int] -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
is) a
a
        Just (Int
j, Context a -> s
k' a
a') -> [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go (Int
jInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) ((a -> f a) -> s -> f s
Traversal' s a
l((a -> f a) -> s -> f s)
-> ((a -> f a) -> a -> f a) -> (a -> f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LensLike (Indexing f) a a a a
-> Int -> IndexedLensLike Int f a a a a
forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike (Indexing f) a a a a
forall a. Data a => Traversal' a a
uniplate Int
j) a -> s
k' a
a'
    in [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go [Int
i] (LensLike (Indexing f) s s a a
-> Int -> IndexedLensLike Int f s s a a
forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike (Indexing f) s s a a
forall s a. (Data s, Typeable a) => Traversal' s a
template Int
i) a -> s
k0 a
a0
{-# INLINE upon #-}

-- | The design of 'onceUpon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.
-- 'upon'' provides this additional recursion.
--
-- Like 'onceUpon'', 'upon'' trusts the user supplied function more than 'upon' using it directly
-- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of
-- generating an illegal lens.
--
-- >>> upon' (tail.tail) .~ [10,20] $ [1,2,3,4]
-- [1,2,10,20]
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' :: (s -> a) -> IndexedLens' [Int] s a
upon' s -> a
field p a (f a)
f s
s = let
    ~([Int]
isn, a -> s
kn) = case LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing -> (String -> [Int]
forall a. HasCallStack => String -> a
error String
"upon': no index, not a member", s -> a -> s
forall a b. a -> b -> a
const s
s)
      Just (Int
i, Context a -> s
k0 a
_) -> [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go [Int
i] (LensLike (Indexing f) s s a a
-> Int -> IndexedLensLike Int f s s a a
forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike (Indexing f) s s a a
forall s a. (Data s, Typeable a) => Traversal' s a
template Int
i) a -> s
k0
    go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
    go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go [Int]
is Traversal' s a
l a -> s
k = case LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (LensLike' (Indexing Identity) s a
Traversal' s a
lLensLike' (Indexing Identity) s a
-> ((a -> Indexing Identity a) -> a -> Indexing Identity a)
-> LensLike' (Indexing Identity) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Indexing Identity a) -> a -> Indexing Identity a
forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing                -> ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
is, a -> s
k)
      Just (Int
j, Context a -> s
k' a
_) -> [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go (Int
jInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) ((a -> f a) -> s -> f s
Traversal' s a
l((a -> f a) -> s -> f s)
-> ((a -> f a) -> a -> f a) -> (a -> f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LensLike (Indexing f) a a a a
-> Int -> IndexedLensLike Int f a a a a
forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike (Indexing f) a a a a
forall a. Data a => Traversal' a a
uniplate Int
j) a -> s
k'
  in a -> s
kn (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> [Int] -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f [Int]
isn (s -> a
field s
s)
{-# INLINE upon' #-}

-- | This automatically constructs a 'Traversal'' from a field accessor.
--
-- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexing' 'template')@ or into the list
-- returned by @'holesOf' 'template'@.
--
-- The design of 'onceUpon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.
-- 'upon' provides this additional recursion, but at the expense of performance.
--
-- >>> onceUpon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD
-- [1,10,20]
--
-- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD
-- [1,2,10,20]
--
-- When in doubt, use 'upon' instead.
onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedTraversal' Int s a
onceUpon :: (s -> a) -> IndexedTraversal' Int s a
onceUpon s -> a
field p a (f a)
f s
s = case LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing               -> s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
  Just (Int
i, Context a -> s
k a
a) -> a -> s
k (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> Int -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f Int
i a
a
{-# INLINE onceUpon #-}

-- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'.
--
-- This means that reading from 'upon'' is considerably faster than 'upon'.
--
-- However, you pay for faster access in two ways:
--
-- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates
--    the laws, unlike 'upon', which will give you a legal 'Traversal' that avoids modifying the target.
--
-- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact.
--
-- When given a legal field accessor, the index of the 'Lens' can be used as an offset into
-- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@.
--
-- When in doubt, use 'upon'' instead.
onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedLens' Int s a
onceUpon' :: (s -> a) -> IndexedLens' Int s a
onceUpon' s -> a
field p a (f a)
f s
s = a -> s
k (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> Int -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f Int
i (s -> a
field s
s) where
  ~(Int
i, Context a -> s
k a
_) = (Int, Context a a s)
-> Maybe (Int, Context a a s) -> (Int, Context a a s)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Int, Context a a s)
forall a. HasCallStack => String -> a
error String
"upon': no index, not a member") (LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s)
{-# INLINE onceUpon' #-}

-------------------------------------------------------------------------------
-- Data Box
-------------------------------------------------------------------------------

data DataBox = forall a. Data a => DataBox
  { DataBox -> TypeRep
dataBoxKey :: TypeRep
  , ()
_dataBoxVal :: a
  }

dataBox :: Data a => a -> DataBox
dataBox :: a -> DataBox
dataBox a
a = TypeRep -> a -> DataBox
forall a. Data a => TypeRep -> a -> DataBox
DataBox ([a] -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep [a
a]) a
a
{-# INLINE dataBox #-}

-- partial, caught elsewhere
sybChildren :: Data a => a -> [DataBox]
sybChildren :: a -> [DataBox]
sybChildren a
x
  | DataType -> Bool
isAlgType DataType
dt = do
    Constr
c <- DataType -> [Constr]
dataTypeConstrs DataType
dt
    (forall d. Data d => d -> DataBox) -> a -> [DataBox]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> DataBox
dataBox (Constr -> a
forall a. Data a => Constr -> a
fromConstr Constr
c a -> a -> a
forall a. a -> a -> a
`asTypeOf` a
x)
  | Bool
otherwise = []
  where dt :: DataType
dt = a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
x
{-# INLINE sybChildren #-}

-------------------------------------------------------------------------------
-- HitMap
-------------------------------------------------------------------------------

type HitMap = HashMap TypeRep (HashSet TypeRep)

emptyHitMap :: HitMap
emptyHitMap :: HitMap
emptyHitMap = [(TypeRep, HashSet TypeRep)] -> HitMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList
  [ (TypeRep
tRational, TypeRep -> HashSet TypeRep
forall a. Hashable a => a -> HashSet a
S.singleton TypeRep
tInteger)
  , (TypeRep
tInteger,  HashSet TypeRep
forall a. HashSet a
S.empty)
  ] where
  tRational :: TypeRep
tRational = Proxy Rational -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (Proxy Rational
forall k (t :: k). Proxy t
X.Proxy :: X.Proxy Rational)
  tInteger :: TypeRep
tInteger  = Proxy Integer -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (Proxy Integer
forall k (t :: k). Proxy t
X.Proxy :: X.Proxy Integer )

insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap DataBox
box HitMap
hit = (HitMap -> HitMap) -> HitMap -> HitMap
forall a. Eq a => (a -> a) -> a -> a
fixEq HitMap -> HitMap
trans (DataBox -> HitMap
populate DataBox
box) HitMap -> HitMap -> HitMap
forall a. Monoid a => a -> a -> a
`mappend` HitMap
hit where
  populate :: DataBox -> HitMap
  populate :: DataBox -> HitMap
populate DataBox
a = DataBox -> HitMap -> HitMap
f DataBox
a HitMap
forall k v. HashMap k v
M.empty where
    f :: DataBox -> HitMap -> HitMap
f (DataBox TypeRep
k a
v) HitMap
m
      | TypeRep -> HitMap -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
hit Bool -> Bool -> Bool
|| TypeRep -> HitMap -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
m = HitMap
m
      | [DataBox]
cs <- a -> [DataBox]
forall a. Data a => a -> [DataBox]
sybChildren a
v = [DataBox] -> HitMap -> HitMap
fs [DataBox]
cs (HitMap -> HitMap) -> HitMap -> HitMap
forall a b. (a -> b) -> a -> b
$ TypeRep -> HashSet TypeRep -> HitMap -> HitMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert TypeRep
k ([TypeRep] -> HashSet TypeRep
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([TypeRep] -> HashSet TypeRep) -> [TypeRep] -> HashSet TypeRep
forall a b. (a -> b) -> a -> b
$ (DataBox -> TypeRep) -> [DataBox] -> [TypeRep]
forall a b. (a -> b) -> [a] -> [b]
map DataBox -> TypeRep
dataBoxKey [DataBox]
cs) HitMap
m
    fs :: [DataBox] -> HitMap -> HitMap
fs []     HitMap
m = HitMap
m
    fs (DataBox
x:[DataBox]
xs) HitMap
m = [DataBox] -> HitMap -> HitMap
fs [DataBox]
xs (DataBox -> HitMap -> HitMap
f DataBox
x HitMap
m)

  trans :: HitMap -> HitMap
  trans :: HitMap -> HitMap
trans HitMap
m = (HashSet TypeRep -> HashSet TypeRep) -> HitMap -> HitMap
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map HashSet TypeRep -> HashSet TypeRep
f HitMap
m where
    f :: HashSet TypeRep -> HashSet TypeRep
f HashSet TypeRep
x = HashSet TypeRep
x HashSet TypeRep -> HashSet TypeRep -> HashSet TypeRep
forall a. Monoid a => a -> a -> a
`mappend` (TypeRep -> HashSet TypeRep) -> HashSet TypeRep -> HashSet TypeRep
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeRep -> HashSet TypeRep
g HashSet TypeRep
x
    g :: TypeRep -> HashSet TypeRep
g TypeRep
x = HashSet TypeRep -> Maybe (HashSet TypeRep) -> HashSet TypeRep
forall a. a -> Maybe a -> a
fromMaybe (HitMap
hit HitMap -> TypeRep -> HashSet TypeRep
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x) (TypeRep -> HitMap -> Maybe (HashSet TypeRep)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
x HitMap
m)

fixEq :: Eq a => (a -> a) -> a -> a
fixEq :: (a -> a) -> a -> a
fixEq a -> a
f = a -> a
go where
  go :: a -> a
go a
x | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x'   = a
x'
       | Bool
otherwise = a -> a
go a
x'
       where x' :: a
x' = a -> a
f a
x
{-# INLINE fixEq #-}

-- | inlineable 'unsafePerformIO'
inlinePerformIO :: IO a -> a
inlinePerformIO :: IO a -> a
inlinePerformIO (IO State# RealWorld -> (# State# RealWorld, a #)
m) = case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
realWorld# of
  (# State# RealWorld
_, a
r #) -> a
r
{-# INLINE inlinePerformIO #-}

-------------------------------------------------------------------------------
-- Cache
-------------------------------------------------------------------------------

data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower)))

cache :: IORef Cache
cache :: IORef Cache
cache = IO (IORef Cache) -> IORef Cache
forall a. IO a -> a
unsafePerformIO (IO (IORef Cache) -> IORef Cache)
-> IO (IORef Cache) -> IORef Cache
forall a b. (a -> b) -> a -> b
$ Cache -> IO (IORef Cache)
forall a. a -> IO (IORef a)
newIORef (Cache -> IO (IORef Cache)) -> Cache -> IO (IORef Cache)
forall a b. (a -> b) -> a -> b
$ HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
emptyHitMap HashMap TypeRep (HashMap TypeRep (Maybe Follower))
forall k v. HashMap k v
M.empty
{-# NOINLINE cache #-}

readCacheFollower :: DataBox -> TypeRep -> Maybe Follower
readCacheFollower :: DataBox -> TypeRep -> Maybe Follower
readCacheFollower b :: DataBox
b@(DataBox TypeRep
kb a
_) TypeRep
ka = IO (Maybe Follower) -> Maybe Follower
forall a. IO a -> a
inlinePerformIO (IO (Maybe Follower) -> Maybe Follower)
-> IO (Maybe Follower) -> Maybe Follower
forall a b. (a -> b) -> a -> b
$
  IORef Cache -> IO Cache
forall a. IORef a -> IO a
readIORef IORef Cache
cache IO Cache -> (Cache -> IO (Maybe Follower)) -> IO (Maybe Follower)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (Cache HitMap
hm HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m) -> case TypeRep
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower))
-> Maybe (HashMap TypeRep (Maybe Follower))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
kb HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m Maybe (HashMap TypeRep (Maybe Follower))
-> (HashMap TypeRep (Maybe Follower) -> Maybe (Maybe Follower))
-> Maybe (Maybe Follower)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeRep
-> HashMap TypeRep (Maybe Follower) -> Maybe (Maybe Follower)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
ka of
    Just Maybe Follower
a -> Maybe Follower -> IO (Maybe Follower)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
a
    Maybe (Maybe Follower)
Nothing -> IO HitMap -> IO (Either SomeException HitMap)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (HitMap -> IO HitMap
forall (m :: * -> *) a. Monad m => a -> m a
return (HitMap -> IO HitMap) -> HitMap -> IO HitMap
forall a b. (a -> b) -> a -> b
$! DataBox -> HitMap -> HitMap
insertHitMap DataBox
b HitMap
hm) IO (Either SomeException HitMap)
-> (Either SomeException HitMap -> IO (Maybe Follower))
-> IO (Maybe Follower)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either SomeException HitMap
r -> case Either SomeException HitMap
r of
      Left SomeException{}                         -> IORef Cache
-> (Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache ((Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower))
-> (Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower)
forall a b. (a -> b) -> a -> b
$ \(Cache HitMap
hm' HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n) -> (HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
hm' (TypeRep
-> TypeRep
-> Maybe Follower
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower))
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower))
forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
kb TypeRep
ka Maybe Follower
forall a. Maybe a
Nothing HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n), Maybe Follower
forall a. Maybe a
Nothing)
      Right HitMap
hm' | Maybe Follower
fol <- Follower -> Maybe Follower
forall a. a -> Maybe a
Just (TypeRep -> TypeRep -> HitMap -> Follower
follower TypeRep
kb TypeRep
ka HitMap
hm') -> IORef Cache
-> (Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache ((Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower))
-> (Cache -> (Cache, Maybe Follower)) -> IO (Maybe Follower)
forall a b. (a -> b) -> a -> b
$ \(Cache HitMap
_ HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n) -> (HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
hm' (TypeRep
-> TypeRep
-> Maybe Follower
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower))
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower))
forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
kb TypeRep
ka Maybe Follower
fol HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n),    Maybe Follower
fol)

insert2 :: TypeRep -> TypeRep -> a -> HashMap TypeRep (HashMap TypeRep a) -> HashMap TypeRep (HashMap TypeRep a)
insert2 :: TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
x TypeRep
y a
v = (HashMap TypeRep a -> HashMap TypeRep a -> HashMap TypeRep a)
-> TypeRep
-> HashMap TypeRep a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith ((HashMap TypeRep a -> HashMap TypeRep a)
-> HashMap TypeRep a -> HashMap TypeRep a -> HashMap TypeRep a
forall a b. a -> b -> a
const ((HashMap TypeRep a -> HashMap TypeRep a)
 -> HashMap TypeRep a -> HashMap TypeRep a -> HashMap TypeRep a)
-> (HashMap TypeRep a -> HashMap TypeRep a)
-> HashMap TypeRep a
-> HashMap TypeRep a
-> HashMap TypeRep a
forall a b. (a -> b) -> a -> b
$ TypeRep -> a -> HashMap TypeRep a -> HashMap TypeRep a
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert TypeRep
y a
v) TypeRep
x (TypeRep -> a -> HashMap TypeRep a
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton TypeRep
y a
v)
{-# INLINE insert2 #-}

{-
readCacheHitMap :: DataBox -> Maybe HitMap
readCacheHitMap b@(DataBox kb _) = inlinePerformIO $
  readIORef cache >>= \ (Cache hm _) -> case M.lookup kb hm of
    Just _  -> return $ Just hm
    Nothing -> E.try (return $! insertHitMap b hm) >>= \r -> case r of
      Left SomeException{} -> return Nothing
      Right hm' -> atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hm' follow, Just hm')
-}

-------------------------------------------------------------------------------
-- Answers
-------------------------------------------------------------------------------

data Answer b a
  = b ~ a => Hit a
  | Follow
  | Miss

-------------------------------------------------------------------------------
-- Oracles
-------------------------------------------------------------------------------

newtype Oracle a = Oracle { Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle :: forall t. Typeable t => t -> Answer t a }

hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest :: a -> b -> Oracle b
hitTest a
a b
b = (forall t. Typeable t => t -> Answer t b) -> Oracle b
forall a. (forall t. Typeable t => t -> Answer t a) -> Oracle a
Oracle ((forall t. Typeable t => t -> Answer t b) -> Oracle b)
-> (forall t. Typeable t => t -> Answer t b) -> Oracle b
forall a b. (a -> b) -> a -> b
$ \(t
c :: c) ->
  case Maybe (t :~: b)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
X.eqT :: Maybe (c X.:~: b) of
    Just t :~: b
X.Refl -> t -> Answer t t
forall b a. (b ~ a) => a -> Answer b a
Hit t
c
    Maybe (t :~: b)
Nothing ->
      case DataBox -> TypeRep -> Maybe Follower
readCacheFollower (a -> DataBox
forall d. Data d => d -> DataBox
dataBox a
a) (b -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf b
b) of
        Just Follower
p | Bool -> Bool
not (Follower
p (t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
c)) -> Answer t b
forall b a. Answer b a
Miss
        Maybe Follower
_ -> Answer t b
forall b a. Answer b a
Follow

-------------------------------------------------------------------------------
-- Traversals
-------------------------------------------------------------------------------


biplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData :: (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData forall c. Typeable c => c -> Answer c a
o a -> f a
f = s -> f s
forall d. Data d => d -> f d
go2 where
  go :: Data d => d -> f d
  go :: d -> f d
go d
s = (forall d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> d -> f d
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl (\f (d -> b)
x d
y -> f (d -> b)
x f (d -> b) -> f d -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
go2 d
y) forall g. g -> f g
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
  go2 :: Data d => d -> f d
  go2 :: d -> f d
go2 d
s = case d -> Answer d a
forall c. Typeable c => c -> Answer c a
o d
s of
    Hit a
a  -> a -> f a
f a
a
    Answer d a
Follow -> d -> f d
forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> d -> f d
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
{-# INLINE biplateData #-}

uniplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData :: (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData forall c. Typeable c => c -> Answer c a
o a -> f a
f = s -> f s
forall d. Data d => d -> f d
go where
  go :: Data d => d -> f d
  go :: d -> f d
go d
s = (forall d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> d -> f d
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl (\f (d -> b)
x d
y -> f (d -> b)
x f (d -> b) -> f d -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
go2 d
y) forall g. g -> f g
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
  go2 :: Data d => d -> f d
  go2 :: d -> f d
go2 d
s = case d -> Answer d a
forall c. Typeable c => c -> Answer c a
o d
s of
    Hit a
a  -> a -> f a
f a
a
    Answer d a
Follow -> d -> f d
forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> d -> f d
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
{-# INLINE uniplateData #-}

-------------------------------------------------------------------------------
-- Follower
-------------------------------------------------------------------------------

part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part a -> Bool
p HashSet a
s = ((a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter a -> Bool
p HashSet a
s, (a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) HashSet a
s)
{-# INLINE part #-}

type Follower = TypeRep -> Bool

follower :: TypeRep -> TypeRep -> HitMap -> Follower
follower :: TypeRep -> TypeRep -> HitMap -> Follower
follower TypeRep
a TypeRep
b HitMap
m
  | HashSet TypeRep -> Bool
forall a. HashSet a -> Bool
S.null HashSet TypeRep
hit               = Bool -> Follower
forall a b. a -> b -> a
const Bool
False
  | HashSet TypeRep -> Bool
forall a. HashSet a -> Bool
S.null HashSet TypeRep
miss              = Bool -> Follower
forall a b. a -> b -> a
const Bool
True
  | HashSet TypeRep -> Int
forall a. HashSet a -> Int
S.size HashSet TypeRep
hit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< HashSet TypeRep -> Int
forall a. HashSet a -> Int
S.size HashSet TypeRep
miss = TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member (TypeRep -> HashSet TypeRep -> Bool) -> HashSet TypeRep -> Follower
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? HashSet TypeRep
hit
  | Bool
otherwise = \TypeRep
k -> Bool -> Bool
not (TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
k HashSet TypeRep
miss)
  where (HashSet TypeRep
hit, HashSet TypeRep
miss) = Follower -> HashSet TypeRep -> (HashSet TypeRep, HashSet TypeRep)
forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part (\TypeRep
x -> TypeRep -> HashSet TypeRep -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
b (HitMap
m HitMap -> TypeRep -> HashSet TypeRep
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x)) (TypeRep -> HashSet TypeRep -> HashSet TypeRep
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert TypeRep
a (HitMap
m HitMap -> TypeRep -> HashSet TypeRep
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
a))