{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TypeFamilies          #-}

{- |
Copyright:  (c) 2017-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

TypeRepMap implementation based on Vector.
-}

module Data.TypeRep.Vector
       ( TypeRepVector (..)
       , TF (..)
       , empty
       , insert
       , lookup
       , size
       , fromList
       ) where

import Prelude hiding (lookup)

import Control.Arrow ((&&&))
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
import Data.Word (Word64)
import GHC.Base hiding (empty)
import GHC.Exts (sortWith)
import GHC.Fingerprint (Fingerprint (..))
import Unsafe.Coerce (unsafeCoerce)

import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Unboxed as Unboxed


data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)
data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)

instance Unboxed.Unbox Fingerprint

instance M.MVector Unboxed.MVector Fingerprint where
    {-# INLINE basicLength  #-}
    basicLength :: forall s. MVector s Fingerprint -> Int
basicLength (MFingerprintVector MVector s Word64
x MVector s Word64
_) = MVector s Word64 -> Int
forall s. MVector s Word64 -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
M.basicLength MVector s Word64
x
    {-# INLINE basicUnsafeSlice  #-}
    basicUnsafeSlice :: forall s.
Int -> Int -> MVector s Fingerprint -> MVector s Fingerprint
basicUnsafeSlice Int
i Int
m (MFingerprintVector MVector s Word64
a MVector s Word64
b) =
        MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
forall s.
MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
MFingerprintVector (Int -> Int -> MVector s Word64 -> MVector s Word64
forall s. Int -> Int -> MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
M.basicUnsafeSlice Int
i Int
m MVector s Word64
a) (Int -> Int -> MVector s Word64 -> MVector s Word64
forall s. Int -> Int -> MVector s Word64 -> MVector s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
M.basicUnsafeSlice Int
i Int
m MVector s Word64
b)
    {-# INLINE basicOverlaps  #-}
    basicOverlaps :: forall s. MVector s Fingerprint -> MVector s Fingerprint -> Bool
basicOverlaps (MFingerprintVector MVector s Word64
as1 MVector s Word64
bs1) (MFingerprintVector MVector s Word64
as2 MVector s Word64
bs2) =
        MVector s Word64 -> MVector s Word64 -> Bool
forall s. MVector s Word64 -> MVector s Word64 -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
M.basicOverlaps MVector s Word64
as1 MVector s Word64
as2 Bool -> Bool -> Bool
|| MVector s Word64 -> MVector s Word64 -> Bool
forall s. MVector s Word64 -> MVector s Word64 -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
M.basicOverlaps MVector s Word64
bs1 MVector s Word64
bs2
    {-# INLINE basicUnsafeNew  #-}
    basicUnsafeNew :: forall s. Int -> ST s (MVector s Fingerprint)
basicUnsafeNew Int
n_ = do
        MVector s Word64
as <- Int -> ST s (MVector s Word64)
forall s. Int -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s. MVector v a => Int -> ST s (v s a)
M.basicUnsafeNew Int
n_
        MVector s Word64
bs <- Int -> ST s (MVector s Word64)
forall s. Int -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s. MVector v a => Int -> ST s (v s a)
M.basicUnsafeNew Int
n_
        MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVector s Fingerprint -> ST s (MVector s Fingerprint))
-> MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
forall s.
MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
MFingerprintVector MVector s Word64
as MVector s Word64
bs
    {-# INLINE basicInitialize  #-}
    basicInitialize :: forall s. MVector s Fingerprint -> ST s ()
basicInitialize (MFingerprintVector MVector s Word64
as MVector s Word64
bs) = do
        MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> ST s ()
M.basicInitialize MVector s Word64
as
        MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> ST s ()
M.basicInitialize MVector s Word64
bs
    {-# INLINE basicUnsafeReplicate  #-}
    basicUnsafeReplicate :: forall s. Int -> Fingerprint -> ST s (MVector s Fingerprint)
basicUnsafeReplicate Int
n_ (Fingerprint Word64
a Word64
b) = do
        MVector s Word64
as <- Int -> Word64 -> ST s (MVector s Word64)
forall s. Int -> Word64 -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> a -> ST s (v s a)
M.basicUnsafeReplicate Int
n_ Word64
a
        MVector s Word64
bs <- Int -> Word64 -> ST s (MVector s Word64)
forall s. Int -> Word64 -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> a -> ST s (v s a)
M.basicUnsafeReplicate Int
n_ Word64
b
        MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVector s Fingerprint -> ST s (MVector s Fingerprint))
-> MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
forall s.
MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
MFingerprintVector MVector s Word64
as MVector s Word64
bs
    {-# INLINE basicUnsafeRead  #-}
    basicUnsafeRead :: forall s. MVector s Fingerprint -> Int -> ST s Fingerprint
basicUnsafeRead (MFingerprintVector MVector s Word64
as MVector s Word64
bs) Int
i_ = do
        Word64
a <- MVector s Word64 -> Int -> ST s Word64
forall s. MVector s Word64 -> Int -> ST s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> ST s a
M.basicUnsafeRead MVector s Word64
as Int
i_
        Word64
b <- MVector s Word64 -> Int -> ST s Word64
forall s. MVector s Word64 -> Int -> ST s Word64
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> ST s a
M.basicUnsafeRead MVector s Word64
bs Int
i_
        Fingerprint -> ST s Fingerprint
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word64 -> Fingerprint
Fingerprint Word64
a Word64
b)
    {-# INLINE basicUnsafeWrite  #-}
    basicUnsafeWrite :: forall s. MVector s Fingerprint -> Int -> Fingerprint -> ST s ()
basicUnsafeWrite (MFingerprintVector MVector s Word64
as MVector s Word64
bs) Int
i_ (Fingerprint Word64
a Word64
b) = do
        MVector s Word64 -> Int -> Word64 -> ST s ()
forall s. MVector s Word64 -> Int -> Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> a -> ST s ()
M.basicUnsafeWrite MVector s Word64
as Int
i_ Word64
a
        MVector s Word64 -> Int -> Word64 -> ST s ()
forall s. MVector s Word64 -> Int -> Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> a -> ST s ()
M.basicUnsafeWrite MVector s Word64
bs Int
i_ Word64
b
    {-# INLINE basicClear  #-}
    basicClear :: forall s. MVector s Fingerprint -> ST s ()
basicClear (MFingerprintVector MVector s Word64
as MVector s Word64
bs) = do
        MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> ST s ()
M.basicClear MVector s Word64
as
        MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> ST s ()
M.basicClear MVector s Word64
bs
    {-# INLINE basicSet  #-}
    basicSet :: forall s. MVector s Fingerprint -> Fingerprint -> ST s ()
basicSet (MFingerprintVector MVector s Word64
as MVector s Word64
bs) (Fingerprint Word64
a Word64
b) = do
        MVector s Word64 -> Word64 -> ST s ()
forall s. MVector s Word64 -> Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> a -> ST s ()
M.basicSet MVector s Word64
as Word64
a
        MVector s Word64 -> Word64 -> ST s ()
forall s. MVector s Word64 -> Word64 -> ST s ()
forall (v :: * -> * -> *) a s. MVector v a => v s a -> a -> ST s ()
M.basicSet MVector s Word64
bs Word64
b
    {-# INLINE basicUnsafeCopy  #-}
    basicUnsafeCopy :: forall s. MVector s Fingerprint -> MVector s Fingerprint -> ST s ()
basicUnsafeCopy (MFingerprintVector MVector s Word64
as1 MVector s Word64
bs1) (MFingerprintVector MVector s Word64
as2 MVector s Word64
bs2) = do
        MVector s Word64 -> MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> ST s ()
M.basicUnsafeCopy MVector s Word64
as1 MVector s Word64
as2
        MVector s Word64 -> MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> ST s ()
M.basicUnsafeCopy MVector s Word64
bs1 MVector s Word64
bs2
    {-# INLINE basicUnsafeMove  #-}
    basicUnsafeMove :: forall s. MVector s Fingerprint -> MVector s Fingerprint -> ST s ()
basicUnsafeMove (MFingerprintVector MVector s Word64
as1 MVector s Word64
bs1) (MFingerprintVector MVector s Word64
as2 MVector s Word64
bs2) = do
        MVector s Word64 -> MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> ST s ()
M.basicUnsafeMove MVector s Word64
as1 MVector s Word64
as2
        MVector s Word64 -> MVector s Word64 -> ST s ()
forall s. MVector s Word64 -> MVector s Word64 -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> ST s ()
M.basicUnsafeMove MVector s Word64
bs1 MVector s Word64
bs2
    {-# INLINE basicUnsafeGrow  #-}
    basicUnsafeGrow :: forall s.
MVector s Fingerprint -> Int -> ST s (MVector s Fingerprint)
basicUnsafeGrow (MFingerprintVector MVector s Word64
as MVector s Word64
bs) Int
m_ = do
        MVector s Word64
as' <- MVector s Word64 -> Int -> ST s (MVector s Word64)
forall s. MVector s Word64 -> Int -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> ST s (v s a)
M.basicUnsafeGrow MVector s Word64
as Int
m_
        MVector s Word64
bs' <- MVector s Word64 -> Int -> ST s (MVector s Word64)
forall s. MVector s Word64 -> Int -> ST s (MVector s Word64)
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> Int -> ST s (v s a)
M.basicUnsafeGrow MVector s Word64
bs Int
m_
        MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVector s Fingerprint -> ST s (MVector s Fingerprint))
-> MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
forall s.
MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
MFingerprintVector MVector s Word64
as' MVector s Word64
bs'

instance G.Vector Unboxed.Vector Fingerprint where
    {-# INLINE basicUnsafeFreeze  #-}
    basicUnsafeFreeze :: forall s. Mutable Vector s Fingerprint -> ST s (Vector Fingerprint)
basicUnsafeFreeze (MFingerprintVector MVector s Word64
as MVector s Word64
bs) = do
        Vector Word64
as' <- Mutable Vector s Word64 -> ST s (Vector Word64)
forall s. Mutable Vector s Word64 -> ST s (Vector Word64)
forall (v :: * -> *) a s. Vector v a => Mutable v s a -> ST s (v a)
G.basicUnsafeFreeze Mutable Vector s Word64
MVector s Word64
as
        Vector Word64
bs' <- Mutable Vector s Word64 -> ST s (Vector Word64)
forall s. Mutable Vector s Word64 -> ST s (Vector Word64)
forall (v :: * -> *) a s. Vector v a => Mutable v s a -> ST s (v a)
G.basicUnsafeFreeze Mutable Vector s Word64
MVector s Word64
bs
        Vector Fingerprint -> ST s (Vector Fingerprint)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Fingerprint -> ST s (Vector Fingerprint))
-> Vector Fingerprint -> ST s (Vector Fingerprint)
forall a b. (a -> b) -> a -> b
$ Vector Word64 -> Vector Word64 -> Vector Fingerprint
FingerprintVector Vector Word64
as' Vector Word64
bs'
    {-# INLINE basicUnsafeThaw  #-}
    basicUnsafeThaw :: forall s. Vector Fingerprint -> ST s (Mutable Vector s Fingerprint)
basicUnsafeThaw (FingerprintVector Vector Word64
as Vector Word64
bs) = do
        MVector s Word64
as' <- Vector Word64 -> ST s (Mutable Vector s Word64)
forall s. Vector Word64 -> ST s (Mutable Vector s Word64)
forall (v :: * -> *) a s. Vector v a => v a -> ST s (Mutable v s a)
G.basicUnsafeThaw Vector Word64
as
        MVector s Word64
bs' <- Vector Word64 -> ST s (Mutable Vector s Word64)
forall s. Vector Word64 -> ST s (Mutable Vector s Word64)
forall (v :: * -> *) a s. Vector v a => v a -> ST s (Mutable v s a)
G.basicUnsafeThaw Vector Word64
bs
        MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVector s Fingerprint -> ST s (MVector s Fingerprint))
-> MVector s Fingerprint -> ST s (MVector s Fingerprint)
forall a b. (a -> b) -> a -> b
$ MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
forall s.
MVector s Word64 -> MVector s Word64 -> MVector s Fingerprint
MFingerprintVector MVector s Word64
as' MVector s Word64
bs'
    {-# INLINE basicLength  #-}
    basicLength :: Vector Fingerprint -> Int
basicLength (FingerprintVector Vector Word64
x Vector Word64
_) = Vector Word64 -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.basicLength Vector Word64
x
    {-# INLINE basicUnsafeSlice  #-}
    basicUnsafeSlice :: Int -> Int -> Vector Fingerprint -> Vector Fingerprint
basicUnsafeSlice Int
i_ Int
m_ (FingerprintVector Vector Word64
as Vector Word64
bs) =
        Vector Word64 -> Vector Word64 -> Vector Fingerprint
FingerprintVector (Int -> Int -> Vector Word64 -> Vector Word64
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
G.basicUnsafeSlice Int
i_ Int
m_ Vector Word64
as) (Int -> Int -> Vector Word64 -> Vector Word64
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
G.basicUnsafeSlice Int
i_ Int
m_ Vector Word64
bs)
    {-# INLINE basicUnsafeIndexM  #-}
    basicUnsafeIndexM :: Vector Fingerprint -> Int -> Box Fingerprint
basicUnsafeIndexM (FingerprintVector Vector Word64
as Vector Word64
bs) Int
i_ = do
        Word64
a <- Vector Word64 -> Int -> Box Word64
forall (v :: * -> *) a. Vector v a => v a -> Int -> Box a
G.basicUnsafeIndexM Vector Word64
as Int
i_
        Word64
b <- Vector Word64 -> Int -> Box Word64
forall (v :: * -> *) a. Vector v a => v a -> Int -> Box a
G.basicUnsafeIndexM Vector Word64
bs Int
i_
        Fingerprint -> Box Fingerprint
forall a. a -> Box a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word64 -> Fingerprint
Fingerprint Word64
a Word64
b)
    {-# INLINE basicUnsafeCopy  #-}
    basicUnsafeCopy :: forall s.
Mutable Vector s Fingerprint -> Vector Fingerprint -> ST s ()
basicUnsafeCopy (MFingerprintVector MVector s Word64
as1 MVector s Word64
bs1) (FingerprintVector Vector Word64
as2 Vector Word64
bs2) = do
        Mutable Vector s Word64 -> Vector Word64 -> ST s ()
forall s. Mutable Vector s Word64 -> Vector Word64 -> ST s ()
forall (v :: * -> *) a s.
Vector v a =>
Mutable v s a -> v a -> ST s ()
G.basicUnsafeCopy Mutable Vector s Word64
MVector s Word64
as1 Vector Word64
as2
        Mutable Vector s Word64 -> Vector Word64 -> ST s ()
forall s. Mutable Vector s Word64 -> Vector Word64 -> ST s ()
forall (v :: * -> *) a s.
Vector v a =>
Mutable v s a -> v a -> ST s ()
G.basicUnsafeCopy Mutable Vector s Word64
MVector s Word64
bs1 Vector Word64
bs2
    {-# INLINE elemseq  #-}
    elemseq :: forall b. Vector Fingerprint -> Fingerprint -> b -> b
elemseq Vector Fingerprint
_ (Fingerprint Word64
a Word64
b)
        = Vector Word64 -> Word64 -> b -> b
forall b. Vector Word64 -> Word64 -> b -> b
forall (v :: * -> *) a b. Vector v a => v a -> a -> b -> b
G.elemseq (Vector a
forall {a}. Vector a
forall a. HasCallStack => a
undefined :: Unboxed.Vector a) Word64
a
        (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word64 -> Word64 -> b -> b
forall b. Vector Word64 -> Word64 -> b -> b
forall (v :: * -> *) a b. Vector v a => v a -> a -> b -> b
G.elemseq (Vector b
forall {a}. Vector a
forall a. HasCallStack => a
undefined :: Unboxed.Vector b) Word64
b

data TypeRepVector f = TypeRepVect
    { forall {k} (f :: k). TypeRepVector f -> Vector Fingerprint
fingerprints :: Unboxed.Vector Fingerprint
    , forall {k} (f :: k). TypeRepVector f -> Vector Any
anys         :: V.Vector Any
    }

fromAny :: Any -> f a
fromAny :: forall {k} (f :: k -> *) (a :: k). Any -> f a
fromAny = Any -> f a
forall a b. a -> b
unsafeCoerce

-- | Empty structure.
empty :: TypeRepVector f
empty :: forall {k} (f :: k). TypeRepVector f
empty = Vector Fingerprint -> Vector Any -> TypeRepVector f
forall {k} (f :: k).
Vector Fingerprint -> Vector Any -> TypeRepVector f
TypeRepVect Vector Fingerprint
forall a. Monoid a => a
mempty Vector Any
forall a. Monoid a => a
mempty

-- | Inserts the value with its type as a key.
insert :: forall a f . a -> TypeRepVector f -> TypeRepVector f
insert :: forall {k} a (f :: k). a -> TypeRepVector f -> TypeRepVector f
insert = a -> TypeRepVector f -> TypeRepVector f
forall a. HasCallStack => a
undefined

-- | Looks up the value at the type.
-- >>> let x = lookup $ insert (11 :: Int) empty
-- >>> x :: Maybe Int
-- Just 11
-- >>> x :: Maybe ()
-- Nothing
lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
lookup :: forall {k} (a :: k) (f :: k -> *).
Typeable a =>
TypeRepVector f -> Maybe (f a)
lookup TypeRepVector f
tVect =  Any -> f a
forall {k} (f :: k -> *) (a :: k). Any -> f a
fromAny (Any -> f a) -> (Int -> Any) -> Int -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRepVector f -> Vector Any
forall {k} (f :: k). TypeRepVector f -> Vector Any
anys TypeRepVector f
tVect Vector Any -> Int -> Any
forall a. Vector a -> Int -> a
V.!)
            (Int -> f a) -> Maybe Int -> Maybe (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fingerprint -> Vector Fingerprint -> Maybe Int
binarySearch (TypeRep -> Fingerprint
typeRepFingerprint (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) (TypeRepVector f -> Vector Fingerprint
forall {k} (f :: k). TypeRepVector f -> Vector Fingerprint
fingerprints TypeRepVector f
tVect)

-- | Returns the size of the 'TypeRepVect'.
size :: TypeRepVector f -> Int
size :: forall {k} (f :: k). TypeRepVector f -> Int
size = Vector Fingerprint -> Int
forall a. Unbox a => Vector a -> Int
Unboxed.length (Vector Fingerprint -> Int)
-> (TypeRepVector f -> Vector Fingerprint)
-> TypeRepVector f
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRepVector f -> Vector Fingerprint
forall {k} (f :: k). TypeRepVector f -> Vector Fingerprint
fingerprints

data TF f where
  TF :: Typeable a => f a -> TF f

fromF :: f a -> Proxy a
fromF :: forall {k} (f :: k -> *) (a :: k). f a -> Proxy a
fromF f a
_ = Proxy a
forall {k} (t :: k). Proxy t
Proxy

fromList :: forall f . [TF f] -> TypeRepVector f
fromList :: forall {k} (f :: k -> *). [TF f] -> TypeRepVector f
fromList [TF f]
tfs = Vector Fingerprint -> Vector Any -> TypeRepVector f
forall {k} (f :: k).
Vector Fingerprint -> Vector Any -> TypeRepVector f
TypeRepVect ([Fingerprint] -> Vector Fingerprint
forall a. Unbox a => [a] -> Vector a
Unboxed.fromList [Fingerprint]
fps) ([Any] -> Vector Any
forall a. [a] -> Vector a
V.fromList [Any]
ans)
  where
    ([Fingerprint]
fps, [Any]
ans) = [(Fingerprint, Any)] -> ([Fingerprint], [Any])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Fingerprint, Any)] -> ([Fingerprint], [Any]))
-> [(Fingerprint, Any)] -> ([Fingerprint], [Any])
forall a b. (a -> b) -> a -> b
$ ((Fingerprint, Any) -> Fingerprint)
-> [(Fingerprint, Any)] -> [(Fingerprint, Any)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Fingerprint, Any) -> Fingerprint
forall a b. (a, b) -> a
fst ([(Fingerprint, Any)] -> [(Fingerprint, Any)])
-> [(Fingerprint, Any)] -> [(Fingerprint, Any)]
forall a b. (a -> b) -> a -> b
$ (TF f -> (Fingerprint, Any)) -> [TF f] -> [(Fingerprint, Any)]
forall a b. (a -> b) -> [a] -> [b]
map (TF f -> Fingerprint
fp (TF f -> Fingerprint)
-> (TF f -> Any) -> TF f -> (Fingerprint, Any)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TF f -> Any
an) [TF f]
tfs

    fp :: TF f -> Fingerprint
    fp :: TF f -> Fingerprint
fp (TF f a
x) = TypeRep -> Fingerprint
typeRepFingerprint (TypeRep -> Fingerprint) -> TypeRep -> Fingerprint
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ f a -> Proxy a
forall {k} (f :: k -> *) (a :: k). f a -> Proxy a
fromF f a
x

    an :: TF f -> Any
    an :: TF f -> Any
an (TF f a
x) = f a -> Any
forall a b. a -> b
unsafeCoerce f a
x

-- | Returns the index is found.
binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
binarySearch :: Fingerprint -> Vector Fingerprint -> Maybe Int
binarySearch Fingerprint
fp Vector Fingerprint
fpVect =
    let
      !(I# Int#
len) = Vector Fingerprint -> Int
forall a. Unbox a => Vector a -> Int
Unboxed.length Vector Fingerprint
fpVect
      ind :: Int
ind = Int# -> Int
I# (Int# -> Int# -> Int#
binSearchHelp (Int#
-1#) Int#
len)
    in
      if Fingerprint
fp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== (Vector Fingerprint
fpVect Vector Fingerprint -> Int -> Fingerprint
forall a. Unbox a => Vector a -> Int -> a
Unboxed.! Int
ind) then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ind else Maybe Int
forall a. Maybe a
Nothing
  where
    binSearchHelp :: Int# -> Int# -> Int#
    binSearchHelp :: Int# -> Int# -> Int#
binSearchHelp Int#
l Int#
r = case Int#
l Int# -> Int# -> Int#
<# (Int#
r Int# -> Int# -> Int#
-# Int#
1#) of
        Int#
0# -> Int#
r
        Int#
_ ->
            let m :: Int#
m = Int# -> Int# -> Int#
uncheckedIShiftRA# (Int#
l Int# -> Int# -> Int#
+# Int#
r) Int#
1# in
            if Vector Fingerprint -> Int -> Fingerprint
forall a. Unbox a => Vector a -> Int -> a
Unboxed.unsafeIndex Vector Fingerprint
fpVect (Int# -> Int
I# Int#
m) Fingerprint -> Fingerprint -> Bool
forall a. Ord a => a -> a -> Bool
< Fingerprint
fp
                then Int# -> Int# -> Int#
binSearchHelp Int#
m Int#
r
                else Int# -> Int# -> Int#
binSearchHelp Int#
l Int#
m