{-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Generics.Uniplate.Internal.Data where
import Data.Generics.Str
import Data.Generics.Uniplate.Internal.Utils
import Data.Data
import Data.Generics
import Data.Maybe
import Data.List
import Data.IORef
import Control.Exception
import Control.Monad
import System.Environment(getEnv)
import qualified Data.IntMap as IntMap; import Data.IntMap(IntMap)
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
type TypeSet = Set.HashSet TypeKey
type TypeMap = Map.HashMap TypeKey
type TypeKey = TypeRep
typeKey :: Typeable a => a -> TypeKey
typeKey :: forall a. Typeable a => a -> TypeKey
typeKey = forall a. Typeable a => a -> TypeKey
typeOf
! :: HashMap k a -> k -> a
(!) HashMap k a
mp k
k = forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"Could not find element") k
k HashMap k a
mp
map_findWithDefault :: a -> k -> HashMap k a -> a
map_findWithDefault a
d k
k HashMap k a
mp = forall a. a -> Maybe a -> a
fromMaybe a
d forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
k HashMap k a
mp
map_fromAscList :: [(TypeKey, v)] -> HashMap TypeKey v
map_fromAscList = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
map_keysSet :: HashMap TypeKey v -> TypeSet
map_keysSet = forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [k]
Map.keys
map_member :: k -> HashMap k a -> Bool
map_member k
x HashMap k a
xs = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
x HashMap k a
xs
set_partition :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
set_partition a -> Bool
f HashSet a
x = (forall a. (a -> Bool) -> HashSet a -> HashSet a
Set.filter a -> Bool
f HashSet a
x, forall a. (a -> Bool) -> HashSet a -> HashSet a
Set.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
f) HashSet a
x)
set_toAscList :: HashSet a -> [a]
set_toAscList = forall a. HashSet a -> [a]
Set.toList
set_unions :: [TypeSet] -> TypeSet
set_unions = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
Set.union forall a. HashSet a
Set.empty
{-# NOINLINE uniplateVerbose #-}
uniplateVerbose :: Int
uniplateVerbose :: Int
uniplateVerbose = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Read a => [Char] -> a
read ([Char] -> IO [Char]
getEnv [Char]
"UNIPLATE_VERBOSE") forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
data Answer a = Hit {forall a. Answer a -> a
fromHit :: a}
| Follow
| Miss
data Oracle to = Oracle {forall to. Oracle to -> forall on. Typeable on => on -> Answer to
fromOracle :: forall on . Typeable on => on -> Answer to}
{-# INLINE hitTest #-}
hitTest :: (Data from, Data to) => from -> to -> Oracle to
hitTest :: forall from to. (Data from, Data to) => from -> to -> Oracle to
hitTest from
from to
to =
let kto :: TypeKey
kto = forall a. Typeable a => a -> TypeKey
typeKey to
to
in case DataBox -> TypeKey -> Maybe Follower
readCacheFollower (forall a. Data a => a -> DataBox
dataBox from
from) TypeKey
kto of
Maybe Follower
Nothing -> forall to. (forall on. Typeable on => on -> Answer to) -> Oracle to
Oracle forall a b. (a -> b) -> a -> b
$ \on
on -> if forall a. Typeable a => a -> TypeKey
typeKey on
on forall a. Eq a => a -> a -> Bool
== TypeKey
kto then forall a. a -> Answer a
Hit forall a b. (a -> b) -> a -> b
$ forall a b. a -> b
unsafeCoerce on
on else forall a. Answer a
Follow
Just Follower
test -> forall to. (forall on. Typeable on => on -> Answer to) -> Oracle to
Oracle forall a b. (a -> b) -> a -> b
$ \on
on -> let kon :: TypeKey
kon = forall a. Typeable a => a -> TypeKey
typeKey on
on in
if TypeKey
kon forall a. Eq a => a -> a -> Bool
== TypeKey
kto then forall a. a -> Answer a
Hit forall a b. (a -> b) -> a -> b
$ forall a b. a -> b
unsafeCoerce on
on
else if Follower
test TypeKey
kon then forall a. Answer a
Follow
else forall a. Answer a
Miss
data Cache = Cache HitMap (TypeMap2 (Maybe Follower))
{-# NOINLINE cache #-}
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
$ HashMap TypeKey TypeSet -> TypeMap2 (Maybe Follower) -> Cache
Cache HashMap TypeKey TypeSet
emptyHitMap forall k v. HashMap k v
Map.empty
readCacheFollower :: DataBox -> TypeKey -> Maybe Follower
readCacheFollower :: DataBox -> TypeKey -> Maybe Follower
readCacheFollower from :: DataBox
from@(DataBox TypeKey
kfrom a
vfrom) TypeKey
kto = forall a. IO a -> a
inlinePerformIO forall a b. (a -> b) -> a -> b
$ do
Cache HashMap TypeKey TypeSet
hit TypeMap2 (Maybe Follower)
follow <- forall a. IORef a -> IO a
readIORef IORef Cache
cache
case forall a. TypeKey -> TypeKey -> TypeMap2 a -> Maybe a
lookup2 TypeKey
kfrom TypeKey
kto TypeMap2 (Maybe Follower)
follow of
Just Maybe Follower
ans -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
ans
Maybe (Maybe Follower)
Nothing -> do
Either SomeException (HashMap TypeKey TypeSet)
res <- forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
insertHitMap DataBox
from HashMap TypeKey TypeSet
hit)
(HashMap TypeKey TypeSet
hit,Maybe Follower
fol) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either SomeException (HashMap TypeKey TypeSet)
res of
Left SomeException
_ -> (HashMap TypeKey TypeSet
hit, forall a. Maybe a
Nothing)
Right HashMap TypeKey TypeSet
hit -> (HashMap TypeKey TypeSet
hit, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TypeKey -> TypeKey -> HashMap TypeKey TypeSet -> Follower
follower TypeKey
kfrom TypeKey
kto HashMap TypeKey TypeSet
hit)
let msg :: [Char]
msg =
[Char]
"# Uniplate lookup on (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeKey
typeOf a
vfrom) forall a. [a] -> [a] -> [a]
++ [Char]
"), from (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeKey
kfrom forall a. [a] -> [a] -> [a]
++ [Char]
"), to (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeKey
kto forall a. [a] -> [a] -> [a]
++ [Char]
"): " forall a. [a] -> [a] -> [a]
++
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException
msg::SomeException) -> [Char]
"FAILURE (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
msg forall a. [a] -> [a] -> [a]
++ [Char]
")") (forall a b. a -> b -> a
const [Char]
"Success") Either SomeException (HashMap TypeKey TypeSet)
res
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
uniplateVerbose forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (forall a b. a -> b -> a
const Int
0) Maybe Follower
fol forall a. Ord a => a -> a -> Bool
>= Int
2) forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
msg
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
uniplateVerbose forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Follower
fol) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
msg
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache forall a b. (a -> b) -> a -> b
$ \(Cache HashMap TypeKey TypeSet
_ TypeMap2 (Maybe Follower)
follow) -> (HashMap TypeKey TypeSet -> TypeMap2 (Maybe Follower) -> Cache
Cache HashMap TypeKey TypeSet
hit (forall a. TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a
insert2 TypeKey
kfrom TypeKey
kto Maybe Follower
fol TypeMap2 (Maybe Follower)
follow), ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
fol
readCacheHitMap :: DataBox -> Maybe HitMap
readCacheHitMap :: DataBox -> Maybe (HashMap TypeKey TypeSet)
readCacheHitMap from :: DataBox
from@(DataBox TypeKey
kfrom a
vfrom) = forall a. IO a -> a
inlinePerformIO forall a b. (a -> b) -> a -> b
$ do
Cache HashMap TypeKey TypeSet
hit TypeMap2 (Maybe Follower)
_ <- forall a. IORef a -> IO a
readIORef IORef Cache
cache
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeKey
kfrom HashMap TypeKey TypeSet
hit of
Just TypeSet
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HashMap TypeKey TypeSet
hit
Maybe TypeSet
Nothing -> do
Maybe (HashMap TypeKey TypeSet)
res <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
insertHitMap DataBox
from HashMap TypeKey TypeSet
hit) (\(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
case Maybe (HashMap TypeKey TypeSet)
res of
Maybe (HashMap TypeKey TypeSet)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just HashMap TypeKey TypeSet
hit -> do
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache forall a b. (a -> b) -> a -> b
$ \(Cache HashMap TypeKey TypeSet
_ TypeMap2 (Maybe Follower)
follow) -> (HashMap TypeKey TypeSet -> TypeMap2 (Maybe Follower) -> Cache
Cache HashMap TypeKey TypeSet
hit TypeMap2 (Maybe Follower)
follow, ())
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HashMap TypeKey TypeSet
hit
type TypeMap2 a = TypeMap (TypeMap a)
lookup2 :: TypeKey -> TypeKey -> TypeMap2 a -> Maybe a
lookup2 :: forall a. TypeKey -> TypeKey -> TypeMap2 a -> Maybe a
lookup2 TypeKey
x TypeKey
y TypeMap2 a
mp = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeKey
x TypeMap2 a
mp 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
Map.lookup TypeKey
y
insert2 :: TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a
insert2 :: forall a. TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a
insert2 TypeKey
x TypeKey
y a
v TypeMap2 a
mp = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.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
Map.insert TypeKey
y a
v) TypeKey
x (forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton TypeKey
y a
v) TypeMap2 a
mp
type IntMap2 a = IntMap (IntMap a)
intLookup2 :: Int -> Int -> IntMap2 a -> Maybe a
intLookup2 :: forall a. Int -> Int -> IntMap2 a -> Maybe a
intLookup2 Int
x Int
y IntMap2 a
mp = forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x IntMap2 a
mp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
y
intInsert2 :: Int -> Int -> a -> IntMap2 a -> IntMap2 a
intInsert2 :: forall a. Int -> Int -> a -> IntMap2 a -> IntMap2 a
intInsert2 Int
x Int
y a
v IntMap2 a
mp = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
y a
v) Int
x (forall a. Int -> a -> IntMap a
IntMap.singleton Int
y a
v) IntMap2 a
mp
type Follower = TypeKey -> Bool
follower :: TypeKey -> TypeKey -> HitMap -> Follower
follower :: TypeKey -> TypeKey -> HashMap TypeKey TypeSet -> Follower
follower TypeKey
from TypeKey
to HashMap TypeKey TypeSet
mp
| forall a. HashSet a -> Bool
Set.null TypeSet
hit = forall a b. a -> b -> a
const Bool
False
| forall a. HashSet a -> Bool
Set.null TypeSet
miss = forall a b. a -> b -> a
const Bool
True
| forall a. HashSet a -> Int
Set.size TypeSet
hit forall a. Ord a => a -> a -> Bool
< forall a. HashSet a -> Int
Set.size TypeSet
miss = \TypeKey
k -> TypeKey
k forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeSet
hit
| Bool
otherwise = \TypeKey
k -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ TypeKey
k forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeSet
miss
where
(TypeSet
hit,TypeSet
miss) = forall {a}. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
set_partition (\TypeKey
x -> TypeKey
to forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeKey -> TypeSet
grab TypeKey
x) (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert TypeKey
from forall a b. (a -> b) -> a -> b
$ TypeKey -> TypeSet
grab TypeKey
from)
grab :: TypeKey -> TypeSet
grab TypeKey
x = forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"couldn't grab in follower") TypeKey
x HashMap TypeKey TypeSet
mp
data DataBox = forall a . (Data a) => DataBox {DataBox -> TypeKey
dataBoxKey :: TypeKey, ()
dataBoxVal :: a}
dataBox :: Data a => a -> DataBox
dataBox :: forall a. Data a => a -> DataBox
dataBox a
x = forall a. Data a => TypeKey -> a -> DataBox
DataBox (forall a. Typeable a => a -> TypeKey
typeKey a
x) a
x
sybChildren :: Data a => a -> [DataBox]
sybChildren :: forall a. Data a => a -> [DataBox]
sybChildren a
x
| DataType -> Bool
isAlgType DataType
dtyp = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constr -> [DataBox]
f [Constr]
ctrs
| DataType -> Bool
isNorepType DataType
dtyp = []
| Bool
otherwise = []
where
f :: Constr -> [DataBox]
f Constr
ctr = forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> DataBox
dataBox (forall a. a -> a -> a
asTypeOf (forall a. Data a => Constr -> a
fromConstr Constr
ctr) a
x)
ctrs :: [Constr]
ctrs = DataType -> [Constr]
dataTypeConstrs DataType
dtyp
dtyp :: DataType
dtyp = forall a. Data a => a -> DataType
dataTypeOf a
x
type HitMap = TypeMap TypeSet
emptyHitMap :: HitMap
emptyHitMap :: HashMap TypeKey TypeSet
emptyHitMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
[(TypeKey
tRational, forall a. Hashable a => a -> HashSet a
Set.singleton TypeKey
tInteger)
,(TypeKey
tInteger, forall a. HashSet a
Set.empty)]
where tRational :: TypeKey
tRational = forall a. Typeable a => a -> TypeKey
typeKey (forall a. HasCallStack => a
undefined :: Rational)
tInteger :: TypeKey
tInteger = forall a. Typeable a => a -> TypeKey
typeKey (Integer
0 :: Integer)
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap :: DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
insertHitMap DataBox
box HashMap TypeKey TypeSet
hit = forall a. Eq a => (a -> a) -> a -> a
fixEq HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
trans (DataBox -> HashMap TypeKey TypeSet
populate DataBox
box) forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` HashMap TypeKey TypeSet
hit
where
populate :: DataBox -> HitMap
populate :: DataBox -> HashMap TypeKey TypeSet
populate DataBox
x = DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
f DataBox
x forall k v. HashMap k v
Map.empty
where
f :: DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
f (DataBox TypeKey
key a
val) HashMap TypeKey TypeSet
mp
| TypeKey
key forall {k} {a}. Hashable k => k -> HashMap k a -> Bool
`map_member` HashMap TypeKey TypeSet
hit Bool -> Bool -> Bool
|| TypeKey
key forall {k} {a}. Hashable k => k -> HashMap k a -> Bool
`map_member` HashMap TypeKey TypeSet
mp = HashMap TypeKey TypeSet
mp
| Bool
otherwise = [DataBox] -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
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
Map.insert TypeKey
key (forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DataBox -> TypeKey
dataBoxKey [DataBox]
cs) HashMap TypeKey TypeSet
mp
where cs :: [DataBox]
cs = forall a. Data a => a -> [DataBox]
sybChildren a
val
fs :: [DataBox] -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
fs [] HashMap TypeKey TypeSet
mp = HashMap TypeKey TypeSet
mp
fs (DataBox
x:[DataBox]
xs) HashMap TypeKey TypeSet
mp = [DataBox] -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
fs [DataBox]
xs (DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
f DataBox
x HashMap TypeKey TypeSet
mp)
trans :: HitMap -> HitMap
trans :: HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
trans HashMap TypeKey TypeSet
mp = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map TypeSet -> TypeSet
f HashMap TypeKey TypeSet
mp
where
f :: TypeSet -> TypeSet
f TypeSet
x = [TypeSet] -> TypeSet
set_unions forall a b. (a -> b) -> a -> b
$ TypeSet
x forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map TypeKey -> TypeSet
g (forall a. HashSet a -> [a]
Set.toList TypeSet
x)
g :: TypeKey -> TypeSet
g TypeKey
x = forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault (HashMap TypeKey TypeSet
hit forall {k} {a}. Hashable k => HashMap k a -> k -> a
! TypeKey
x) TypeKey
x HashMap TypeKey TypeSet
mp
fixEq :: Eq a => (a -> a) -> a -> a
fixEq :: forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f a
x = if a
x forall a. Eq a => a -> a -> Bool
== a
x2 then a
x2 else forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f a
x2
where x2 :: a
x2 = a -> a
f a
x
newtype C x a = C {forall x a. C x a -> CC x a
fromC :: CC x a}
type CC x a = (Str x, Str x -> a)
biplateData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
biplateData :: forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
biplateData forall a. Typeable a => a -> Answer with
oracle on
x = case forall a. Typeable a => a -> Answer with
oracle on
x of
Hit with
y -> (forall a. a -> Str a
One with
y, \(One with
x) -> forall a b. a -> b
unsafeCoerce with
x)
Answer with
Follow -> forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
uniplateData forall a. Typeable a => a -> Answer with
oracle on
x
Answer with
Miss -> (forall a. Str a
Zero, \Str with
_ -> on
x)
uniplateData :: forall on with . (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
uniplateData :: forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
uniplateData forall a. Typeable a => a -> Answer with
oracle on
item = forall x a. C x a -> CC x a
fromC forall a b. (a -> b) -> a -> b
$ 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 a b. Data a => C with (a -> b) -> a -> C with b
combine forall g. g -> C with g
create on
item
where
combine :: Data a => C with (a -> b) -> a -> C with b
combine :: forall a b. Data a => C with (a -> b) -> a -> C with b
combine (C (Str with
c,Str with -> a -> b
g)) a
x = case forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
biplateData forall a. Typeable a => a -> Answer with
oracle a
x of
(Str with
c2, Str with -> a
g2) -> forall x a. CC x a -> C x a
C (forall a. Str a -> Str a -> Str a
Two Str with
c Str with
c2, \(Two Str with
c' Str with
c2') -> Str with -> a -> b
g Str with
c' (Str with -> a
g2 Str with
c2'))
create :: g -> C with g
create :: forall g. g -> C with g
create g
x = forall x a. CC x a -> C x a
C (forall a. Str a
Zero, \Str with
_ -> g
x)
descendData :: Data on => (forall a . Typeable a => a -> Answer on) -> (on -> on) -> on -> on
descendData :: forall on.
Data on =>
(forall a. Typeable a => a -> Answer on) -> (on -> on) -> on -> on
descendData forall a. Typeable a => a -> Answer on
oracle on -> on
op = forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> with) -> on -> on
descendBiData forall a. Typeable a => a -> Answer on
oracle on -> on
op)
descendBiData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> (with -> with) -> on -> on
descendBiData :: forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> with) -> on -> on
descendBiData forall a. Typeable a => a -> Answer with
oracle with -> with
op on
x = case forall a. Typeable a => a -> Answer with
oracle on
x of
Hit with
y -> forall a b. a -> b
unsafeCoerce forall a b. (a -> b) -> a -> b
$ with -> with
op with
y
Answer with
Follow -> forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> with) -> on -> on
descendBiData forall a. Typeable a => a -> Answer with
oracle with -> with
op) on
x
Answer with
Miss -> on
x
descendDataM :: (Data on, Applicative m) => (forall a . Typeable a => a -> Answer on) -> (on -> m on) -> on -> m on
descendDataM :: forall on (m :: * -> *).
(Data on, Applicative m) =>
(forall a. Typeable a => a -> Answer on)
-> (on -> m on) -> on -> m on
descendDataM forall a. Typeable a => a -> Answer on
oracle on -> m on
op = forall (m :: * -> *) a.
(Data a, Applicative m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapA (forall on with (m :: * -> *).
(Data on, Data with, Applicative m) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> on -> m on
descendBiDataM forall a. Typeable a => a -> Answer on
oracle on -> m on
op)
descendBiDataM :: (Data on, Data with, Applicative m) => (forall a . Typeable a => a -> Answer with) -> (with -> m with) -> on -> m on
descendBiDataM :: forall on with (m :: * -> *).
(Data on, Data with, Applicative m) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> on -> m on
descendBiDataM forall a. Typeable a => a -> Answer with
oracle with -> m with
op on
x = case forall a. Typeable a => a -> Answer with
oracle on
x of
Hit with
y -> forall a b. a -> b
unsafeCoerce forall a b. (a -> b) -> a -> b
$ with -> m with
op with
y
Answer with
Follow -> forall (m :: * -> *) a.
(Data a, Applicative m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapA (forall on with (m :: * -> *).
(Data on, Data with, Applicative m) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> on -> m on
descendBiDataM forall a. Typeable a => a -> Answer with
oracle with -> m with
op) on
x
Answer with
Miss -> forall (f :: * -> *) a. Applicative f => a -> f a
pure on
x
gmapA :: forall m a. (Data a, Applicative m) => (forall d. Data d => d -> m d) -> a -> m a
gmapA :: forall (m :: * -> *) a.
(Data a, Applicative m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapA forall d. Data d => d -> m 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 forall d b. Data d => m (d -> b) -> d -> m b
k forall (f :: * -> *) a. Applicative f => a -> f a
pure
where k :: Data d => m (d -> b) -> d -> m b
k :: forall d b. Data d => m (d -> b) -> d -> m b
k m (d -> b)
c d
x = m (d -> b)
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> m d
f d
x
data Transformer = forall a . Data a => Transformer TypeKey (a -> a)
transformer :: Data a => (a -> a) -> Transformer
transformer :: forall a. Data a => (a -> a) -> Transformer
transformer = forall a. Data a => (a -> a) -> Transformer
transformer_
transformer_ :: forall a . Data a => (a -> a) -> Transformer
transformer_ :: forall a. Data a => (a -> a) -> Transformer
transformer_ = forall a. Data a => TypeKey -> (a -> a) -> Transformer
Transformer (forall a. Typeable a => a -> TypeKey
typeKey (forall a. HasCallStack => a
undefined :: a))
transformBis :: forall a . Data a => [[Transformer]] -> a -> a
transformBis :: forall a. Data a => [[Transformer]] -> a -> a
transformBis = forall a. Data a => [[Transformer]] -> a -> a
transformBis_
transformBis_ :: forall a . Data a => [[Transformer]] -> a -> a
transformBis_ :: forall a. Data a => [[Transformer]] -> a -> a
transformBis_ [[Transformer]]
ts | forall a. Maybe a -> Bool
isJust Maybe (HashMap TypeKey TypeSet)
hitBoxM = forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op (Int -> Int -> TypeMap (Maybe Transformer)
sliceMe Int
1 Int
n)
where
on :: DataBox
on = forall a. Data a => a -> DataBox
dataBox (forall a. HasCallStack => a
undefined :: a)
hitBoxM :: Maybe (HashMap TypeKey TypeSet)
hitBoxM = DataBox -> Maybe (HashMap TypeKey TypeSet)
readCacheHitMap DataBox
on
hitBox :: HashMap TypeKey TypeSet
hitBox = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (HashMap TypeKey TypeSet)
hitBoxM
univ :: [TypeKey]
univ = forall a. HashSet a -> [a]
set_toAscList forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert (DataBox -> TypeKey
dataBoxKey DataBox
on) forall a b. (a -> b) -> a -> b
$ HashMap TypeKey TypeSet
hitBox forall {k} {a}. Hashable k => HashMap k a -> k -> a
! DataBox -> TypeKey
dataBoxKey DataBox
on
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Transformer]]
ts
sliceMe :: Int -> Int -> TypeMap (Maybe Transformer)
sliceMe Int
i Int
j = forall a. a -> Maybe a -> a
fromMaybe forall k v. HashMap k v
Map.empty forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> IntMap2 a -> Maybe a
intLookup2 Int
i Int
j IntMap2 (TypeMap (Maybe Transformer))
slices
slices :: IntMap2 (TypeMap (Maybe Transformer))
slices :: IntMap2 (TypeMap (Maybe Transformer))
slices = forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList
[ (Int
i, forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList [(Int
j, Int -> Int -> [[Transformer]] -> TypeMap (Maybe Transformer)
slice Int
i Int
j [[Transformer]]
ts) | (Int
j,[[Transformer]]
ts) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i..Int
n] (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
inits [[Transformer]]
ts)])
| (Int
i,[[Transformer]]
ts) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
n] (forall a. [a] -> [[a]]
tails forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [[Transformer]]
ts)]
slice :: Int -> Int -> [[Transformer]] -> TypeMap (Maybe Transformer)
slice :: Int -> Int -> [[Transformer]] -> TypeMap (Maybe Transformer)
slice Int
from Int
to [[Transformer]]
tts = TypeMap (Maybe Transformer)
self
where
self :: TypeMap (Maybe Transformer)
self = TypeMap (Maybe Transformer)
-> [(Int, [Transformer])] -> TypeMap (Maybe Transformer)
f forall k v. HashMap k v
Map.empty (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
from..] [[Transformer]]
tts)
f :: TypeMap (Maybe Transformer)
-> [(Int, [Transformer])] -> TypeMap (Maybe Transformer)
f TypeMap (Maybe Transformer)
a ((Int
i,[Transformer TypeKey
tk a -> a
tr]):[(Int, [Transformer])]
ts)
| TypeKey
tk forall {k} {a}. Hashable k => k -> HashMap k a -> Bool
`map_member` TypeMap (Maybe Transformer)
a = TypeMap (Maybe Transformer)
-> [(Int, [Transformer])] -> TypeMap (Maybe Transformer)
f TypeMap (Maybe Transformer)
a [(Int, [Transformer])]
ts
| Bool
otherwise = TypeMap (Maybe Transformer)
-> [(Int, [Transformer])] -> TypeMap (Maybe Transformer)
f (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert TypeKey
tk Maybe Transformer
t TypeMap (Maybe Transformer)
a) [(Int, [Transformer])]
ts
where
t :: Maybe Transformer
t = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Data a => TypeKey -> (a -> a) -> Transformer
Transformer TypeKey
tk forall a b. (a -> b) -> a -> b
$ forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op (Int -> Int -> TypeMap (Maybe Transformer)
sliceMe (Int
iforall a. Num a => a -> a -> a
+Int
1) Int
to) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op forall a b. (a -> b) -> a -> b
$ Int -> Int -> TypeMap (Maybe Transformer)
sliceMe Int
from Int
i)
f TypeMap (Maybe Transformer)
a [] = TypeMap (Maybe Transformer)
a forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` forall {v}. [(TypeKey, v)] -> HashMap TypeKey v
map_fromAscList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. TypeSet -> TypeKey -> Maybe (TypeKey, Maybe a)
g forall a b. (a -> b) -> a -> b
$ forall {v}. HashMap TypeKey v -> TypeSet
map_keysSet TypeMap (Maybe Transformer)
a) [TypeKey]
univ)
g :: TypeSet -> TypeKey -> Maybe (TypeKey, Maybe a)
g TypeSet
a TypeKey
t = if Bool
b then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (TypeKey
t, forall a. Maybe a
Nothing)
where b :: Bool
b = forall a. HashSet a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ TypeSet
a forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`Set.intersection` (HashMap TypeKey TypeSet
hitBox forall {k} {a}. Hashable k => HashMap k a -> k -> a
! TypeKey
t)
op :: forall b . Data b => TypeMap (Maybe Transformer) -> b -> b
op :: forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op TypeMap (Maybe Transformer)
slice = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (forall a. Typeable a => a -> TypeKey
typeKey (forall a. HasCallStack => a
undefined :: b)) TypeMap (Maybe Transformer)
slice of
Maybe (Maybe Transformer)
Nothing -> forall a. a -> a
id
Just Maybe Transformer
Nothing -> forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op TypeMap (Maybe Transformer)
slice)
Just (Just (Transformer TypeKey
_ a -> a
t)) -> forall a b. a -> b
unsafeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b
unsafeCoerce
transformBis_ [] = forall a. a -> a
id
transformBis_ ([]:[[Transformer]]
xs) = forall a. Data a => [[Transformer]] -> a -> a
transformBis_ [[Transformer]]
xs
transformBis_ ((Transformer TypeKey
_ a -> a
t:[Transformer]
x):[[Transformer]]
xs) = (forall b. Data b => b -> b) -> forall b. Data b => b -> b
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT a -> a
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => [[Transformer]] -> a -> a
transformBis_ ([Transformer]
xforall a. a -> [a] -> [a]
:[[Transformer]]
xs)