{-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- |
    Internal module, do not import or use.
-}

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)

---------------------------------------------------------------------
-- GHC 7.2 and above (using fingerprint)

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 = a -> TypeKey
forall a. Typeable a => a -> TypeKey
typeOf

! :: HashMap k a -> k -> a
(!) HashMap k a
mp k
k = a -> k -> HashMap k a -> a
forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault ([Char] -> a
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 = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
d (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
k HashMap k a
mp -- in 0.2.3.0 lookupDefault is strict in the default :(
map_fromAscList :: [(TypeKey, v)] -> HashMap TypeKey v
map_fromAscList = [(TypeKey, v)] -> HashMap TypeKey v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
map_keysSet :: HashMap TypeKey v -> TypeSet
map_keysSet = [TypeKey] -> TypeSet
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([TypeKey] -> TypeSet)
-> (HashMap TypeKey v -> [TypeKey]) -> HashMap TypeKey v -> TypeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap TypeKey v -> [TypeKey]
forall k v. HashMap k v -> [k]
Map.keys
map_member :: k -> HashMap k a -> Bool
map_member k
x HashMap k a
xs = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ k -> HashMap k a -> Maybe a
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 = ((a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
Set.filter a -> Bool
f HashSet a
x, (a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
f) HashSet a
x)
set_toAscList :: HashSet a -> [a]
set_toAscList = HashSet a -> [a]
forall a. HashSet a -> [a]
Set.toList
set_unions :: [TypeSet] -> TypeSet
set_unions = (TypeSet -> TypeSet -> TypeSet) -> TypeSet -> [TypeSet] -> TypeSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeSet -> TypeSet -> TypeSet
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
Set.union TypeSet
forall a. HashSet a
Set.empty


{-# NOINLINE uniplateVerbose #-}
uniplateVerbose :: Int -- -1 = error if failed, 0 = quiet, 1 = print errors only, 2 = print everything
uniplateVerbose :: Int
uniplateVerbose = IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
    ([Char] -> Int) -> IO [Char] -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> IO [Char]
getEnv [Char]
"UNIPLATE_VERBOSE") IO Int -> (SomeException -> IO Int) -> IO Int
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(SomeException
_ :: SomeException) -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0


---------------------------------------------------------------------
-- HIT TEST


data Answer a = Hit {forall a. Answer a -> a
fromHit :: a} -- you just hit the element you were after (here is a cast)
              | Follow -- go forward, you will find something
              | Miss -- you failed to sink my battleship!

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 = to -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey to
to
    in case DataBox -> TypeKey -> Maybe Follower
readCacheFollower (from -> DataBox
forall a. Data a => a -> DataBox
dataBox from
from) TypeKey
kto of
           Maybe Follower
Nothing -> (forall on. Typeable on => on -> Answer to) -> Oracle to
forall to. (forall on. Typeable on => on -> Answer to) -> Oracle to
Oracle ((forall on. Typeable on => on -> Answer to) -> Oracle to)
-> (forall on. Typeable on => on -> Answer to) -> Oracle to
forall a b. (a -> b) -> a -> b
$ \on
on -> if on -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey on
on TypeKey -> Follower
forall a. Eq a => a -> a -> Bool
== TypeKey
kto then to -> Answer to
forall a. a -> Answer a
Hit (to -> Answer to) -> to -> Answer to
forall a b. (a -> b) -> a -> b
$ on -> to
forall a b. a -> b
unsafeCoerce on
on else Answer to
forall a. Answer a
Follow
           Just Follower
test -> (forall on. Typeable on => on -> Answer to) -> Oracle to
forall to. (forall on. Typeable on => on -> Answer to) -> Oracle to
Oracle ((forall on. Typeable on => on -> Answer to) -> Oracle to)
-> (forall on. Typeable on => on -> Answer to) -> Oracle to
forall a b. (a -> b) -> a -> b
$ \on
on -> let kon :: TypeKey
kon = on -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey on
on in
                   if TypeKey
kon TypeKey -> Follower
forall a. Eq a => a -> a -> Bool
== TypeKey
kto then to -> Answer to
forall a. a -> Answer a
Hit (to -> Answer to) -> to -> Answer to
forall a b. (a -> b) -> a -> b
$ on -> to
forall a b. a -> b
unsafeCoerce on
on
                   else if Follower
test TypeKey
kon then Answer to
forall a. Answer a
Follow
                   else Answer to
forall a. Answer a
Miss



---------------------------------------------------------------------
-- CACHE
-- Store and compute the Follower and HitMap

data Cache = Cache HitMap (TypeMap2 (Maybe Follower))

-- Indexed by the @from@ type, then the @to@ type
-- Nothing means that we can't perform the trick on the set
{-# NOINLINE cache #-}
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
$ HashMap TypeKey TypeSet -> TypeMap2 (Maybe Follower) -> Cache
Cache HashMap TypeKey TypeSet
emptyHitMap TypeMap2 (Maybe Follower)
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 = 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
$ do
    Cache HashMap TypeKey TypeSet
hit TypeMap2 (Maybe Follower)
follow <- IORef Cache -> IO Cache
forall a. IORef a -> IO a
readIORef IORef Cache
cache
    case TypeKey
-> TypeKey -> TypeMap2 (Maybe Follower) -> Maybe (Maybe Follower)
forall a. TypeKey -> TypeKey -> TypeMap2 a -> Maybe a
lookup2 TypeKey
kfrom TypeKey
kto TypeMap2 (Maybe Follower)
follow of
        Just Maybe Follower
ans -> Maybe Follower -> IO (Maybe Follower)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
ans
        Maybe (Maybe Follower)
Nothing -> do
            Either SomeException (HashMap TypeKey TypeSet)
res <- IO (HashMap TypeKey TypeSet)
-> IO (Either SomeException (HashMap TypeKey TypeSet))
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (HashMap TypeKey TypeSet -> IO (HashMap TypeKey TypeSet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap TypeKey TypeSet -> IO (HashMap TypeKey TypeSet))
-> HashMap TypeKey TypeSet -> IO (HashMap TypeKey TypeSet)
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) <- (HashMap TypeKey TypeSet, Maybe Follower)
-> IO (HashMap TypeKey TypeSet, Maybe Follower)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HashMap TypeKey TypeSet, Maybe Follower)
 -> IO (HashMap TypeKey TypeSet, Maybe Follower))
-> (HashMap TypeKey TypeSet, Maybe Follower)
-> IO (HashMap TypeKey TypeSet, Maybe Follower)
forall a b. (a -> b) -> a -> b
$ case Either SomeException (HashMap TypeKey TypeSet)
res of
                Left SomeException
_ -> (HashMap TypeKey TypeSet
hit, Maybe Follower
forall a. Maybe a
Nothing)
                Right HashMap TypeKey TypeSet
hit -> (HashMap TypeKey TypeSet
hit, Follower -> Maybe Follower
forall a. a -> Maybe a
Just (Follower -> Maybe Follower) -> Follower -> Maybe Follower
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 (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeKey -> [Char]
forall a. Show a => a -> [Char]
show (a -> TypeKey
forall a. Typeable a => a -> TypeKey
typeOf a
vfrom) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"), from (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeKey -> [Char]
forall a. Show a => a -> [Char]
show TypeKey
kfrom [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"), to (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeKey -> [Char]
forall a. Show a => a -> [Char]
show TypeKey
kto [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    (SomeException -> [Char])
-> (HashMap TypeKey TypeSet -> [Char])
-> Either SomeException (HashMap TypeKey TypeSet)
-> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException
msg::SomeException) -> [Char]
"FAILURE (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")") ([Char] -> HashMap TypeKey TypeSet -> [Char]
forall a b. a -> b -> a
const [Char]
"Success") Either SomeException (HashMap TypeKey TypeSet)
res

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
uniplateVerbose Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (Follower -> Int) -> Maybe Follower -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (Int -> Follower -> Int
forall a b. a -> b -> a
const Int
0) Maybe Follower
fol Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
msg
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
uniplateVerbose Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
&& Maybe Follower -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Follower
fol) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
msg

            IORef Cache -> (Cache -> (Cache, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache ((Cache -> (Cache, ())) -> IO ())
-> (Cache -> (Cache, ())) -> IO ()
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 (TypeKey
-> TypeKey
-> Maybe Follower
-> TypeMap2 (Maybe Follower)
-> TypeMap2 (Maybe Follower)
forall a. TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a
insert2 TypeKey
kfrom TypeKey
kto Maybe Follower
fol TypeMap2 (Maybe Follower)
follow), ())
            Maybe Follower -> IO (Maybe Follower)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
fol


-- from which values, what can you reach
readCacheHitMap :: DataBox -> Maybe HitMap
readCacheHitMap :: DataBox -> Maybe (HashMap TypeKey TypeSet)
readCacheHitMap from :: DataBox
from@(DataBox TypeKey
kfrom a
vfrom) = IO (Maybe (HashMap TypeKey TypeSet))
-> Maybe (HashMap TypeKey TypeSet)
forall a. IO a -> a
inlinePerformIO (IO (Maybe (HashMap TypeKey TypeSet))
 -> Maybe (HashMap TypeKey TypeSet))
-> IO (Maybe (HashMap TypeKey TypeSet))
-> Maybe (HashMap TypeKey TypeSet)
forall a b. (a -> b) -> a -> b
$ do
    Cache HashMap TypeKey TypeSet
hit TypeMap2 (Maybe Follower)
_ <- IORef Cache -> IO Cache
forall a. IORef a -> IO a
readIORef IORef Cache
cache
    case TypeKey -> HashMap TypeKey TypeSet -> Maybe TypeSet
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeKey
kfrom HashMap TypeKey TypeSet
hit of
        Just TypeSet
_ -> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (HashMap TypeKey TypeSet)
 -> IO (Maybe (HashMap TypeKey TypeSet)))
-> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a b. (a -> b) -> a -> b
$ HashMap TypeKey TypeSet -> Maybe (HashMap TypeKey TypeSet)
forall a. a -> Maybe a
Just HashMap TypeKey TypeSet
hit
        Maybe TypeSet
Nothing -> do
            Maybe (HashMap TypeKey TypeSet)
res <- IO (Maybe (HashMap TypeKey TypeSet))
-> (SomeException -> IO (Maybe (HashMap TypeKey TypeSet)))
-> IO (Maybe (HashMap TypeKey TypeSet))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch (Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (HashMap TypeKey TypeSet)
 -> IO (Maybe (HashMap TypeKey TypeSet)))
-> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a b. (a -> b) -> a -> b
$! HashMap TypeKey TypeSet -> Maybe (HashMap TypeKey TypeSet)
forall a. a -> Maybe a
Just (HashMap TypeKey TypeSet -> Maybe (HashMap TypeKey TypeSet))
-> HashMap TypeKey TypeSet -> Maybe (HashMap TypeKey TypeSet)
forall a b. (a -> b) -> a -> b
$! DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
insertHitMap DataBox
from HashMap TypeKey TypeSet
hit) (\(SomeException
_ :: SomeException) -> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HashMap TypeKey TypeSet)
forall a. Maybe a
Nothing)
            case Maybe (HashMap TypeKey TypeSet)
res of
                Maybe (HashMap TypeKey TypeSet)
Nothing -> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HashMap TypeKey TypeSet)
forall a. Maybe a
Nothing
                Just HashMap TypeKey TypeSet
hit -> do
                    IORef Cache -> (Cache -> (Cache, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache ((Cache -> (Cache, ())) -> IO ())
-> (Cache -> (Cache, ())) -> IO ()
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, ())
                    Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (HashMap TypeKey TypeSet)
 -> IO (Maybe (HashMap TypeKey TypeSet)))
-> Maybe (HashMap TypeKey TypeSet)
-> IO (Maybe (HashMap TypeKey TypeSet))
forall a b. (a -> b) -> a -> b
$ HashMap TypeKey TypeSet -> Maybe (HashMap TypeKey TypeSet)
forall a. a -> Maybe a
Just HashMap TypeKey TypeSet
hit


---------------------------------------------------------------------
-- TYPEMAP2/INTMAP2

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 = TypeKey -> TypeMap2 a -> Maybe (TypeMap a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeKey
x TypeMap2 a
mp Maybe (TypeMap a) -> (TypeMap a -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeKey -> TypeMap a -> Maybe a
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 = (TypeMap a -> TypeMap a -> TypeMap a)
-> TypeKey -> TypeMap a -> TypeMap2 a -> TypeMap2 a
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith ((TypeMap a -> TypeMap a) -> TypeMap a -> TypeMap a -> TypeMap a
forall a b. a -> b -> a
const ((TypeMap a -> TypeMap a) -> TypeMap a -> TypeMap a -> TypeMap a)
-> (TypeMap a -> TypeMap a) -> TypeMap a -> TypeMap a -> TypeMap a
forall a b. (a -> b) -> a -> b
$ TypeKey -> a -> TypeMap a -> TypeMap a
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert TypeKey
y a
v) TypeKey
x (TypeKey -> a -> TypeMap a
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 = Int -> IntMap2 a -> Maybe (IntMap a)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
x IntMap2 a
mp Maybe (IntMap a) -> (IntMap a -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IntMap a -> Maybe a
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 = (IntMap a -> IntMap a -> IntMap a)
-> Int -> IntMap a -> IntMap2 a -> IntMap2 a
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith ((IntMap a -> IntMap a) -> IntMap a -> IntMap a -> IntMap a
forall a b. a -> b -> a
const ((IntMap a -> IntMap a) -> IntMap a -> IntMap a -> IntMap a)
-> (IntMap a -> IntMap a) -> IntMap a -> IntMap a -> IntMap a
forall a b. (a -> b) -> a -> b
$ Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
y a
v) Int
x (Int -> a -> IntMap a
forall a. Int -> a -> IntMap a
IntMap.singleton Int
y a
v) IntMap2 a
mp


---------------------------------------------------------------------
-- FOLLOWER
-- Function to test if you should follow

type Follower = TypeKey -> Bool


-- HitMap must have addHitMap on the key
follower :: TypeKey -> TypeKey -> HitMap -> Follower
follower :: TypeKey -> TypeKey -> HashMap TypeKey TypeSet -> Follower
follower TypeKey
from TypeKey
to HashMap TypeKey TypeSet
mp
    | TypeSet -> Bool
forall a. HashSet a -> Bool
Set.null TypeSet
hit = Bool -> Follower
forall a b. a -> b -> a
const Bool
False
    | TypeSet -> Bool
forall a. HashSet a -> Bool
Set.null TypeSet
miss = Bool -> Follower
forall a b. a -> b -> a
const Bool
True
    | TypeSet -> Int
forall a. HashSet a -> Int
Set.size TypeSet
hit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TypeSet -> Int
forall a. HashSet a -> Int
Set.size TypeSet
miss = \TypeKey
k -> TypeKey
k TypeKey -> TypeSet -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeSet
hit
    | Bool
otherwise = \TypeKey
k -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TypeKey
k TypeKey -> TypeSet -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeSet
miss
    where
        (TypeSet
hit,TypeSet
miss) = Follower -> TypeSet -> (TypeSet, TypeSet)
forall {a}. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
set_partition (\TypeKey
x -> TypeKey
to TypeKey -> TypeSet -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` TypeKey -> TypeSet
grab TypeKey
x) (TypeKey -> TypeSet -> TypeSet
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert TypeKey
from (TypeSet -> TypeSet) -> TypeSet -> TypeSet
forall a b. (a -> b) -> a -> b
$ TypeKey -> TypeSet
grab TypeKey
from)
        grab :: TypeKey -> TypeSet
grab TypeKey
x = TypeSet -> TypeKey -> HashMap TypeKey TypeSet -> TypeSet
forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault ([Char] -> TypeSet
forall a. HasCallStack => [Char] -> a
error [Char]
"couldn't grab in follower") TypeKey
x HashMap TypeKey TypeSet
mp


---------------------------------------------------------------------
-- DATA/TYPEABLE OPERATIONS

-- | An existential box representing a type which supports SYB
-- operations.
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 = TypeKey -> a -> DataBox
forall a. Data a => TypeKey -> a -> DataBox
DataBox (a -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey a
x) a
x


-- NOTE: This function is partial, but all exceptions are caught later on
sybChildren :: Data a => a -> [DataBox]
sybChildren :: forall a. Data a => a -> [DataBox]
sybChildren a
x
    | DataType -> Bool
isAlgType DataType
dtyp = (Constr -> [DataBox]) -> [Constr] -> [DataBox]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constr -> [DataBox]
f [Constr]
ctrs
    | DataType -> Bool
isNorepType DataType
dtyp = []
        -- Extensive discussions with Lennart and Roman decided that if something returns NorepType, it really wants to be atomic
        -- so we should let it be, and pretend it has no children.
        -- The most common types which say this are Data.Set/Data.Map, and we think that's a bug in their Data instances.
        -- error $ "Data.Generics.Uniplate.Data: sybChildren on data type which returns NorepType, " ++ show (typeOf x) ++ ", " ++ show dtyp
    | Bool
otherwise = []
    where
        f :: Constr -> [DataBox]
f Constr
ctr = (forall a. Data a => a -> DataBox) -> a -> [DataBox]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ d -> DataBox
forall a. Data a => a -> DataBox
dataBox (a -> a -> a
forall a. a -> a -> a
asTypeOf (Constr -> a
forall a. Data a => Constr -> a
fromConstr Constr
ctr) a
x)
        ctrs :: [Constr]
ctrs = DataType -> [Constr]
dataTypeConstrs DataType
dtyp
        dtyp :: DataType
dtyp = a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
x


---------------------------------------------------------------------
-- HITMAP
-- What is the transitive closure of a type key

type HitMap = TypeMap TypeSet

emptyHitMap :: HitMap
emptyHitMap :: HashMap TypeKey TypeSet
emptyHitMap = [(TypeKey, TypeSet)] -> HashMap TypeKey TypeSet
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
        [(TypeKey
tRational, TypeKey -> TypeSet
forall a. Hashable a => a -> HashSet a
Set.singleton TypeKey
tInteger)
        ,(TypeKey
tInteger, TypeSet
forall a. HashSet a
Set.empty)]
    where tRational :: TypeKey
tRational = Rational -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey (Rational
forall a. HasCallStack => a
undefined :: Rational)
          tInteger :: TypeKey
tInteger = Integer -> TypeKey
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 = (HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet)
-> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
forall a. Eq a => (a -> a) -> a -> a
fixEq HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
trans (DataBox -> HashMap TypeKey TypeSet
populate DataBox
box) HashMap TypeKey TypeSet
-> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`Map.union` HashMap TypeKey TypeSet
hit
    where
        -- create a fresh box with all the necessary children that aren't in hit
        populate :: DataBox -> HitMap
        populate :: DataBox -> HashMap TypeKey TypeSet
populate DataBox
x = DataBox -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
f DataBox
x HashMap TypeKey TypeSet
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 TypeKey -> HashMap TypeKey TypeSet -> Bool
forall {k} {a}. Hashable k => k -> HashMap k a -> Bool
`map_member` HashMap TypeKey TypeSet
hit Bool -> Bool -> Bool
|| TypeKey
key TypeKey -> HashMap TypeKey TypeSet -> Bool
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 (HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet)
-> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
forall a b. (a -> b) -> a -> b
$ TypeKey
-> TypeSet -> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert TypeKey
key ([TypeKey] -> TypeSet
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([TypeKey] -> TypeSet) -> [TypeKey] -> TypeSet
forall a b. (a -> b) -> a -> b
$ (DataBox -> TypeKey) -> [DataBox] -> [TypeKey]
forall a b. (a -> b) -> [a] -> [b]
map DataBox -> TypeKey
dataBoxKey [DataBox]
cs) HashMap TypeKey TypeSet
mp
                        where cs :: [DataBox]
cs = a -> [DataBox]
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)


        -- update every one to be the transitive closure
        trans :: HitMap -> HitMap
        trans :: HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
trans HashMap TypeKey TypeSet
mp = (TypeSet -> TypeSet)
-> HashMap TypeKey TypeSet -> HashMap TypeKey TypeSet
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 ([TypeSet] -> TypeSet) -> [TypeSet] -> TypeSet
forall a b. (a -> b) -> a -> b
$ TypeSet
x TypeSet -> [TypeSet] -> [TypeSet]
forall a. a -> [a] -> [a]
: (TypeKey -> TypeSet) -> [TypeKey] -> [TypeSet]
forall a b. (a -> b) -> [a] -> [b]
map TypeKey -> TypeSet
g (TypeSet -> [TypeKey]
forall a. HashSet a -> [a]
Set.toList TypeSet
x)
                g :: TypeKey -> TypeSet
g TypeKey
x = TypeSet -> TypeKey -> HashMap TypeKey TypeSet -> TypeSet
forall {k} {a}. Hashable k => a -> k -> HashMap k a -> a
map_findWithDefault (HashMap TypeKey TypeSet
hit HashMap TypeKey TypeSet -> TypeKey -> TypeSet
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2 then a
x2 else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f a
x2
    where x2 :: a
x2 = a -> a
f a
x


---------------------------------------------------------------------
-- INSTANCE FUNCTIONS

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 on -> Answer with
forall a. Typeable a => a -> Answer with
oracle on
x of
    Hit with
y -> (with -> Str with
forall a. a -> Str a
One with
y, \(One with
x) -> with -> on
forall a b. a -> b
unsafeCoerce with
x)
    Answer with
Follow -> (forall a. Typeable a => a -> Answer with) -> on -> CC with on
forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
uniplateData a -> Answer with
forall a. Typeable a => a -> Answer with
oracle on
x
    Answer with
Miss -> (Str with
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 = C with on -> CC with on
forall x a. C x a -> CC x a
fromC (C with on -> CC with on) -> C with on -> CC with on
forall a b. (a -> b) -> a -> b
$ (forall d b. Data d => C with (d -> b) -> d -> C with b)
-> (forall g. g -> C with g) -> on -> C with on
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> on -> c on
gfoldl C with (d -> b) -> d -> C with b
forall d b. Data d => C with (d -> b) -> d -> C with b
combine g -> C with g
forall g. g -> C with g
create on
item
    where
        combine :: Data a => C with (a -> b) -> a -> C with b
        combine :: forall d b. Data d => C with (d -> b) -> d -> C with b
combine (C (Str with
c,Str with -> a -> b
g)) a
x = case (forall a. Typeable a => a -> Answer with) -> a -> CC with a
forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with) -> on -> CC with on
biplateData a -> Answer with
forall a. Typeable a => a -> Answer with
oracle a
x of
                                  (Str with
c2, Str with -> a
g2) -> CC with b -> C with b
forall x a. CC x a -> C x a
C (Str with -> Str with -> Str with
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 = CC with g -> C with g
forall x a. CC x a -> C x a
C (Str with
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 b. Data b => b -> b) -> on -> on
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((forall a. Typeable a => a -> Answer on) -> (on -> on) -> b -> b
forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> with) -> on -> on
descendBiData a -> Answer on
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 on -> Answer with
forall a. Typeable a => a -> Answer with
oracle on
x of
    Hit with
y -> with -> on
forall a b. a -> b
unsafeCoerce (with -> on) -> with -> on
forall a b. (a -> b) -> a -> b
$ with -> with
op with
y
    Answer with
Follow -> (forall b. Data b => b -> b) -> on -> on
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((forall a. Typeable a => a -> Answer with)
-> (with -> with) -> b -> b
forall on with.
(Data on, Data with) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> with) -> on -> on
descendBiData a -> Answer with
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 d. Data d => d -> m d) -> on -> m on
forall (m :: * -> *) a.
(Data a, Applicative m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapA ((forall a. Typeable a => a -> Answer on)
-> (on -> m on) -> d -> m d
forall on with (m :: * -> *).
(Data on, Data with, Applicative m) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> on -> m on
descendBiDataM a -> Answer on
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 on -> Answer with
forall a. Typeable a => a -> Answer with
oracle on
x of
    Hit with
y -> m with -> m on
forall a b. a -> b
unsafeCoerce (m with -> m on) -> m with -> m on
forall a b. (a -> b) -> a -> b
$ with -> m with
op with
y
    Answer with
Follow -> (forall d. Data d => d -> m d) -> on -> m on
forall (m :: * -> *) a.
(Data a, Applicative m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapA ((forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> d -> m d
forall on with (m :: * -> *).
(Data on, Data with, Applicative m) =>
(forall a. Typeable a => a -> Answer with)
-> (with -> m with) -> on -> m on
descendBiDataM a -> Answer with
forall a. Typeable a => a -> Answer with
oracle with -> m with
op) on
x
    Answer with
Miss -> on -> m on
forall a. a -> m a
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 d b. Data d => m (d -> b) -> d -> m b)
-> (forall g. g -> m g) -> a -> m 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
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl m (d -> b) -> d -> m b
forall d b. Data d => m (d -> b) -> d -> m b
k g -> m g
forall g. g -> m g
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 m (d -> b) -> m d -> m b
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> m d
forall d. Data d => d -> m d
f d
x


---------------------------------------------------------------------
-- FUSION

data Transformer = forall a . Data a => Transformer TypeKey (a -> a)


-- | Wrap up a @(a -> a)@ transformation function, to use with 'transformBis'
transformer :: Data a => (a -> a) -> Transformer
transformer :: forall a. Data a => (a -> a) -> Transformer
transformer = (a -> a) -> Transformer
forall a. Data a => (a -> a) -> Transformer
transformer_


-- Don't export directly, as don't want Haddock to see the forall
transformer_ :: forall a . Data a => (a -> a) -> Transformer
transformer_ :: forall a. Data a => (a -> a) -> Transformer
transformer_ = TypeKey -> (a -> a) -> Transformer
forall a. Data a => TypeKey -> (a -> a) -> Transformer
Transformer (a -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey (a
forall a. HasCallStack => a
undefined :: a))


-- | Apply a sequence of transformations in order. This function obeys the equivalence:
--
-- > transformBis [[transformer f],[transformer g],...] == transformBi f . transformBi g . ...
--
--   Each item of type @[Transformer]@ is applied in turn, right to left. Within each
--   @[Transformer]@, the individual @Transformer@ values may be interleaved.
--
--   The implementation will attempt to perform fusion, and avoid walking any part of the
--   data structure more than necessary. To further improve performance, you may wish to
--   partially apply the first argument, which will calculate information about the relationship
--   between the transformations.
transformBis :: forall a . Data a => [[Transformer]] -> a -> a
transformBis :: forall a. Data a => [[Transformer]] -> a -> a
transformBis = [[Transformer]] -> a -> a
forall a. Data a => [[Transformer]] -> a -> a
transformBis_


transformBis_ :: forall a . Data a => [[Transformer]] -> a -> a

-- basic algorithm:
-- as you go down, given transformBis [fN..f1]
--   if x is not in the set reachable by fN..f1, return x
--   if x is in the reachable set, gmap (transformBis [fN..f1]) x
--   if x is one of fN..f1, pick the lowest fi then
--      transformBis [fN..f(i+1)] $ fi $ gmap (transformBis [fi..f1]) x

transformBis_ :: forall a. Data a => [[Transformer]] -> a -> a
transformBis_ [[Transformer]]
ts | Maybe (HashMap TypeKey TypeSet) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (HashMap TypeKey TypeSet)
hitBoxM = TypeMap (Maybe Transformer) -> a -> a
forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op (Int -> Int -> TypeMap (Maybe Transformer)
sliceMe Int
1 Int
n)
    where
        on :: DataBox
on = a -> DataBox
forall a. Data a => a -> DataBox
dataBox (a
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 = Maybe (HashMap TypeKey TypeSet) -> HashMap TypeKey TypeSet
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (HashMap TypeKey TypeSet)
hitBoxM
        univ :: [TypeKey]
univ = TypeSet -> [TypeKey]
forall a. HashSet a -> [a]
set_toAscList (TypeSet -> [TypeKey]) -> TypeSet -> [TypeKey]
forall a b. (a -> b) -> a -> b
$ TypeKey -> TypeSet -> TypeSet
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert (DataBox -> TypeKey
dataBoxKey DataBox
on) (TypeSet -> TypeSet) -> TypeSet -> TypeSet
forall a b. (a -> b) -> a -> b
$ HashMap TypeKey TypeSet
hitBox HashMap TypeKey TypeSet -> TypeKey -> TypeSet
forall {k} {a}. Hashable k => HashMap k a -> k -> a
! DataBox -> TypeKey
dataBoxKey DataBox
on
        n :: Int
n = [[Transformer]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Transformer]]
ts

        -- (a,b), where a < b, and both in range 1..n
        sliceMe :: Int -> Int -> TypeMap (Maybe Transformer)
sliceMe Int
i Int
j = TypeMap (Maybe Transformer)
-> Maybe (TypeMap (Maybe Transformer))
-> TypeMap (Maybe Transformer)
forall a. a -> Maybe a -> a
fromMaybe TypeMap (Maybe Transformer)
forall k v. HashMap k v
Map.empty (Maybe (TypeMap (Maybe Transformer))
 -> TypeMap (Maybe Transformer))
-> Maybe (TypeMap (Maybe Transformer))
-> TypeMap (Maybe Transformer)
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> IntMap2 (TypeMap (Maybe Transformer))
-> Maybe (TypeMap (Maybe Transformer))
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 = [(Int, IntMap (TypeMap (Maybe Transformer)))]
-> IntMap2 (TypeMap (Maybe Transformer))
forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList
            [ (Int
i, [(Int, TypeMap (Maybe Transformer))]
-> IntMap (TypeMap (Maybe Transformer))
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) <- [Int] -> [[[Transformer]]] -> [(Int, [[Transformer]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i..Int
n] ([[[Transformer]]] -> [[[Transformer]]]
forall a. HasCallStack => [a] -> [a]
tail ([[[Transformer]]] -> [[[Transformer]]])
-> [[[Transformer]]] -> [[[Transformer]]]
forall a b. (a -> b) -> a -> b
$ [[Transformer]] -> [[[Transformer]]]
forall a. [a] -> [[a]]
inits [[Transformer]]
ts)])
            | (Int
i,[[Transformer]]
ts) <- [Int] -> [[[Transformer]]] -> [(Int, [[Transformer]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
n] ([[Transformer]] -> [[[Transformer]]]
forall a. [a] -> [[a]]
tails ([[Transformer]] -> [[[Transformer]]])
-> [[Transformer]] -> [[[Transformer]]]
forall a b. (a -> b) -> a -> b
$ [[Transformer]] -> [[Transformer]]
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 TypeMap (Maybe Transformer)
forall k v. HashMap k v
Map.empty ([Int] -> [[Transformer]] -> [(Int, [Transformer])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
from..] [[Transformer]]
tts) -- FIXME: flattening out here gives different results...
                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 TypeKey -> TypeMap (Maybe Transformer) -> Bool
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 (TypeKey
-> Maybe Transformer
-> TypeMap (Maybe Transformer)
-> TypeMap (Maybe Transformer)
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 = Transformer -> Maybe Transformer
forall a. a -> Maybe a
Just (Transformer -> Maybe Transformer)
-> Transformer -> Maybe Transformer
forall a b. (a -> b) -> a -> b
$ TypeKey -> (a -> a) -> Transformer
forall a. Data a => TypeKey -> (a -> a) -> Transformer
Transformer TypeKey
tk ((a -> a) -> Transformer) -> (a -> a) -> Transformer
forall a b. (a -> b) -> a -> b
$ TypeMap (Maybe Transformer) -> a -> a
forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op (Int -> Int -> TypeMap (Maybe Transformer)
sliceMe (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
to) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
tr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (TypeMap (Maybe Transformer) -> b -> b
forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op (TypeMap (Maybe Transformer) -> b -> b)
-> TypeMap (Maybe Transformer) -> b -> b
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 TypeMap (Maybe Transformer)
-> TypeMap (Maybe Transformer) -> TypeMap (Maybe Transformer)
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`Map.union` [(TypeKey, Maybe Transformer)] -> TypeMap (Maybe Transformer)
forall {v}. [(TypeKey, v)] -> HashMap TypeKey v
map_fromAscList ((TypeKey -> Maybe (TypeKey, Maybe Transformer))
-> [TypeKey] -> [(TypeKey, Maybe Transformer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TypeSet -> TypeKey -> Maybe (TypeKey, Maybe Transformer)
forall {a}. TypeSet -> TypeKey -> Maybe (TypeKey, Maybe a)
g (TypeSet -> TypeKey -> Maybe (TypeKey, Maybe Transformer))
-> TypeSet -> TypeKey -> Maybe (TypeKey, Maybe Transformer)
forall a b. (a -> b) -> a -> b
$ TypeMap (Maybe Transformer) -> TypeSet
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 Maybe (TypeKey, Maybe a)
forall a. Maybe a
Nothing else (TypeKey, Maybe a) -> Maybe (TypeKey, Maybe a)
forall a. a -> Maybe a
Just (TypeKey
t, Maybe a
forall a. Maybe a
Nothing)
                    where b :: Bool
b = TypeSet -> Bool
forall a. HashSet a -> Bool
Set.null (TypeSet -> Bool) -> TypeSet -> Bool
forall a b. (a -> b) -> a -> b
$ TypeSet
a TypeSet -> TypeSet -> TypeSet
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
`Set.intersection` (HashMap TypeKey TypeSet
hitBox HashMap TypeKey TypeSet -> TypeKey -> TypeSet
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 TypeKey -> TypeMap (Maybe Transformer) -> Maybe (Maybe Transformer)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (b -> TypeKey
forall a. Typeable a => a -> TypeKey
typeKey (b
forall a. HasCallStack => a
undefined :: b)) TypeMap (Maybe Transformer)
slice of
            Maybe (Maybe Transformer)
Nothing -> b -> b
forall a. a -> a
id
            Just Maybe Transformer
Nothing -> (forall b. Data b => b -> b) -> b -> b
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (TypeMap (Maybe Transformer) -> b -> b
forall b. Data b => TypeMap (Maybe Transformer) -> b -> b
op TypeMap (Maybe Transformer)
slice)
            Just (Just (Transformer TypeKey
_ a -> a
t)) -> a -> b
forall a b. a -> b
unsafeCoerce (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
t (a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
forall a b. a -> b
unsafeCoerce


transformBis_ [] = a -> a
forall a. a -> a
id
transformBis_ ([]:[[Transformer]]
xs) = [[Transformer]] -> a -> a
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 ((a -> a) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT a -> a
t) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Transformer]] -> a -> a
forall a. Data a => [[Transformer]] -> a -> a
transformBis_ ([Transformer]
x[Transformer] -> [[Transformer]] -> [[Transformer]]
forall a. a -> [a] -> [a]
:[[Transformer]]
xs)