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 qualified Data.IntSet as IntSet
import Data.IntSet(IntSet)
import qualified Data.IntMap as IntMap
import Data.IntMap(IntMap)
import Data.IORef
import Control.Exception
data Answer a = Hit {fromHit :: a}
| Follow
| Miss
data Oracle to = Oracle {fromOracle :: forall on . Typeable on => on -> Answer to}
hitTest :: (Data from, Data to) => from -> to -> Oracle to
#if __GLASGOW_HASKELL__ < 606
hitTest _ _ = Oracle . maybe Follow Hit . cast
#elif 0
hitTest from to =
let kto = typeKey to
in case hitTestQuery (dataBox from) kto of
Nothing -> Oracle $ \on -> if typeKey on == kto then Hit $ unsafeCoerce on else Follow
Just cache -> let test = cacheHitTest cache in
Oracle $ \on -> let kon = typeKey on in
if kon == kto then Hit $ unsafeCoerce on
else if test kon then Follow
else Miss
cacheHitTest :: Cache -> TypeKey -> Bool
cacheHitTest (Cache hit miss)
| IntSet.null hit = const False
| IntSet.null miss = const True
| otherwise = \x -> x `IntSet.member` hit
data Cache = Cache {hit :: IntSet, miss :: IntSet} deriving Show
newCache = Cache IntSet.empty IntSet.empty
hitTestCache :: IORef (IntMap (IntMap (Maybe Cache)))
hitTestCache = unsafePerformIO $ newIORef IntMap.empty
hitTestQuery :: DataBox -> TypeKey -> Maybe Cache
hitTestQuery from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do
mp <- readIORef hitTestCache
let res = IntMap.lookup kfrom mp >>= IntMap.lookup kto
case res of
Just ans -> return ans
Nothing -> do
let res = toCache $ hitTestAdd from kto IntMap.empty
res2 <- Control.Exception.catch (return $! res) (\(_ :: SomeException) -> return Nothing)
atomicModifyIORef hitTestCache $ \mp -> flip (,) () $
IntMap.insertWith (const $ IntMap.insert kto res2) kfrom (IntMap.singleton kto res2) mp
return res2
data Res = RHit | RMiss | RFollow | RBad deriving (Show,Eq)
toCache :: IntMap Res -> Maybe Cache
toCache res | not $ IntSet.null $ f RBad = Nothing
| otherwise = Just $ Cache (f RFollow) (f RMiss)
where f x = IntMap.keysSet $ IntMap.filter (== x) res
hitTestAdd :: DataBox -> TypeKey -> IntMap Res -> IntMap Res
hitTestAdd from@(DataBox kfrom _) kto res = case sybChildren from of
_ | kfrom `IntMap.member` res -> res
Nothing -> IntMap.insert kfrom RBad res
Just xs | kto == kfrom -> hitTestAdds xs kto $ IntMap.insert kfrom RHit res
| correct -> res2
| otherwise -> hitTestAdds xs kto $ IntMap.insert kfrom RFollow res
where res2 = hitTestAdds xs kto $ IntMap.insert kfrom RMiss res
correct = all ((==) RMiss . (res2 IntMap.!) . dataBoxKey) xs
hitTestAdds :: [DataBox] -> TypeKey -> IntMap Res -> IntMap Res
hitTestAdds [] kto res = res
hitTestAdds (x:xs) kto res = hitTestAdds xs kto $ hitTestAdd x kto res
type TypeKey = Int
typeKey :: Typeable a => a -> Int
typeKey x = inlinePerformIO $ typeRepKey $ typeOf x
data DataBox = forall a . (Data a) => DataBox {dataBoxKey :: TypeKey, dataBoxVal :: a}
dataBox :: Data a => a -> DataBox
dataBox x = DataBox (typeKey x) x
sybChildren :: DataBox -> Maybe [DataBox]
sybChildren (DataBox k x)
| k == typeRational = Just [dataBox (0 :: Integer)]
| isAlgType dtyp = Just $ concatMap f ctrs
| isNorepType dtyp = Nothing
| otherwise = Just []
where
f ctr = gmapQ dataBox (asTypeOf (fromConstr ctr) x)
ctrs = dataTypeConstrs dtyp
dtyp = dataTypeOf x
typeRational = typeKey (undefined :: Rational)
#else
hitTest from to =
let kto = typeKey to
in case readCacheFollower (dataBox from) kto of
Nothing -> Oracle $ \on -> if typeKey on == kto then Hit $ unsafeCoerce on else Follow
Just test -> Oracle $ \on -> let kon = typeKey on in
if kon == kto then Hit $ unsafeCoerce on
else if test kon then Follow
else Miss
data Cache = Cache HitMap (IntMap2 (Maybe Follower))
cache :: IORef Cache
cache = unsafePerformIO $ newIORef $ Cache emptyHitMap IntMap.empty
readCacheFollower :: DataBox -> TypeKey -> Maybe Follower
readCacheFollower from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do
Cache hit follow <- readIORef cache
case lookup2 kfrom kto follow of
Just ans -> return ans
Nothing -> do
res <- Control.Exception.catch (return $! Just $! insertHitMap from hit) (\(_ :: SomeException) -> return Nothing)
(hit,fol) <- return $ case res of
Nothing -> (hit, Nothing)
Just hit -> (hit, Just $ follower kfrom kto hit)
atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit (insert2 kfrom kto fol follow), ())
return fol
readCacheHitMap :: DataBox -> Maybe HitMap
readCacheHitMap from@(DataBox kfrom vfrom) = inlinePerformIO $ do
Cache hit _ <- readIORef cache
case IntMap.lookup kfrom hit of
Just _ -> return $ Just hit
Nothing -> do
res <- Control.Exception.catch (return $! Just $! insertHitMap from hit) (\(_ :: SomeException) -> return Nothing)
case res of
Nothing -> return Nothing
Just hit -> do
atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit follow, ())
return $ Just hit
type IntMap2 a = IntMap (IntMap a)
lookup2 :: Int -> Int -> IntMap (IntMap x) -> Maybe x
lookup2 x y mp = IntMap.lookup x mp >>= IntMap.lookup y
insert2 :: Int -> Int -> x -> IntMap (IntMap x) -> IntMap (IntMap x)
insert2 x y v mp = IntMap.insertWith (const $ IntMap.insert y v) x (IntMap.singleton y v) mp
type Follower = TypeKey -> Bool
follower :: TypeKey -> TypeKey -> HitMap -> Follower
follower from to mp
| IntSet.null hit = const False
| IntSet.null miss = const True
| otherwise = \now -> now `IntSet.member` hit
where
(hit,miss) = IntSet.partition (\x -> to `IntSet.member` grab x) (IntSet.insert from $ grab from)
grab x = IntMap.findWithDefault (error "couldn't grab in follower") x mp
type TypeKey = Int
typeKey :: Typeable a => a -> Int
typeKey x = inlinePerformIO $ typeRepKey $ typeOf x
data DataBox = forall a . (Data a) => DataBox {dataBoxKey :: TypeKey, dataBoxVal :: a}
dataBox :: Data a => a -> DataBox
dataBox x = DataBox (typeKey x) x
sybChildren :: Data a => a -> [DataBox]
sybChildren x
| isAlgType dtyp = concatMap f ctrs
| isNorepType dtyp = error "sybChildren on NorepType"
| otherwise = []
where
f ctr = gmapQ dataBox (asTypeOf (fromConstr ctr) x)
ctrs = dataTypeConstrs dtyp
dtyp = dataTypeOf x
type HitMap = IntMap IntSet
emptyHitMap :: HitMap
emptyHitMap = IntMap.fromList
[(tRational, IntSet.singleton tInteger)
,(tInteger, IntSet.empty)]
where tRational = typeKey (undefined :: Rational)
tInteger = typeKey (0 :: Integer)
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap box hit = fixEq trans (populate box) `IntMap.union` hit
where
populate :: DataBox -> HitMap
populate x = f x IntMap.empty
where
f (DataBox key val) mp
| key `IntMap.member` hit || key `IntMap.member` mp = mp
| otherwise = fs cs $ IntMap.insert key (IntSet.fromList $ map dataBoxKey cs) mp
where cs = sybChildren val
fs [] mp = mp
fs (x:xs) mp = fs xs (f x mp)
trans :: HitMap -> HitMap
trans mp = IntMap.map f mp
where
f x = IntSet.unions $ x : map g (IntSet.toList x)
g x = IntMap.findWithDefault (hit IntMap.! x) x mp
fixEq :: Eq a => (a -> a) -> a -> a
fixEq f x = if x == x2 then x2 else fixEq f x2
where x2 = f x
#endif
newtype C x a = C {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 oracle x = case oracle x of
Hit y -> (One y, \(One x) -> unsafeCoerce x)
Follow -> uniplateData oracle x
Miss -> (Zero, \_ -> x)
uniplateData :: forall on with . (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
uniplateData oracle item = fromC $ gfoldl combine create item
where
combine :: Data a => C with (a -> b) -> a -> C with b
combine (C (c,g)) x = case biplateData oracle x of
(c2, g2) -> C (Two c c2, \(Two c' c2') -> g c' (g2 c2'))
create :: g -> C with g
create x = C (Zero, \_ -> x)
descendData :: Data on => (forall a . Typeable a => a -> Answer on) -> (on -> on) -> on -> on
descendData oracle op = gmapT (descendBiData oracle op)
descendBiData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> (with -> with) -> on -> on
descendBiData oracle op x = case oracle x of
Hit y -> unsafeCoerce $ op y
Follow -> gmapT (descendBiData oracle op) x
Miss -> x
data Transformer = forall a . Data a => Transformer TypeKey (a -> a)
transformer :: Data a => (a -> a) -> Transformer
transformer = transformer_
transformer_ :: forall a . Data a => (a -> a) -> Transformer
transformer_ = Transformer (typeKey (undefined :: a))
transformBis :: forall a . Data a => [[Transformer]] -> a -> a
transformBis = transformBis_
transformBis_ :: forall a . Data a => [[Transformer]] -> a -> a
#if __GLASGOW_HASKELL__ >= 606
transformBis_ ts | isJust hitBoxM = op (sliceMe 1 n)
where
on = dataBox (undefined :: a)
hitBoxM = readCacheHitMap on
hitBox = fromJust hitBoxM
univ = IntSet.toAscList $ IntSet.insert (dataBoxKey on) $ hitBox IntMap.! dataBoxKey on
n = length ts
sliceMe i j = fromMaybe IntMap.empty $ lookup2 i j slices
slices :: IntMap2 (IntMap (Maybe Transformer))
slices = IntMap.fromAscList
[ (i, IntMap.fromAscList [(j, slice i j ts) | (j,ts) <- zip [i..n] (tail $ inits ts)])
| (i,ts) <- zip [1..n] (tails $ reverse ts)]
slice :: Int -> Int -> [[Transformer]] -> IntMap (Maybe Transformer)
slice from to tts = self
where
self = f IntMap.empty (zip [from..] tts)
f a ((i,[Transformer tk tr]):ts)
| tk `IntMap.member` a = f a ts
| otherwise = f (IntMap.insert tk t a) ts
where
t = Just $ Transformer tk $ op (sliceMe (i+1) to) . tr . gmapT (op $ sliceMe from i)
f a [] = a `IntMap.union` IntMap.fromAscList (mapMaybe (g $ IntMap.keysSet a) $ univ)
g a t = if b then Nothing else Just (t, Nothing)
where b = IntSet.null $ a `IntSet.intersection` (hitBox IntMap.! t)
op :: forall b . Data b => IntMap (Maybe Transformer) -> b -> b
op slice = case IntMap.lookup (typeKey (undefined :: b)) slice of
Nothing -> id
Just Nothing -> gmapT (op slice)
Just (Just (Transformer _ t)) -> unsafeCoerce . t . unsafeCoerce
#endif
transformBis_ [] = id
transformBis_ ([]:xs) = transformBis_ xs
transformBis_ ((Transformer _ t:x):xs) = everywhere (mkT t) . transformBis_ (x:xs)