#ifdef TRUSTWORTHY
#endif
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.Getter
import Control.Lens.Indexed
import Control.Lens.IndexedLens
import Control.Lens.IndexedSetter
import Control.Lens.IndexedTraversal
import Control.Lens.Internal
import Control.Lens.Setter
import Control.Lens.Traversal
import Control.Lens.Type
import Data.Data
import GHC.IO
import Unsafe.Coerce as Unsafe
#ifndef SAFE
import Control.Arrow ((&&&))
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#)
#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
tinplate :: (Data s, Typeable a) => Simple Traversal s a
tinplate f = gfoldl (step f) pure
step :: (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r
step f w s = w <*> case cast s of
Just a -> unsafeCoerce <$> f a
Nothing -> tinplate f s
template :: forall s a. (Data s, Typeable a) => Simple Traversal s a
#ifdef SAFE
template = tinplate
#else
template = uniplateData (fromOracle answer) where
answer = hitTest (undefined :: s) (undefined :: a)
#endif
uniplate :: Data a => Simple Traversal a a
uniplate = template
biplate :: forall s a. (Data s, Typeable a) => Simple Traversal s a
#ifdef SAFE
biplate f s
| typeOf (undefined :: s) == typeOf (undefined :: a) = pure s
| otherwise = template f s
#else
biplate = biplateData (fromOracle answer) where
answer = hitTest (undefined :: s) (undefined :: a)
#endif
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 => SimpleLensLike (Indexing Mutator) 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)
upon :: forall k f s a. (Indexable [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s)
upon field = indexed $ \ f s -> case lookupon template field s of
Nothing -> pure s
Just (i, Context k0 a0) ->
let
go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s
go is l k a = case lookupon (l.uniplate) field s of
Nothing -> k <$> 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
upon' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a
upon' field = indexed $ \ 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] -> SimpleTraversal 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 <$> f isn (field s)
onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a
onceUpon field = indexed $ \f s -> case lookupon template field s of
Nothing -> pure s
Just (i, Context k a) -> k <$> f i a
onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a
onceUpon' field = indexed $ \f s -> let
~(i, Context k _) = case lookupon template field s of
Nothing -> error "upon': no index, not a member"
Just ip -> ip
in k <$> f i (field s)
#ifndef SAFE
data DataBox = forall a. Data a => DataBox
{ dataBoxKey :: TypeRep
, _dataBoxVal :: a
}
dataBox :: Data a => a -> DataBox
dataBox a = DataBox (typeOf a) a
sybChildren :: Data a => a -> [DataBox]
sybChildren x
| isAlgType dt = do
c <- dataTypeConstrs dt
gmapQ dataBox (fromConstr c `asTypeOf` x)
| otherwise = []
where dt = dataTypeOf x
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 = M.lookupDefault (hit ! x) 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
inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of
(# _, r #) -> r
data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower)))
cache :: IORef Cache
cache = unsafePerformIO $ newIORef $ Cache emptyHitMap M.empty
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)
data Answer a
= Hit a
| Follow
| Miss
deriving (Eq,Ord,Show,Read)
instance Functor Answer where
fmap f (Hit a) = Hit (f a)
fmap _ Follow = Follow
fmap _ Miss = Miss
newtype Oracle a = Oracle { fromOracle :: forall t. Typeable t => t -> Answer a }
instance Functor Oracle where
fmap f (Oracle g) = Oracle (fmap f . g)
hitTest :: (Data a, Typeable b) => a -> b -> Oracle b
hitTest a b
| kb <- typeOf b = case readCacheFollower (dataBox a) kb of
Nothing -> Oracle $ \c ->
if typeOf c == kb
then Hit (unsafeCoerce c)
else Follow
Just p -> Oracle $ \c -> let kc = typeOf c in
if kc == kb then Hit (unsafeCoerce c)
else if p kc then Follow
else Miss
biplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer 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 -> Unsafe.unsafeCoerce <$> f a
Follow -> go s
Miss -> pure s
uniplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer 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 -> Unsafe.unsafeCoerce <$> f a
Follow -> go s
Miss -> pure s
part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part p = S.filter p &&& S.filter (not . p)
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 = \k -> S.member k hit
| otherwise = \k -> not (S.member k miss)
where (hit, miss) = part (\x -> S.member b (m ! x)) (S.insert a (m ! a))
#endif