{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
#if __GLASGOW_HASKELL__ >= 810
{-# OPTIONS_GHC -fbyte-code #-}
#endif
module Data.Data.Lens
(
template
, tinplate
, uniplate
, biplate
, upon
, upon'
, onceUpon
, onceUpon'
, 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
gtraverse :: (Applicative f, Data a) => (forall d. Data d => d -> f d) -> a -> f a
gtraverse :: forall (f :: * -> *) a.
(Applicative f, Data a) =>
(forall d. Data d => d -> f d) -> a -> f a
gtraverse forall d. Data d => d -> f d
f = 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
f d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE gtraverse #-}
tinplate :: (Data s, Typeable a) => Traversal' s a
tinplate :: forall s a. (Data s, Typeable a) => Traversal' s a
tinplate a -> f a
f = 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 (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 (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 :: 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 f (s -> r)
w s
s = f (s -> r)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case 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
s
Maybe (s :~: a)
Nothing -> forall s a. (Data s, Typeable a) => Traversal' s a
tinplate a -> f a
f s
s
{-# INLINE step #-}
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template = forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData (forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
answer :: Oracle a
answer = forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (forall a. HasCallStack => a
undefined :: s) (forall a. HasCallStack => a
undefined :: a)
{-# INLINE template #-}
uniplate :: Data a => Traversal' a a
uniplate :: forall a. Data a => Traversal' a a
uniplate = forall s a. (Data s, Typeable a) => Traversal' s a
template
{-# INLINE uniplate #-}
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate = forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData (forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
answer :: Oracle a
answer = forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (forall a. HasCallStack => a
undefined :: s) (forall a. HasCallStack => a
undefined :: a)
{-# INLINE biplate #-}
data FieldException a = FieldException !Int a
instance Show (FieldException a) where
showsPrec :: Int -> FieldException a -> ShowS
showsPrec Int
d (FieldException Int
i a
_) = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"<field " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i 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 :: 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
l s -> a
field s
s = case forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ s -> a
field forall a b. (a -> b) -> a -> b
$ s
s forall a b. a -> (a -> b) -> b
& 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 forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ \Int
i (a
a::a) -> forall a e. Exception e => e -> a
E.throw (forall a. Int -> a -> FieldException a
FieldException Int
i a
a) of
Right a
_ -> forall a. Maybe a
Nothing
Left SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Maybe (FieldException a)
Nothing -> forall a. Maybe a
Nothing
Just (FieldException Int
i a
a) -> forall a. a -> Maybe a
Just (Int
i, forall a b t. (b -> t) -> a -> Context a b t
Context (\a
a' -> forall s t a b. ASetter s t a b -> b -> s -> t
set (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 #-}
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 :: 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
field p a (f a)
f s
s = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
Maybe (Int, Context a a s)
Nothing -> 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 forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
Maybe (Int, Context a a s)
Nothing -> a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f (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
jforall a. a -> [a] -> [a]
:[Int]
is) (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf 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] (forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall s a. (Data s, Typeable a) => Traversal' s a
template Int
i) a -> s
k0 a
a0
{-# INLINE upon #-}
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' s -> a
field p a (f a)
f s
s = let
~([Int]
isn, a -> s
kn) = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
Maybe (Int, Context a a s)
Nothing -> (forall a. HasCallStack => String -> a
error String
"upon': no index, not a member", 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] (forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf 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 forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
Maybe (Int, Context a a s)
Nothing -> (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
jforall a. a -> [a] -> [a]
:[Int]
is) (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall a. Data a => Traversal' a a
uniplate Int
j) a -> s
k'
in a -> s
kn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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' #-}
onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedTraversal' Int s a
onceUpon :: forall s a.
(Data s, Typeable a) =>
(s -> a) -> IndexedTraversal' Int s a
onceUpon s -> a
field p a (f a)
f s
s = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
Maybe (Int, Context a a s)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
Just (Int
i, Context a -> s
k a
a) -> a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 #-}
onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedLens' Int s a
onceUpon' :: forall s a.
(Data s, Typeable a) =>
(s -> a) -> IndexedLens' Int s a
onceUpon' s -> a
field p a (f a)
f s
s = a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"upon': no index, not a member") (forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s)
{-# INLINE onceUpon' #-}
data DataBox = forall a. Data a => DataBox
{ DataBox -> TypeRep
dataBoxKey :: TypeRep
, ()
_dataBoxVal :: a
}
dataBox :: Data a => a -> DataBox
dataBox :: forall a. Data a => a -> DataBox
dataBox a
a = forall a. Data a => TypeRep -> a -> DataBox
DataBox (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep [a
a]) a
a
{-# INLINE dataBox #-}
sybChildren :: Data a => a -> [DataBox]
sybChildren :: forall a. Data a => a -> [DataBox]
sybChildren a
x
| DataType -> Bool
isAlgType DataType
dt = do
Constr
c <- DataType -> [Constr]
dataTypeConstrs DataType
dt
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> DataBox
dataBox (forall a. Data a => Constr -> a
fromConstr Constr
c forall a. a -> a -> a
`asTypeOf` a
x)
| Bool
otherwise = []
where dt :: DataType
dt = forall a. Data a => a -> DataType
dataTypeOf a
x
{-# INLINE sybChildren #-}
type HitMap = HashMap TypeRep (HashSet TypeRep)
emptyHitMap :: HitMap
emptyHitMap :: HitMap
emptyHitMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList
[ (TypeRep
tRational, forall a. Hashable a => a -> HashSet a
S.singleton TypeRep
tInteger)
, (TypeRep
tInteger, forall a. HashSet a
S.empty)
] where
tRational :: TypeRep
tRational = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (forall {k} (t :: k). Proxy t
X.Proxy :: X.Proxy Rational)
tInteger :: TypeRep
tInteger = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (forall {k} (t :: k). Proxy t
X.Proxy :: X.Proxy Integer )
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap DataBox
box HitMap
hit = forall a. Eq a => (a -> a) -> a -> a
fixEq HitMap -> HitMap
trans (DataBox -> HitMap
populate DataBox
box) 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 forall k v. HashMap k v
M.empty where
f :: DataBox -> HitMap -> HitMap
f (DataBox TypeRep
k a
v) HitMap
m
| forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
hit Bool -> Bool -> Bool
|| forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
m = HitMap
m
| [DataBox]
cs <- forall a. Data a => a -> [DataBox]
sybChildren a
v = [DataBox] -> HitMap -> HitMap
fs [DataBox]
cs forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert TypeRep
k (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ 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 = 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 forall a. Monoid a => a -> a -> a
`mappend` 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 = forall a. a -> Maybe a -> a
fromMaybe (HitMap
hit forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x) (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 :: forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f = a -> a
go where
go :: a -> a
go a
x | a
x 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 #-}
inlinePerformIO :: IO a -> a
inlinePerformIO :: forall a. 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 #-}
data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower)))
cache :: IORef Cache
cache :: IORef Cache
cache = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
emptyHitMap 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 = forall a. IO a -> a
inlinePerformIO forall a b. (a -> b) -> a -> b
$
forall a. IORef a -> IO a
readIORef IORef Cache
cache forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (Cache HitMap
hm HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m) -> case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
kb HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
ka of
Just Maybe Follower
a -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
a
Maybe (Maybe Follower)
Nothing -> forall e a. Exception e => IO a -> IO (Either e a)
E.try (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! DataBox -> HitMap -> HitMap
insertHitMap DataBox
b HitMap
hm) 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{} -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache 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' (forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
kb TypeRep
ka forall a. Maybe a
Nothing HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n), forall a. Maybe a
Nothing)
Right HitMap
hm' | Maybe Follower
fol <- forall a. a -> Maybe a
Just (TypeRep -> TypeRep -> HitMap -> Follower
follower TypeRep
kb TypeRep
ka HitMap
hm') -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache 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' (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 :: forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
x TypeRep
y a
v = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert TypeRep
y a
v) TypeRep
x (forall k v. Hashable k => k -> v -> HashMap k v
M.singleton TypeRep
y a
v)
{-# INLINE insert2 #-}
data Answer b a
= b ~ a => Hit a
| Follow
| Miss
newtype Oracle a = Oracle { forall a. 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 :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest a
a b
b = forall a. (forall t. Typeable t => t -> Answer t a) -> Oracle a
Oracle forall a b. (a -> b) -> a -> b
$ \(t
c :: c) ->
case 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 -> forall b a. (b ~ a) => a -> Answer b a
Hit t
c
Maybe (t :~: b)
Nothing ->
case DataBox -> TypeRep -> Maybe Follower
readCacheFollower (forall a. Data a => a -> DataBox
dataBox a
a) (forall a. Typeable a => a -> TypeRep
typeOf b
b) of
Just Follower
p | Bool -> Bool
not (Follower
p (forall a. Typeable a => a -> TypeRep
typeOf t
c)) -> forall b a. Answer b a
Miss
Maybe Follower
_ -> forall b a. Answer b a
Follow
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 (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
o a -> f a
f = forall d. Data d => d -> f d
go2 where
go :: Data d => d -> f d
go :: forall d. Data d => d -> f d
go = 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
go2 d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
go2 :: Data d => d -> f d
go2 :: forall d. Data d => d -> f d
go2 d
s = case 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 -> forall d. Data d => d -> f d
go d
s
Answer d a
Miss -> 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 (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
o a -> f a
f = forall d. Data d => d -> f d
go where
go :: Data d => d -> f d
go :: forall d. Data d => d -> f d
go = 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
go2 d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
go2 :: Data d => d -> f d
go2 :: forall d. Data d => d -> f d
go2 d
s = case 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 -> forall d. Data d => d -> f d
go d
s
Answer d a
Miss -> forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
{-# INLINE uniplateData #-}
part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part :: forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part a -> Bool
p HashSet a
s = (forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter a -> Bool
p HashSet a
s, forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter (Bool -> Bool
not 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
| forall a. HashSet a -> Bool
S.null HashSet TypeRep
hit = forall a b. a -> b -> a
const Bool
False
| forall a. HashSet a -> Bool
S.null HashSet TypeRep
miss = forall a b. a -> b -> a
const Bool
True
| forall a. HashSet a -> Int
S.size HashSet TypeRep
hit forall a. Ord a => a -> a -> Bool
< forall a. HashSet a -> Int
S.size HashSet TypeRep
miss = forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? HashSet TypeRep
hit
| Bool
otherwise = \TypeRep
k -> Bool -> Bool
not (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
k HashSet TypeRep
miss)
where (HashSet TypeRep
hit, HashSet TypeRep
miss) = forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part (\TypeRep
x -> forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
b (HitMap
m forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x)) (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert TypeRep
a (HitMap
m forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
a))