{-# 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 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 #-}
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 #-}
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 #-}
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 :: 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 #-}
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 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 #-}
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 #-}
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' #-}
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 #-}
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 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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
data Answer b a
= b ~ a => Hit a
| Follow
| Miss
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
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 = (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
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 = (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
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 #-}
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))