{-# 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 #-}
-----------------------------------------------------------------------------
-- |
-- 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 d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> a -> f a
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
forall (c :: * -> *).
(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 f (d -> b) -> f d -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
f d
y) g -> f g
forall g. g -> f g
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 d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> s -> f s
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> s -> c s
gfoldl ((a -> f a) -> f (d -> b) -> d -> f b
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) g -> f g
forall g. g -> f g
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 f (s -> r) -> f s -> f r
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case Maybe (s :~: a)
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
a
s
  Maybe (s :~: a)
Nothing   -> (a -> f a) -> s -> f s
forall s a. (Data s, Typeable a) => Traversal' s 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 c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
uniplateData (Oracle a -> forall c. Typeable c => c -> Answer c a
forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = s -> a -> Oracle a
forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (s
forall a. HasCallStack => a
undefined :: s) (a
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 = (a -> f a) -> a -> f a
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' a 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 c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
forall (f :: * -> *) s a.
(Applicative f, Data s) =>
(forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s
biplateData (Oracle a -> forall c. Typeable c => c -> Answer c a
forall a. Oracle a -> forall t. Typeable t => t -> Answer t a
fromOracle Oracle a
answer) where
  answer :: Oracle a
answer = s -> a -> Oracle a
forall a b. (Data a, Typeable b) => a -> b -> Oracle b
hitTest (s
forall a. HasCallStack => a
undefined :: s) (a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"<field " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Int
i ShowS -> ShowS -> ShowS
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 IO (Either SomeException a) -> Either SomeException a
forall a. IO a -> a
unsafePerformIO (IO (Either SomeException a) -> Either SomeException a)
-> IO (Either SomeException a) -> Either SomeException a
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ s -> a
field (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& LensLike' (Indexing Identity) s a
-> Indexed Int a (Identity a) -> s -> Identity s
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 (Indexed Int a (Identity a) -> s -> Identity s)
-> (Int -> a -> a) -> s -> s
forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ \Int
i (a
a::a) -> FieldException a -> a
forall a e. (HasCallStack, Exception e) => e -> a
E.throw (Int -> a -> FieldException a
forall a. Int -> a -> FieldException a
FieldException Int
i a
a) of
  Right a
_ -> Maybe (Int, Context a a s)
forall a. Maybe a
Nothing
  Left SomeException
e -> case SomeException -> Maybe (FieldException a)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Maybe (FieldException a)
Nothing -> Maybe (Int, Context a a s)
forall a. Maybe a
Nothing
    Just (FieldException Int
i a
a) -> (Int, Context a a s) -> Maybe (Int, Context a a s)
forall a. a -> Maybe a
Just (Int
i, (a -> s) -> a -> Context a a s
forall a b t. (b -> t) -> a -> Context a b t
Context (\a
a' -> ASetter s s a a -> a -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set (LensLike' (Indexing Identity) s a
-> Int -> IndexedLensLike Int Identity s s a a
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 LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing -> s -> f s
forall a. a -> f a
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 LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
Traversal' s a
lLensLike' (Indexing Identity) s a
-> ((a -> Indexing Identity a) -> a -> Indexing Identity a)
-> LensLike' (Indexing Identity) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Indexing Identity a) -> a -> Indexing Identity a
forall a. Data a => Traversal' a a
Traversal' a a
uniplate) s -> a
field s
s of
        Maybe (Int, Context a a s)
Nothing                 -> a -> s
k (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> [Int] -> a -> f a
forall a b. p a b -> [Int] -> a -> b
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f ([Int] -> [Int]
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
jInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) ((a -> f a) -> s -> f s
Traversal' s a
l((a -> f a) -> s -> f s)
-> ((a -> f a) -> a -> f a) -> (a -> f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LensLike (Indexing f) a a a a
-> Int -> IndexedLensLike Int f a a a a
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 f) a a a a
forall a. Data a => Traversal' a 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] (LensLike (Indexing f) s s a a
-> Int -> IndexedLensLike Int f s s a a
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 f) s s a a
forall s a. (Data s, Typeable a) => Traversal' s 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 LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' s a
template s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing -> (String -> [Int]
forall a. HasCallStack => String -> a
error String
"upon': no index, not a member", s -> a -> s
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] (LensLike (Indexing f) s s a a
-> Int -> IndexedLensLike Int f s s a a
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 f) s s a a
forall s a. (Data s, Typeable a) => Traversal' s 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 LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
Traversal' s a
lLensLike' (Indexing Identity) s a
-> ((a -> Indexing Identity a) -> a -> Indexing Identity a)
-> LensLike' (Indexing Identity) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Indexing Identity a) -> a -> Indexing Identity a
forall a. Data a => Traversal' a a
Traversal' a a
uniplate) s -> a
field s
s of
      Maybe (Int, Context a a s)
Nothing                -> ([Int] -> [Int]
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
jInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) ((a -> f a) -> s -> f s
Traversal' s a
l((a -> f a) -> s -> f s)
-> ((a -> f a) -> a -> f a) -> (a -> f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LensLike (Indexing f) a a a a
-> Int -> IndexedLensLike Int f a a a a
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 f) a a a a
forall a. Data a => Traversal' a a
Traversal' a a
uniplate Int
j) a -> s
k'
  in a -> s
kn (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> [Int] -> a -> f a
forall a b. p a b -> [Int] -> a -> 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 LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' s a
template s -> a
field s
s of
  Maybe (Int, Context a a s)
Nothing               -> s -> f s
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s
  Just (Int
i, Context a -> s
k a
a) -> a -> s
k (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> Int -> a -> f a
forall a b. p a b -> Int -> a -> 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 (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a (f a) -> Int -> a -> f a
forall a b. p a b -> Int -> a -> 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
_) = (Int, Context a a s)
-> Maybe (Int, Context a a s) -> (Int, Context a a s)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Int, Context a a s)
forall a. HasCallStack => String -> a
error String
"upon': no index, not a member") (LensLike' (Indexing Identity) s a
-> (s -> a) -> s -> Maybe (Int, Context a a s)
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
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' s a
template s -> a
field s
s)
{-# INLINE onceUpon' #-}

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

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

dataBox :: Data a => a -> DataBox
dataBox :: forall a. Data a => a -> DataBox
dataBox a
a = SomeTypeRep -> a -> DataBox
forall a. Data a => SomeTypeRep -> a -> DataBox
DataBox ([a] -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
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
    c <- DataType -> [Constr]
dataTypeConstrs DataType
dt
    gmapQ dataBox (fromConstr c `asTypeOf` x)
  | Bool
otherwise = []
  where dt :: DataType
dt = a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
x
{-# INLINE sybChildren #-}

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

type HitMap = HashMap TypeRep (HashSet TypeRep)

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

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

  trans :: HitMap -> HitMap
  trans :: HashMap SomeTypeRep (HashSet SomeTypeRep)
-> HashMap SomeTypeRep (HashSet SomeTypeRep)
trans HashMap SomeTypeRep (HashSet SomeTypeRep)
m = (HashSet SomeTypeRep -> HashSet SomeTypeRep)
-> HashMap SomeTypeRep (HashSet SomeTypeRep)
-> HashMap SomeTypeRep (HashSet SomeTypeRep)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map HashSet SomeTypeRep -> HashSet SomeTypeRep
f HashMap SomeTypeRep (HashSet SomeTypeRep)
m where
    f :: HashSet SomeTypeRep -> HashSet SomeTypeRep
f HashSet SomeTypeRep
x = HashSet SomeTypeRep
x HashSet SomeTypeRep -> HashSet SomeTypeRep -> HashSet SomeTypeRep
forall a. Monoid a => a -> a -> a
`mappend` (SomeTypeRep -> HashSet SomeTypeRep)
-> HashSet SomeTypeRep -> HashSet SomeTypeRep
forall m a. Monoid m => (a -> m) -> HashSet a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SomeTypeRep -> HashSet SomeTypeRep
g HashSet SomeTypeRep
x
    g :: SomeTypeRep -> HashSet SomeTypeRep
g SomeTypeRep
x = HashSet SomeTypeRep
-> Maybe (HashSet SomeTypeRep) -> HashSet SomeTypeRep
forall a. a -> Maybe a -> a
fromMaybe (HashMap SomeTypeRep (HashSet SomeTypeRep)
hit HashMap SomeTypeRep (HashSet SomeTypeRep)
-> SomeTypeRep -> HashSet SomeTypeRep
forall k v. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! SomeTypeRep
x) (SomeTypeRep
-> HashMap SomeTypeRep (HashSet SomeTypeRep)
-> Maybe (HashSet SomeTypeRep)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
M.lookup SomeTypeRep
x HashMap SomeTypeRep (HashSet SomeTypeRep)
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 a -> a -> Bool
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 = IO (IORef Cache) -> IORef Cache
forall a. IO a -> a
unsafePerformIO (IO (IORef Cache) -> IORef Cache)
-> IO (IORef Cache) -> IORef Cache
forall a b. (a -> b) -> a -> b
$ Cache -> IO (IORef Cache)
forall a. a -> IO (IORef a)
newIORef (Cache -> IO (IORef Cache)) -> Cache -> IO (IORef Cache)
forall a b. (a -> b) -> a -> b
$ HashMap SomeTypeRep (HashSet SomeTypeRep)
-> HashMap SomeTypeRep (HashMap SomeTypeRep (Maybe Follower))
-> Cache
Cache HashMap SomeTypeRep (HashSet SomeTypeRep)
emptyHitMap HashMap SomeTypeRep (HashMap SomeTypeRep (Maybe Follower))
forall k v. HashMap k v
M.empty
{-# NOINLINE cache #-}

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

insert2 :: TypeRep -> TypeRep -> a -> HashMap TypeRep (HashMap TypeRep a) -> HashMap TypeRep (HashMap TypeRep a)
insert2 :: forall a.
SomeTypeRep
-> SomeTypeRep
-> a
-> HashMap SomeTypeRep (HashMap SomeTypeRep a)
-> HashMap SomeTypeRep (HashMap SomeTypeRep a)
insert2 SomeTypeRep
x SomeTypeRep
y a
v = (HashMap SomeTypeRep a
 -> HashMap SomeTypeRep a -> HashMap SomeTypeRep a)
-> SomeTypeRep
-> HashMap SomeTypeRep a
-> HashMap SomeTypeRep (HashMap SomeTypeRep a)
-> HashMap SomeTypeRep (HashMap SomeTypeRep a)
forall k v.
Hashable k =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith ((HashMap SomeTypeRep a -> HashMap SomeTypeRep a)
-> HashMap SomeTypeRep a
-> HashMap SomeTypeRep a
-> HashMap SomeTypeRep a
forall a b. a -> b -> a
const ((HashMap SomeTypeRep a -> HashMap SomeTypeRep a)
 -> HashMap SomeTypeRep a
 -> HashMap SomeTypeRep a
 -> HashMap SomeTypeRep a)
-> (HashMap SomeTypeRep a -> HashMap SomeTypeRep a)
-> HashMap SomeTypeRep a
-> HashMap SomeTypeRep a
-> HashMap SomeTypeRep a
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> a -> HashMap SomeTypeRep a -> HashMap SomeTypeRep a
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
M.insert SomeTypeRep
y a
v) SomeTypeRep
x (SomeTypeRep -> a -> HashMap SomeTypeRep a
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton SomeTypeRep
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 t. Typeable t => t -> Answer t b) -> Oracle b
forall a. (forall t. Typeable t => t -> Answer t a) -> Oracle a
Oracle ((forall t. Typeable t => t -> Answer t b) -> Oracle b)
-> (forall t. Typeable t => t -> Answer t b) -> Oracle b
forall a b. (a -> b) -> a -> b
$ \(t
c :: c) ->
  case Maybe (t :~: b)
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 -> b -> Answer t b
forall b a. (b ~ a) => a -> Answer b a
Hit b
t
c
    Maybe (t :~: b)
Nothing ->
      case DataBox -> SomeTypeRep -> Maybe Follower
readCacheFollower (a -> DataBox
forall a. Data a => a -> DataBox
dataBox a
a) (b -> SomeTypeRep
forall a. Typeable a => a -> SomeTypeRep
typeOf b
b) of
        Just Follower
p | Bool -> Bool
not (Follower
p (t -> SomeTypeRep
forall a. Typeable a => a -> SomeTypeRep
typeOf t
c)) -> Answer t b
forall b a. Answer b a
Miss
        Maybe Follower
_ -> Answer t b
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 = s -> f s
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 d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> d -> f d
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> d -> c d
gfoldl (\f (d -> b)
x d
y -> f (d -> b)
x f (d -> b) -> f d -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
go2 d
y) g -> f g
forall g. g -> f g
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 d -> Answer d a
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 -> d -> f d
forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> d -> f d
forall g. g -> f g
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 = s -> f s
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 d b. Data d => f (d -> b) -> d -> f b)
-> (forall g. g -> f g) -> d -> f d
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> d -> c d
gfoldl (\f (d -> b)
x d
y -> f (d -> b)
x f (d -> b) -> f d -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> d -> f d
forall d. Data d => d -> f d
go2 d
y) g -> f g
forall g. g -> f g
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 d -> Answer d a
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 -> d -> f d
forall d. Data d => d -> f d
go d
s
    Answer d a
Miss   -> d -> f d
forall g. g -> f g
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 = ((a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter a -> Bool
p HashSet a
s, (a -> Bool) -> HashSet a -> HashSet a
forall a. (a -> Bool) -> HashSet a -> HashSet a
S.filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
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 :: SomeTypeRep
-> SomeTypeRep
-> HashMap SomeTypeRep (HashSet SomeTypeRep)
-> Follower
follower SomeTypeRep
a SomeTypeRep
b HashMap SomeTypeRep (HashSet SomeTypeRep)
m
  | HashSet SomeTypeRep -> Bool
forall a. HashSet a -> Bool
S.null HashSet SomeTypeRep
hit               = Bool -> Follower
forall a b. a -> b -> a
const Bool
False
  | HashSet SomeTypeRep -> Bool
forall a. HashSet a -> Bool
S.null HashSet SomeTypeRep
miss              = Bool -> Follower
forall a b. a -> b -> a
const Bool
True
  | HashSet SomeTypeRep -> Int
forall a. HashSet a -> Int
S.size HashSet SomeTypeRep
hit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< HashSet SomeTypeRep -> Int
forall a. HashSet a -> Int
S.size HashSet SomeTypeRep
miss = SomeTypeRep -> HashSet SomeTypeRep -> Bool
forall a. Hashable a => a -> HashSet a -> Bool
S.member (SomeTypeRep -> HashSet SomeTypeRep -> Bool)
-> HashSet SomeTypeRep -> Follower
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? HashSet SomeTypeRep
hit
  | Bool
otherwise = \SomeTypeRep
k -> Bool -> Bool
not (SomeTypeRep -> HashSet SomeTypeRep -> Bool
forall a. Hashable a => a -> HashSet a -> Bool
S.member SomeTypeRep
k HashSet SomeTypeRep
miss)
  where (HashSet SomeTypeRep
hit, HashSet SomeTypeRep
miss) = Follower
-> HashSet SomeTypeRep
-> (HashSet SomeTypeRep, HashSet SomeTypeRep)
forall a. (a -> Bool) -> HashSet a -> (HashSet a, HashSet a)
part (\SomeTypeRep
x -> SomeTypeRep -> HashSet SomeTypeRep -> Bool
forall a. Hashable a => a -> HashSet a -> Bool
S.member SomeTypeRep
b (HashMap SomeTypeRep (HashSet SomeTypeRep)
m HashMap SomeTypeRep (HashSet SomeTypeRep)
-> SomeTypeRep -> HashSet SomeTypeRep
forall k v. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! SomeTypeRep
x)) (SomeTypeRep -> HashSet SomeTypeRep -> HashSet SomeTypeRep
forall a. Hashable a => a -> HashSet a -> HashSet a
S.insert SomeTypeRep
a (HashMap SomeTypeRep (HashSet SomeTypeRep)
m HashMap SomeTypeRep (HashSet SomeTypeRep)
-> SomeTypeRep -> HashSet SomeTypeRep
forall k v. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! SomeTypeRep
a))