{-# 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 = 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 -- in 0.2.3.0 lookupDefault is strict in the default :(
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 -- -1 = error if failed, 0 = quiet, 1 = print errors only, 2 = print everything
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


---------------------------------------------------------------------
-- 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 = 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



---------------------------------------------------------------------
-- 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 = 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


-- 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) = 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


---------------------------------------------------------------------
-- 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 = 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


---------------------------------------------------------------------
-- 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
    | 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/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 = forall a. Data a => TypeKey -> a -> DataBox
DataBox (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 = 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 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


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

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
        -- 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 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)


        -- update every one to be the transitive closure
        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


---------------------------------------------------------------------
-- 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 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


---------------------------------------------------------------------
-- 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 = 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_ = forall a. Data a => TypeKey -> (a -> a) -> Transformer
Transformer (forall a. Typeable a => a -> TypeKey
typeKey (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 = 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 | 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

        -- (a,b), where a < b, and both in range 1..n
        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) -- 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 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)