{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
#if __GLASGOW_HASKELL__ >= 810
-- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically
-- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the
-- doctests. See #874 for more details.
{-# OPTIONS_GHC -fbyte-code #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Data.Lens
-- Copyright   :  (C) 2012-2016 Edward Kmett, (C) 2006-2012 Neil Mitchell
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  Rank2Types
--
-- Smart and naïve generic traversals given 'Data' instances.
--
-- 'template', 'uniplate', and 'biplate' each build up information about what
-- types can be contained within another type to speed up 'Traversal'.
--
----------------------------------------------------------------------------
module Data.Data.Lens
  (
  -- * Generic Traversal
    template
  , tinplate
  , uniplate
  , biplate
  -- * Field Accessor Traversal
  , upon
  , upon'
  , onceUpon
  , onceUpon'
  -- * Data Traversal
  , 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

import qualified Data.Proxy as X (Proxy (..))
import qualified Data.Typeable as X (typeRep, eqT)
import qualified Data.Type.Equality as X

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Control.Lens.Internal.Doctest
-- >>> import Prelude hiding (head, tail)

-------------------------------------------------------------------------------
-- Generic Traversal
-------------------------------------------------------------------------------

-- | A generic applicative transformation that maps over the immediate subterms.
--
-- 'gtraverse' is to 'traverse' what 'gmapM' is to 'mapM'
--
-- This really belongs in @Data.Data@.
gtraverse :: (Applicative f, Data a) => (forall d. Data d => d -> f d) -> a -> f a
gtraverse :: forall (f :: * -> *) a.
(Applicative f, Data a) =>
(forall d. Data d => d -> f d) -> a -> f a
gtraverse forall d. Data d => d -> f 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 (\f (d -> b)
x d
y -> f (d -> b)
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
f d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE gtraverse #-}

-------------------------------------------------------------------------------
-- Naïve Traversal
-------------------------------------------------------------------------------

-- | Naïve 'Traversal' using 'Data'. This does not attempt to optimize the traversal.
--
-- This is primarily useful when the children are immediately obvious, and for benchmarking.
tinplate :: (Data s, Typeable a) => Traversal' s a
tinplate :: forall s a. (Data s, Typeable a) => Traversal' s a
tinplate a -> f a
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 s a (f :: * -> *) r.
(Applicative f, Typeable a, Data s) =>
(a -> f a) -> f (s -> r) -> s -> f r
step a -> f a
f) forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall s a (f :: * -> *) r.
(Applicative f, Typeable a, Data s) =>
(a -> f a) -> f (s -> r) -> s -> f r
step a -> f a
f f (s -> r)
w s
s = f (s -> r)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
X.eqT :: Maybe (s X.:~: a) of
  Just s :~: a
X.Refl -> a -> f a
f s
s
  Maybe (s :~: a)
Nothing   -> forall s a. (Data s, Typeable a) => Traversal' s a
tinplate a -> f a
f s
s
{-# INLINE step #-}

-------------------------------------------------------------------------------
-- Smart Traversal
-------------------------------------------------------------------------------

-- | Find every occurrence of a given type @a@ recursively that doesn't require
-- passing through something of type @a@ using 'Data', while avoiding traversal
-- of areas that cannot contain a value of type @a@.
--
-- This is 'uniplate' with a more liberal signature.
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template :: forall s a. (Data s, Typeable a) => Traversal' s a
template = forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData (forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (forall a. HasCallStack => a
undefined :: s) (forall a. HasCallStack => a
undefined :: a)
{-# INLINE template #-}

-- | Find descendants of type @a@ non-transitively, while avoiding computation of areas that cannot contain values of
-- type @a@ using 'Data'.
--
-- 'uniplate' is a useful default definition for 'Control.Lens.Plated.plate'
uniplate :: Data a => Traversal' a a
uniplate :: forall a. Data a => Traversal' a a
uniplate = forall s a. (Data s, Typeable a) => Traversal' s a
template
{-# INLINE uniplate #-}

-- | 'biplate' performs like 'template', except when @s ~ a@, it returns itself and nothing else.
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate :: forall s a. (Data s, Typeable a) => Traversal' s a
biplate = forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData (forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (forall a. HasCallStack => a
undefined :: s) (forall a. HasCallStack => a
undefined :: a)
{-# INLINE biplate #-}

------------------------------------------------------------------------------
-- Automatic Traversal construction from field accessors
------------------------------------------------------------------------------

data FieldException a = FieldException !Int a

instance Show (FieldException a) where
  showsPrec :: Int -> FieldException a -> ShowS
showsPrec Int
d (FieldException Int
i a
_) = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"<field " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'>'

instance Typeable a => Exception (FieldException a)

lookupon :: Typeable a => LensLike' (Indexing Identity) s a -> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon :: forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon LensLike' (Indexing Identity) s a
l s -> a
field s
s = case forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ s -> a
field forall a b. (a -> b) -> a -> b
$ s
s forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a (f :: * -> *) b s t.
Indexable Int p =>
((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t
indexing LensLike' (Indexing Identity) s a
l forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ \Int
i (a
a::a) -> forall a e. Exception e => e -> a
E.throw (forall a. Int -> a -> FieldException a
FieldException Int
i a
a) of
  Right a
_ -> forall a. Maybe a
Nothing
  Left SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Maybe (FieldException a)
Nothing -> forall a. Maybe a
Nothing
    Just (FieldException Int
i a
a) -> forall a. a -> Maybe a
Just (Int
i, forall a b t. (b -> t) -> a -> Context a b t
Context (\a
a' -> forall s t a b. ASetter s t a b -> b -> s -> t
set (forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf LensLike' (Indexing Identity) s a
l Int
i) a
a' s
s) a
a)
{-# INLINE lookupon #-}


-- | This automatically constructs a 'Traversal'' from an function.
--
-- >>> (2,4) & upon fst *~ 5
-- (10,4)
--
-- There are however, caveats on how this function can be used!
--
-- First, the user supplied function must access only one field of the specified type. That is to say the target
-- must be a single element that would be visited by @'holesOnOf' 'template' 'uniplate'@
--
-- Note: this even permits a number of functions to be used directly.
--
-- >>> [1,2,3,4] & upon head .~ 0
-- [0,2,3,4]
--
-- >>> [1,2,3,4] & upon last .~ 5
-- [1,2,3,5]
--
-- >>> [1,2,3,4] ^? upon tail
-- Just [2,3,4]
--
-- >>> "" ^? upon tail
-- Nothing
--
-- Accessing parents on the way down to children is okay:
--
-- >>> [1,2,3,4] & upon (tail.tail) .~ [10,20]
-- [1,2,10,20]
--
-- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data'
--
-- @'upon' :: ('Data' s, 'Data' a) => (s -> a) -> 'IndexedTraversal'' [Int] s a@
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 :: forall (p :: * -> * -> *) (f :: * -> *) s a.
(Indexable [Int] p, Applicative f, Data s, Data a) =>
(s -> a) -> p a (f a) -> s -> f s
upon s -> a
field p a (f a)
f s
s = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
  Just (Int
i, Context a -> s
k0 a
a0) ->
    let
      go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s
      go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go [Int]
is Traversal' s a
l a -> s
k a
a = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
        Maybe (Int, Context a a s)
Nothing                 -> a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f (forall a. [a] -> [a]
reverse [Int]
is) a
a
        Just (Int
j, Context a -> s
k' a
a') -> [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go (Int
jforall a. a -> [a] -> [a]
:[Int]
is) (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall a. Data a => Traversal' a a
uniplate Int
j) a -> s
k' a
a'
    in [Int] -> Traversal' s a -> (a -> s) -> a -> f s
go [Int
i] (forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall s a. (Data s, Typeable a) => Traversal' s a
template Int
i) a -> s
k0 a
a0
{-# INLINE upon #-}

-- | The design of 'onceUpon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.
-- 'upon'' provides this additional recursion.
--
-- Like 'onceUpon'', 'upon'' trusts the user supplied function more than 'upon' using it directly
-- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of
-- generating an illegal lens.
--
-- >>> upon' (tail.tail) .~ [10,20] $ [1,2,3,4]
-- [1,2,10,20]
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a
upon' s -> a
field p a (f a)
f s
s = let
    ~([Int]
isn, a -> s
kn) = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing -> (forall a. HasCallStack => String -> a
error String
"upon': no index, not a member", forall a b. a -> b -> a
const s
s)
      Just (Int
i, Context a -> s
k0 a
_) -> [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go [Int
i] (forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall s a. (Data s, Typeable a) => Traversal' s a
template Int
i) a -> s
k0
    go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
    go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go [Int]
is Traversal' s a
l a -> s
k = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Data a => Traversal' a a
uniplate) s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing                -> (forall a. [a] -> [a]
reverse [Int]
is, a -> s
k)
      Just (Int
j, Context a -> s
k' a
_) -> [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s)
go (Int
jforall a. a -> [a] -> [a]
:[Int]
is) (Traversal' s a
lforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) s t a.
Applicative f =>
LensLike (Indexing f) s t a a
-> Int -> IndexedLensLike Int f s t a a
elementOf forall a. Data a => Traversal' a a
uniplate Int
j) a -> s
k'
  in a -> s
kn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f [Int]
isn (s -> a
field s
s)
{-# INLINE upon' #-}

-- | This automatically constructs a 'Traversal'' from a field accessor.
--
-- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexing' 'template')@ or into the list
-- returned by @'holesOf' 'template'@.
--
-- The design of 'onceUpon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.
-- 'upon' provides this additional recursion, but at the expense of performance.
--
-- >>> onceUpon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD
-- [1,10,20]
--
-- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD
-- [1,2,10,20]
--
-- When in doubt, use 'upon' instead.
onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedTraversal' Int s a
onceUpon :: forall s a.
(Data s, Typeable a) =>
(s -> a) -> IndexedTraversal' Int s a
onceUpon s -> a
field p a (f a)
f s
s = case forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
  Just (Int
i, Context a -> s
k a
a) -> a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f Int
i a
a
{-# INLINE onceUpon #-}

-- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'.
--
-- This means that reading from 'upon'' is considerably faster than 'upon'.
--
-- However, you pay for faster access in two ways:
--
-- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates
--    the laws, unlike 'upon', which will give you a legal 'Traversal' that avoids modifying the target.
--
-- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact.
--
-- When given a legal field accessor, the index of the 'Lens' can be used as an offset into
-- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@.
--
-- When in doubt, use 'upon'' instead.
onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedLens' Int s a
onceUpon' :: forall s a.
(Data s, Typeable a) =>
(s -> a) -> IndexedLens' Int s a
onceUpon' s -> a
field p a (f a)
f s
s = a -> s
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f Int
i (s -> a
field s
s) where
  ~(Int
i, Context a -> s
k a
_) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"upon': no index, not a member") (forall a s.
Typeable a =>
LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
lookupon forall s a. (Data s, Typeable a) => Traversal' s a
template s -> a
field s
s)
{-# INLINE onceUpon' #-}

-------------------------------------------------------------------------------
-- Data Box
-------------------------------------------------------------------------------

data DataBox = forall a. Data a => DataBox
  { DataBox -> TypeRep
dataBoxKey :: TypeRep
  , ()
_dataBoxVal :: a
  }

dataBox :: Data a => a -> DataBox
dataBox :: forall a. Data a => a -> DataBox
dataBox a
a = forall a. Data a => TypeRep -> a -> DataBox
DataBox (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep [a
a]) a
a
{-# INLINE dataBox #-}

-- partial, caught elsewhere
sybChildren :: Data a => a -> [DataBox]
sybChildren :: forall a. Data a => a -> [DataBox]
sybChildren a
x
  | DataType -> Bool
isAlgType DataType
dt = do
    Constr
c <- DataType -> [Constr]
dataTypeConstrs DataType
dt
    forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> DataBox
dataBox (forall a. Data a => Constr -> a
fromConstr Constr
c forall a. a -> a -> a
`asTypeOf` a
x)
  | Bool
otherwise = []
  where dt :: DataType
dt = forall a. Data a => a -> DataType
dataTypeOf a
x
{-# INLINE sybChildren #-}

-------------------------------------------------------------------------------
-- HitMap
-------------------------------------------------------------------------------

type HitMap = HashMap TypeRep (HashSet TypeRep)

emptyHitMap :: HitMap
emptyHitMap :: HitMap
emptyHitMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList
  [ (TypeRep
tRational, forall a. Hashable a => a -> HashSet a
S.singleton TypeRep
tInteger)
  , (TypeRep
tInteger,  forall a. HashSet a
S.empty)
  ] where
  tRational :: TypeRep
tRational = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (forall {k} (t :: k). Proxy t
X.Proxy :: X.Proxy Rational)
  tInteger :: TypeRep
tInteger  = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
X.typeRep (forall {k} (t :: k). Proxy t
X.Proxy :: X.Proxy Integer )

insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap :: DataBox -> HitMap -> HitMap
insertHitMap DataBox
box HitMap
hit = forall a. Eq a => (a -> a) -> a -> a
fixEq HitMap -> HitMap
trans (DataBox -> HitMap
populate DataBox
box) forall a. Monoid a => a -> a -> a
`mappend` HitMap
hit where
  populate :: DataBox -> HitMap
  populate :: DataBox -> HitMap
populate DataBox
a = DataBox -> HitMap -> HitMap
f DataBox
a forall k v. HashMap k v
M.empty where
    f :: DataBox -> HitMap -> HitMap
f (DataBox TypeRep
k a
v) HitMap
m
      | forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
hit Bool -> Bool -> Bool
|| forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
M.member TypeRep
k HitMap
m = HitMap
m
      | [DataBox]
cs <- forall a. Data a => a -> [DataBox]
sybChildren a
v = [DataBox] -> HitMap -> HitMap
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
M.insert TypeRep
k (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DataBox -> TypeRep
dataBoxKey [DataBox]
cs) HitMap
m
    fs :: [DataBox] -> HitMap -> HitMap
fs []     HitMap
m = HitMap
m
    fs (DataBox
x:[DataBox]
xs) HitMap
m = [DataBox] -> HitMap -> HitMap
fs [DataBox]
xs (DataBox -> HitMap -> HitMap
f DataBox
x HitMap
m)

  trans :: HitMap -> HitMap
  trans :: HitMap -> HitMap
trans HitMap
m = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map HashSet TypeRep -> HashSet TypeRep
f HitMap
m where
    f :: HashSet TypeRep -> HashSet TypeRep
f HashSet TypeRep
x = HashSet TypeRep
x forall a. Monoid a => a -> a -> a
`mappend` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeRep -> HashSet TypeRep
g HashSet TypeRep
x
    g :: TypeRep -> HashSet TypeRep
g TypeRep
x = forall a. a -> Maybe a -> a
fromMaybe (HitMap
hit forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
x HitMap
m)

fixEq :: Eq a => (a -> a) -> a -> a
fixEq :: forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f = a -> a
go where
  go :: a -> a
go a
x | a
x forall a. Eq a => a -> a -> Bool
== a
x'   = a
x'
       | Bool
otherwise = a -> a
go a
x'
       where x' :: a
x' = a -> a
f a
x
{-# INLINE fixEq #-}

-- | inlineable 'unsafePerformIO'
inlinePerformIO :: IO a -> a
inlinePerformIO :: forall a. IO a -> a
inlinePerformIO (IO State# RealWorld -> (# State# RealWorld, a #)
m) = case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
realWorld# of
  (# State# RealWorld
_, a
r #) -> a
r
{-# INLINE inlinePerformIO #-}

-------------------------------------------------------------------------------
-- Cache
-------------------------------------------------------------------------------

data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower)))

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
$ HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
emptyHitMap forall k v. HashMap k v
M.empty
{-# NOINLINE cache #-}

readCacheFollower :: DataBox -> TypeRep -> Maybe Follower
readCacheFollower :: DataBox -> TypeRep -> Maybe Follower
readCacheFollower b :: DataBox
b@(DataBox TypeRep
kb a
_) TypeRep
ka = forall a. IO a -> a
inlinePerformIO forall a b. (a -> b) -> a -> b
$
  forall a. IORef a -> IO a
readIORef IORef Cache
cache forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (Cache HitMap
hm HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m) -> case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup TypeRep
kb HashMap TypeRep (HashMap TypeRep (Maybe Follower))
m 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
M.lookup TypeRep
ka of
    Just Maybe Follower
a -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Follower
a
    Maybe (Maybe Follower)
Nothing -> forall e a. Exception e => IO a -> IO (Either e a)
E.try (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! DataBox -> HitMap -> HitMap
insertHitMap DataBox
b HitMap
hm) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either SomeException HitMap
r -> case Either SomeException HitMap
r of
      Left SomeException{}                         -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache forall a b. (a -> b) -> a -> b
$ \(Cache HitMap
hm' HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n) -> (HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
hm' (forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
kb TypeRep
ka forall a. Maybe a
Nothing HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n), forall a. Maybe a
Nothing)
      Right HitMap
hm' | Maybe Follower
fol <- forall a. a -> Maybe a
Just (TypeRep -> TypeRep -> HitMap -> Follower
follower TypeRep
kb TypeRep
ka HitMap
hm') -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Cache
cache forall a b. (a -> b) -> a -> b
$ \(Cache HitMap
_ HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n) -> (HitMap
-> HashMap TypeRep (HashMap TypeRep (Maybe Follower)) -> Cache
Cache HitMap
hm' (forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
kb TypeRep
ka Maybe Follower
fol HashMap TypeRep (HashMap TypeRep (Maybe Follower))
n),    Maybe Follower
fol)

insert2 :: TypeRep -> TypeRep -> a -> HashMap TypeRep (HashMap TypeRep a) -> HashMap TypeRep (HashMap TypeRep a)
insert2 :: forall a.
TypeRep
-> TypeRep
-> a
-> HashMap TypeRep (HashMap TypeRep a)
-> HashMap TypeRep (HashMap TypeRep a)
insert2 TypeRep
x TypeRep
y a
v = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.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
M.insert TypeRep
y a
v) TypeRep
x (forall k v. Hashable k => k -> v -> HashMap k v
M.singleton TypeRep
y a
v)
{-# INLINE insert2 #-}

{-
readCacheHitMap :: DataBox -> Maybe HitMap
readCacheHitMap b@(DataBox kb _) = inlinePerformIO $
  readIORef cache >>= \ (Cache hm _) -> case M.lookup kb hm of
    Just _  -> return $ Just hm
    Nothing -> E.try (return $! insertHitMap b hm) >>= \r -> case r of
      Left SomeException{} -> return Nothing
      Right hm' -> atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hm' follow, Just hm')
-}

-------------------------------------------------------------------------------
-- Answers
-------------------------------------------------------------------------------

data Answer b a
  = b ~ a => Hit a
  | Follow
  | Miss

-------------------------------------------------------------------------------
-- Oracles
-------------------------------------------------------------------------------

newtype Oracle a = Oracle { forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle :: forall t. Typeable t => t -> Answer t a }

hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest a
a b
b = forall a. (forall t. Typeable t => t -> Answer t a) -> Oracle a
Oracle forall a b. (a -> b) -> a -> b
$ \(t
c :: c) ->
  case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
X.eqT :: Maybe (c X.:~: b) of
    Just t :~: b
X.Refl -> forall b a. (b ~ a) => a -> Answer b a
Hit t
c
    Maybe (t :~: b)
Nothing ->
      case DataBox -> TypeRep -> Maybe Follower
readCacheFollower (forall a. Data a => a -> DataBox
dataBox a
a) (forall a. Typeable a => a -> TypeRep
typeOf b
b) of
        Just Follower
p | Bool -> Bool
not (Follower
p (forall a. Typeable a => a -> TypeRep
typeOf t
c)) -> forall b a. Answer b a
Miss
        Maybe Follower
_ -> forall b a. Answer b a
Follow

-------------------------------------------------------------------------------
-- Traversals
-------------------------------------------------------------------------------


biplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData :: forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData forall c. Typeable c => c -> Answer c a
o a -> f a
f = forall d. Data d => d -> f d
go2 where
  go :: Data d => d -> f d
  go :: forall d. Data d => d -> f d
go = 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 (\f (d -> b)
x d
y -> f (d -> b)
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
go2 d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
  go2 :: Data d => d -> f d
  go2 :: forall d. Data d => d -> f d
go2 d
s = case forall c. Typeable c => c -> Answer c a
o d
s of
    Hit a
a  -> a -> f a
f a
a
    Answer d a
Follow -> forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure d
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 :: forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData forall c. Typeable c => c -> Answer c a
o a -> f a
f = forall d. Data d => d -> f d
go where
  go :: Data d => d -> f d
  go :: forall d. Data d => d -> f d
go = 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 (\f (d -> b)
x d
y -> f (d -> b)
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall d. Data d => d -> f d
go2 d
y) forall (f :: * -> *) a. Applicative f => a -> f a
pure
  go2 :: Data d => d -> f d
  go2 :: forall d. Data d => d -> f d
go2 d
s = case forall c. Typeable c => c -> Answer c a
o d
s of
    Hit a
a  -> a -> f a
f a
a
    Answer d a
Follow -> forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure d
s
{-# INLINE uniplateData #-}

-------------------------------------------------------------------------------
-- Follower
-------------------------------------------------------------------------------

part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part :: forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part a -> Bool
p HashSet a
s = (forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter a -> Bool
p HashSet a
s, forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) HashSet a
s)
{-# INLINE part #-}

type Follower = TypeRep -> Bool

follower :: TypeRep -> TypeRep -> HitMap -> Follower
follower :: TypeRep -> TypeRep -> HitMap -> Follower
follower TypeRep
a TypeRep
b HitMap
m
  | forall a. HashSet a -> Bool
S.null HashSet TypeRep
hit               = forall a b. a -> b -> a
const Bool
False
  | forall a. HashSet a -> Bool
S.null HashSet TypeRep
miss              = forall a b. a -> b -> a
const Bool
True
  | forall a. HashSet a -> Int
S.size HashSet TypeRep
hit forall a. Ord a => a -> a -> Bool
< forall a. HashSet a -> Int
S.size HashSet TypeRep
miss = forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? HashSet TypeRep
hit
  | Bool
otherwise = \TypeRep
k -> Bool -> Bool
not (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
k HashSet TypeRep
miss)
  where (HashSet TypeRep
hit, HashSet TypeRep
miss) = forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part (\TypeRep
x -> forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TypeRep
b (HitMap
m forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
x)) (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
S.insert TypeRep
a (HitMap
m forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! TypeRep
a))