{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
#ifndef HLINT
{-# LANGUAGE UnboxedTuples #-}
#endif
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
module Data.Data.Lens
(
template
, tinplate
, uniplate
, biplate
, upon
, upon'
, onceUpon
, onceUpon'
, gtraverse
) where
import Control.Applicative
import Control.Exception as E
import Control.Lens.Internal.Context
import Control.Lens.Internal.Indexed
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Lens.Traversal
import Control.Lens.Type
import Data.Data
import GHC.IO
import Data.Maybe
import Data.Foldable
import qualified Data.HashMap.Strict as M
import Data.HashMap.Strict (HashMap, (!))
import qualified Data.HashSet as S
import Data.HashSet (HashSet)
import Data.IORef
import Data.Monoid
import GHC.Exts (realWorld#)
import Prelude
#ifdef HLINT
{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Use foldl" #-}
{-# ANN module "HLint: ignore Reduce duplication" #-}
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
#endif
gtraverse :: (Applicative f, Data a) => (forall d. Data d => d -> f d) -> a -> f a
gtraverse f = gfoldl (\x y -> x <*> f y) pure
{-# INLINE gtraverse #-}
tinplate :: (Data s, Typeable a) => Traversal' s a
tinplate f = gfoldl (step f) pure
{-# INLINE tinplate #-}
step :: forall s a f r. (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r
step f w s = w <*> case mightBe :: Maybe (Is s a) of
Just Data.Data.Lens.Refl -> f s
Nothing -> tinplate f s
{-# INLINE step #-}
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template = uniplateData (fromOracle answer) where
answer = hitTest (undefined :: s) (undefined :: a)
{-# INLINE template #-}
uniplate :: Data a => Traversal' a a
uniplate = template
{-# INLINE uniplate #-}
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate = biplateData (fromOracle answer) where
answer = hitTest (undefined :: s) (undefined :: a)
{-# INLINE biplate #-}
data FieldException a = FieldException !Int a deriving Typeable
instance Show (FieldException a) where
showsPrec d (FieldException i _) = showParen (d > 10) $
showString "<field " . showsPrec 11 i . showChar '>'
instance Typeable a => Exception (FieldException a)
lookupon :: Typeable a => LensLike' (Indexing Identity) s a -> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexing l %@~ \i (a::a) -> E.throw (FieldException i a) of
Right _ -> Nothing
Left e -> case fromException e of
Nothing -> Nothing
Just (FieldException i a) -> Just (i, Context (\a' -> set (elementOf l i) a' s) a)
{-# INLINE lookupon #-}
upon :: forall p f s a. (Indexable [Int] p, Applicative f, Data s, Data a) => (s -> a) -> p a (f a) -> s -> f s
upon field f s = case lookupon template field s of
Nothing -> pure s
Just (i, Context k0 a0) ->
let
go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go is l k a = case lookupon (l.uniplate) field s of
Nothing -> k <$> indexed f (reverse is) a
Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a'
in go [i] (elementOf template i) k0 a0
{-# INLINE upon #-}
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' field f s = let
~(isn, kn) = case lookupon template field s of
Nothing -> (error "upon': no index, not a member", const s)
Just (i, Context k0 _) -> go [i] (elementOf template i) k0
go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go is l k = case lookupon (l.uniplate) field s of
Nothing -> (reverse is, k)
Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k'
in kn <$> indexed f isn (field s)
{-# INLINE upon' #-}
onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedTraversal' Int s a
onceUpon field f s = case lookupon template field s of
Nothing -> pure s
Just (i, Context k a) -> k <$> indexed f i a
{-# INLINE onceUpon #-}
onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedLens' Int s a
onceUpon' field f s = k <$> indexed f i (field s) where
~(i, Context k _) = fromMaybe (error "upon': no index, not a member") (lookupon template field s)
{-# INLINE onceUpon' #-}
data Is a b where
Refl :: Is a a
mightBe :: (Typeable a, Typeable b) => Maybe (Is a b)
mightBe = gcast Data.Data.Lens.Refl
{-# INLINE mightBe #-}
data DataBox = forall a. Data a => DataBox
{ dataBoxKey :: TypeRep
, _dataBoxVal :: a
}
dataBox :: Data a => a -> DataBox
dataBox a = DataBox (typeOf a) a
{-# INLINE dataBox #-}
sybChildren :: Data a => a -> [DataBox]
sybChildren x
| isAlgType dt = do
c <- dataTypeConstrs dt
gmapQ dataBox (fromConstr c `asTypeOf` x)
| otherwise = []
where dt = dataTypeOf x
{-# INLINE sybChildren #-}
type HitMap = HashMap TypeRep (HashSet TypeRep)
emptyHitMap :: HitMap
emptyHitMap = M.fromList
[ (tRational, S.singleton tInteger)
, (tInteger, S.empty)
] where
tRational = typeOf (undefined :: Rational)
tInteger = typeOf (undefined :: Integer )
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap box hit = fixEq trans (populate box) `mappend` hit where
populate :: DataBox -> HitMap
populate a = f a M.empty where
f (DataBox k v) m
| M.member k hit || M.member k m = m
| cs <- sybChildren v = fs cs $ M.insert k (S.fromList $ map dataBoxKey cs) m
fs [] m = m
fs (x:xs) m = fs xs (f x m)
trans :: HitMap -> HitMap
trans m = M.map f m where
f x = x `mappend` foldMap g x
g x = fromMaybe (hit ! x) (M.lookup x m)
fixEq :: Eq a => (a -> a) -> a -> a
fixEq f = go where
go x | x == x' = x'
| otherwise = go x'
where x' = f x
{-# INLINE fixEq #-}
#ifndef HLINT
inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of
(# _, r #) -> r
{-# INLINE inlinePerformIO #-}
#endif
data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower)))
cache :: IORef Cache
cache = unsafePerformIO $ newIORef $ Cache emptyHitMap M.empty
{-# NOINLINE cache #-}
readCacheFollower :: DataBox -> TypeRep -> Maybe Follower
readCacheFollower b@(DataBox kb _) ka = inlinePerformIO $
readIORef cache >>= \ (Cache hm m) -> case M.lookup kb m >>= M.lookup ka of
Just a -> return a
Nothing -> E.try (return $! insertHitMap b hm) >>= \r -> case r of
Left SomeException{} -> atomicModifyIORef cache $ \(Cache hm' n) -> (Cache hm' (insert2 kb ka Nothing n), Nothing)
Right hm' | fol <- Just (follower kb ka hm') -> atomicModifyIORef cache $ \(Cache _ n) -> (Cache hm' (insert2 kb ka fol n), fol)
insert2 :: TypeRep -> TypeRep -> a -> HashMap TypeRep (HashMap TypeRep a) -> HashMap TypeRep (HashMap TypeRep a)
insert2 x y v = M.insertWith (const $ M.insert y v) x (M.singleton y v)
{-# INLINE insert2 #-}
data Answer b a
= b ~ a => Hit a
| Follow
| Miss
newtype Oracle a = Oracle { fromOracle :: forall t. Typeable t => t -> Answer t a }
hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest a b = Oracle $ \(c :: c) ->
case mightBe :: Maybe (Is c b) of
Just Data.Data.Lens.Refl -> Hit c
Nothing ->
case readCacheFollower (dataBox a) (typeOf b) of
Just p | not (p (typeOf c)) -> Miss
_ -> Follow
biplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData o f a0 = go2 a0 where
go :: Data d => d -> f d
go s = gfoldl (\x y -> x <*> go2 y) pure s
go2 :: Data d => d -> f d
go2 s = case o s of
Hit a -> f a
Follow -> go s
Miss -> pure s
{-# INLINE biplateData #-}
uniplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData o f a0 = go a0 where
go :: Data d => d -> f d
go s = gfoldl (\x y -> x <*> go2 y) pure s
go2 :: Data d => d -> f d
go2 s = case o s of
Hit a -> f a
Follow -> go s
Miss -> pure s
{-# INLINE uniplateData #-}
part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part p s = (S.filter p s, S.filter (not . p) s)
{-# INLINE part #-}
type Follower = TypeRep -> Bool
follower :: TypeRep -> TypeRep -> HitMap -> Follower
follower a b m
| S.null hit = const False
| S.null miss = const True
| S.size hit < S.size miss = S.member ?? hit
| otherwise = \k -> not (S.member k miss)
where (hit, miss) = part (\x -> S.member b (m ! x)) (S.insert a (m ! a))