typerep-map (empty) → 0.1.0
raw patch · 23 files changed
+1685/−0 lines, 23 filesdep +basedep +containersdep +criterionsetup-changed
Dependencies added: base, containers, criterion, deepseq, dependent-map, dependent-sum, ghc-prim, ghc-typelits-knownnat, hedgehog, primitive, tasty, tasty-discover, tasty-hedgehog, tasty-hspec, typerep-map, vector
Files
- CHANGELOG.md +12/−0
- LICENSE +21/−0
- README.md +55/−0
- Setup.hs +2/−0
- benchmark/CMap.hs +57/−0
- benchmark/CacheMap.hs +52/−0
- benchmark/DMap.hs +85/−0
- benchmark/Main.hs +31/−0
- benchmark/OptimalVector.hs +62/−0
- benchmark/Vector.hs +62/−0
- src/Data/TMap.hs +148/−0
- src/Data/TypeRepMap.hs +65/−0
- src/Data/TypeRepMap/Internal.hs +328/−0
- test/Test.hs +1/−0
- test/Test/TypeRep/CMap.hs +41/−0
- test/Test/TypeRep/CacheMap.hs +48/−0
- test/Test/TypeRep/MapProperty.hs +109/−0
- test/Test/TypeRep/Vector.hs +18/−0
- test/Test/TypeRep/VectorOpt.hs +18/−0
- typerep-extra-impls/Data/TypeRep/CMap.hs +48/−0
- typerep-extra-impls/Data/TypeRep/OptimalVector.hs +115/−0
- typerep-extra-impls/Data/TypeRep/Vector.hs +188/−0
- typerep-map.cabal +119/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+Change log+==========++`typerep-map` uses [PVP Versioning][1].+The change log is available [on GitHub][2].++# 0.1.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/kowainik/typerep-map/blob/master/CHANGELOG.md
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Veronika Romashkina++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,55 @@+# typerep-map++[](https://hackage.haskell.org/package/typerep-map)+[](https://travis-ci.org/kowainik/typerep-map)+[](https://github.com/vrom911/typerep-map/blob/master/LICENSE)++`typerep-map` introduces `TMap` and `TypeRepMap` — data structures like [`Map`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#t:Map), but where types serve as keys, and values have the types specified in the corresponding key spots.++## Usage example++```haskell+ghci> import Data.TMap++ghci> tm = insert True $ one (42 :: Int)++ghci> size tm+2++ghci> res = lookup tm++ghci> res :: Maybe Int+Just 42++ghci> res :: Maybe Bool+Just True++ghci> res :: Maybe String+Nothing++ghci> lookup (insert "hello" tm) :: Maybe String+Just "hello"++ghci> member @Int tm+True++ghci> tm' = delete @Int tm++ghci> member @Int tm'+False+```++## Benchmarks++Tables below contain comparision with `DMap TypeRep` of ten `lookup` operations+on structure with size `10^4`:++| | ghc-8.2.2 | ghc-8.4.3 |+|----------------|-----------|-----------|+| `DMap TypeRep` | 517.5 ns | 779.9 ns |+| `typerep-map` | 205.3 ns | 187.2 ns |++ ghc-8.2.2 | ghc-8.4.3+:---------:|:-----------:+ | + | 
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/CMap.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module CMap+ ( benchMap+ , prepareBenchMap+ ) where++import Criterion.Main (Benchmark, bench, bgroup, nf)++import Prelude hiding (lookup)++import Control.DeepSeq (rnf)+import Control.Exception+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import GHC.TypeLits++import Data.TypeRep.CMap (TypeRepMap (..), empty, insert, keys, lookup)++benchMap :: Benchmark+benchMap = bgroup "map"+ [ bench "lookup" $ nf tenLookups bigMap+ --, bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)+ --, bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)+ ]++tenLookups :: TypeRepMap (Proxy :: Nat -> *)+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80+ )+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)+ where+ lp :: forall (a::Nat). Typeable a => Proxy a+ lp = fromJust $ lookup tmap++-- TypeRepMap of 10000 elements+bigMap :: TypeRepMap (Proxy :: Nat -> *)+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty++buildBigMap :: forall a . (KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *)+buildBigMap 1 x = insert x+buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))++rknf :: TypeRepMap f -> ()+rknf = rnf . keys++prepareBenchMap :: IO ()+prepareBenchMap = evaluate (rknf bigMap)
+ benchmark/CacheMap.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module CacheMap+ ( benchCacheMap+ ) where++import Criterion.Main (Benchmark, bench, bgroup, nf)++import Prelude hiding (lookup)++import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import GHC.TypeLits++import Data.TypeRepMap.Internal (TF (..), TypeRepMap (..), fromList, lookup)++benchCacheMap :: Benchmark+benchCacheMap = bgroup "vector optimal cache"+ [ bench "lookup" $ nf tenLookups bigMap+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)+ ]++tenLookups :: TypeRepMap (Proxy :: Nat -> *)+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80+ )+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)+ where+ lp :: forall (a::Nat). Typeable a => Proxy a+ lp = fromJust $ lookup tmap++-- TypeRepMap of 10000 elements+bigMap :: TypeRepMap (Proxy :: Nat -> *)+bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []++buildBigMap :: forall a . (KnownNat a)+ => Int+ -> Proxy (a :: Nat)+ -> [TF (Proxy :: Nat -> *)]+ -> [TF (Proxy :: Nat -> *)]+buildBigMap 1 x = (TF x :)+buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
+ benchmark/DMap.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver -fno-warn-orphans #-}++module DMap+ ( benchDMap+ , prepareBenchDMap+ ) where++import Criterion.Main (Benchmark, bench, bgroup, nf)++import Prelude hiding (lookup)++import Control.DeepSeq (rnf)+import Control.Exception+import Data.Functor.Identity (Identity (..))+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Type.Equality ((:~:) (..))+import GHC.TypeLits+import Type.Reflection (TypeRep, Typeable, typeRep)+import Type.Reflection.Unsafe (typeRepFingerprint)+import Unsafe.Coerce (unsafeCoerce)++import Data.Dependent.Map (DMap, empty, insert, keys, lookup)+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))+import Data.Some (Some (This))++benchDMap :: Benchmark+benchDMap = bgroup "dependent map"+ [ bench "lookup" $ nf tenLookups bigMap+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)+ ]++tenLookups :: DMap TypeRep Identity+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80+ )+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)+ where+ lp :: forall (a :: Nat) . Typeable a => Proxy a+ lp = runIdentity $ fromJust $ lookup (typeRep @(Proxy a)) tmap++-- TypeRepMap of 10000 elements+bigMap :: DMap TypeRep Identity+bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty++buildBigMap :: forall a . (KnownNat a)+ => Int+ -> Proxy (a :: Nat)+ -> DMap TypeRep Identity+ -> DMap TypeRep Identity+buildBigMap 1 x = insert (typeRep @(Proxy a)) $ Identity x+buildBigMap n x = insert (typeRep @(Proxy a)) (Identity x)+ . buildBigMap (n - 1) (Proxy @(a + 1))++rknf :: DMap TypeRep f -> ()+rknf = rnf . map (\(This t) -> typeRepFingerprint t) . keys++prepareBenchDMap :: IO ()+prepareBenchDMap = evaluate (rknf bigMap)++instance GEq TypeRep where+ geq :: TypeRep a -> TypeRep b -> Maybe (a :~: b)+ geq (typeRepFingerprint -> a) (typeRepFingerprint -> b) =+ if a == b+ then Just $ unsafeCoerce Refl+ else Nothing++instance GCompare TypeRep where+ gcompare :: TypeRep a -> TypeRep b -> GOrdering a b+ gcompare (typeRepFingerprint -> a) (typeRepFingerprint -> b) =+ case compare a b of+ EQ -> unsafeCoerce GEQ+ LT -> GLT+ GT -> GGT
+ benchmark/Main.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++module Main where++import Criterion.Main (defaultMain)++import CacheMap (benchCacheMap)+import CMap (benchMap, prepareBenchMap)+#if ( __GLASGOW_HASKELL__ >= 802 )+import DMap (benchDMap, prepareBenchDMap)+#endif+import OptimalVector (benchVectorOpt, prepareBenchVectorOpt)+--import Vector (benchVector, prepareBenchVector)++main :: IO ()+main = do+ prepareBenchMap+ --prepareBenchVector+ prepareBenchVectorOpt+#if ( __GLASGOW_HASKELL__ >= 802 )+ prepareBenchDMap+#endif+ defaultMain+ [ benchMap+ -- , benchVector+ , benchCacheMap+ , benchVectorOpt+#if ( __GLASGOW_HASKELL__ >= 802 )+ , benchDMap+#endif+ ]
+ benchmark/OptimalVector.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module OptimalVector+ ( benchVectorOpt+ , prepareBenchVectorOpt+ ) where++import Criterion.Main (Benchmark, bench, bgroup, nf)++import Prelude hiding (lookup)++import Control.DeepSeq (rnf)+import Control.Exception+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import GHC.TypeLits++import Data.TypeRep.OptimalVector (TF (..), TypeRepMap (..), fromList, lookup)++benchVectorOpt :: Benchmark+benchVectorOpt = bgroup "vector optimal"+ [ bench "lookup" $ nf tenLookups bigMap+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)+ ]++tenLookups :: TypeRepMap (Proxy :: Nat -> *)+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80+ )+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)+ where+ lp :: forall (a::Nat). Typeable a => Proxy a+ lp = fromJust $ lookup tmap++-- TypeRepMap of 10000 elements+bigMap :: TypeRepMap (Proxy :: Nat -> *)+bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []++buildBigMap :: forall a . (KnownNat a)+ => Int+ -> Proxy (a :: Nat)+ -> [TF (Proxy :: Nat -> *)]+ -> [TF (Proxy :: Nat -> *)]+buildBigMap 1 x = (TF x :)+buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))++rknf :: TypeRepMap f -> ()+rknf tVect = rnf (fingerprintAs tVect, fingerprintBs tVect)++prepareBenchVectorOpt :: IO ()+prepareBenchVectorOpt = evaluate (rknf bigMap)
+ benchmark/Vector.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Vector+ ( benchVector+ , prepareBenchVector+ ) where++import Criterion.Main (Benchmark, bench, bgroup, nf)++import Prelude hiding (lookup)++import Control.DeepSeq (rnf)+import Control.Exception+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import GHC.TypeLits++import Data.TypeRep.Vector++benchVector :: Benchmark+benchVector = bgroup "vector"+ [ bench "lookup" $ nf tenLookups bigMap+ -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)+ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)+ ]++tenLookups :: TypeRepVector (Proxy :: Nat -> *)+ -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40+ , Proxy 50, Proxy 60, Proxy 70, Proxy 80+ )+tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)+ where+ lp :: forall (a::Nat). Typeable a => Proxy a+ lp = fromJust $ lookup tmap++-- TypeRepMap of 10000 elements+bigMap :: TypeRepVector (Proxy :: Nat -> *)+bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []++buildBigMap :: forall a . (KnownNat a)+ => Int+ -> Proxy (a :: Nat)+ -> [TF (Proxy :: Nat -> *)]+ -> [TF (Proxy :: Nat -> *)]+buildBigMap 1 x = (TF x :)+buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))++rknf :: TypeRepVector f -> ()+rknf = rnf . fingerprints++prepareBenchVector :: IO ()+prepareBenchVector = evaluate (rknf bigMap)
+ src/Data/TMap.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE Rank2Types #-}++{- |+'TMap' is a heterogeneous data structure similar in its essence to+'Data.Map.Map' with types as keys, where each value has the type of its key.++Here is an example of a 'TMap' with a comparison to 'Data.Map.Map':++@+ 'Data.Map.Map' 'Prelude.String' 'Prelude.String' 'TMap'+-------------------- -----------------+ \"Int\" -> \"5\" 'Prelude.Int' -> 5+ \"Bool\" -> \"True\" 'Prelude.Bool' -> 'Prelude.True'+ \"Char\" -> \"\'x\'\" 'Prelude.Char' -> \'x\'+@++The runtime representation of 'TMap' is an array, not a tree. This makes+'lookup' significantly more efficient.++-}++module Data.TMap+ ( -- * Map type+ TMap++ -- * Construction+ , empty+ , one++ -- * Modification+ , insert+ , delete+ , unionWith+ , union++ -- * Query+ , lookup+ , member+ , size+ ) where++import Prelude hiding (lookup)++import Data.Functor.Identity (Identity (..))+import Data.Typeable (Typeable)+import GHC.Exts (coerce)++import qualified Data.TypeRepMap as F++-- | 'TMap' is a special case of 'F.TypeRepMap' when the interpretation is+-- 'Identity'.+type TMap = F.TypeRepMap Identity++{- |++A 'TMap' with no values stored in it.++prop> size empty == 0+prop> member @a empty == False++-}+empty :: TMap+empty = F.empty+{-# INLINE empty #-}++{- |++Construct a 'TMap' with a single element.++prop> size (one x) == 1+prop> member @a (one (x :: a)) == True++-}+one :: forall a . Typeable a => a -> TMap+one x = coerce (F.one @a @Identity $ coerce x)+{-# INLINE one #-}++{- |++Insert a value into a 'TMap'.++prop> size (insert v tm) >= size tm+prop> member @a (insert (x :: a) tm) == True++-}+insert :: forall a . Typeable a => a -> TMap -> TMap+insert x = coerce (F.insert @a @Identity $ coerce x)+{-# INLINE insert #-}++{- | Delete a value from a 'TMap'.++prop> size (delete @a tm) <= size tm+prop> member @a (delete @a tm) == False++>>> tm = delete @Bool $ insert True $ one 'a'+>>> size tm+1+>>> member @Bool tm+False+>>> member @Char tm+True+-}+delete :: forall a . Typeable a => TMap -> TMap+delete = F.delete @a @Identity+{-# INLINE delete #-}++-- | The union of two 'TMap's using a combining function.+unionWith :: (forall x. x -> x -> x) -> TMap -> TMap -> TMap+unionWith f = F.unionWith fId+ where+ fId :: forall y . Identity y -> Identity y -> Identity y+ fId y1 y2 = Identity $ f (coerce y1) (coerce y2)+{-# INLINE unionWith #-}++-- | The (left-biased) union of two 'TMap's. It prefers the first map when+-- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@.+union :: TMap -> TMap -> TMap+union = F.union+{-# INLINE union #-}++{- | Lookup a value of the given type in a 'TMap'.++>>> x = lookup $ insert (11 :: Int) empty+>>> x :: Maybe Int+Just 11+>>> x :: Maybe ()+Nothing+-}+lookup :: forall a. Typeable a => TMap -> Maybe a+lookup = coerce (F.lookup @a @Identity)+{-# INLINE lookup #-}++{- | Check if a value of the given type is present in a 'TMap'.++>>> member @Char $ one 'a'+True+>>> member @Bool $ one 'a'+False+-}+member :: forall a . Typeable a => TMap -> Bool+member = F.member @a @Identity+{-# INLINE member #-}++-- | Get the amount of elements in a 'TMap'.+size :: TMap -> Int+size = F.size+{-# INLINE size #-}
+ src/Data/TypeRepMap.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This+-- sort of parametrization may be familiar to users of @vinyl@ records.+--+-- @'TypeRepMap' f@ is a more efficient replacement for @DMap+-- 'Type.Reflection.TypeRep' f@ (where @DMap@ is from the @dependent-map@+-- package).+--+-- Here is an example of using 'Prelude.Maybe' as an interpretation, with a+-- comparison to 'Data.TMap.TMap':+--+-- @+-- 'Data.TMap.TMap' 'TypeRepMap' 'Prelude.Maybe'+-- -------------- -------------------+-- Int -> 5 Int -> Just 5+-- Bool -> True Bool -> Nothing+-- Char -> \'x\' Char -> Just \'x\'+-- @+--+-- In fact, a 'Data.TMap.TMap' is defined as 'TypeRepMap'+-- 'Data.Functor.Identity'.+--+-- Since 'Type.Reflection.TypeRep' is poly-kinded, the interpretation can use+-- any kind for the keys. For instance, we can use the 'GHC.TypeLits.Symbol'+-- kind to use 'TypeRepMap' as an extensible record:+--+-- @+-- newtype Field name = F (FType name)+--+-- type family FType (name :: Symbol) :: Type+-- type instance FType "radius" = Double+-- type instance FType "border-color" = RGB+-- type instance FType "border-width" = Double+--+-- 'TypeRepMap' Field+-- --------------------------------------+-- "radius" -> F 5.7+-- "border-color" -> F (rgb 148 0 211)+-- "border-width" -> F 0.5+-- @+--+module Data.TypeRepMap+ ( -- * Map type+ TypeRepMap()++ -- * Construction+ , empty+ , one++ -- * Modification+ , insert+ , delete+ , hoist+ , unionWith+ , union++ -- * Query+ , lookup+ , member+ , size++ ) where++import Data.TypeRepMap.Internal
+ src/Data/TypeRepMap/Internal.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}++-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}++-- | Internal API for 'TypeRepMap' and operations on it. The functions here do+-- not have any stability guarantees and can change between minor versions.+--+-- If you need to use this module for purposes other than tests,+-- create an issue.+--+module Data.TypeRepMap.Internal where++import Prelude hiding (lookup)++import Control.Arrow ((&&&))+import Data.Function (on)+import Data.IntMap.Strict (IntMap)+import Data.Kind (Type)+import Data.List (nubBy)+import Data.Maybe (fromJust)+import Data.Primitive.Array (Array, indexArray, mapArray')+import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)+import Data.Proxy (Proxy (..))+import Data.Semigroup (Semigroup (..))+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)+import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))+import GHC.Exts (inline, sortWith)+import GHC.Fingerprint (Fingerprint (..))+import GHC.Prim (eqWord#, ltWord#)+import GHC.Word (Word64 (..))+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.IntMap.Strict as IM+import qualified Data.Map.Strict as Map+import qualified GHC.Exts as GHC (fromList, toList)++{- |++'TypeRepMap' is a heterogeneous data structure similar in its essence to+'Data.Map.Map' with types as keys, where each value has the type of its key. In+addition to that, each value is wrapped in an interpretation @f@.++Here is an example of using 'Prelude.Maybe' as an interpretation, with a+comparison to 'Data.Map.Map':++@+ 'Data.Map.Map' 'Prelude.String' ('Prelude.Maybe' 'Prelude.String') 'TypeRepMap' 'Prelude.Maybe'+--------------------------- ---------------------+ \"Int\" -> Just \"5\" 'Prelude.Int' -> Just 5+ \"Bool\" -> Just \"True\" 'Prelude.Bool' -> Just 'Prelude.True'+ \"Char\" -> Nothing 'Prelude.Char' -> Nothing+@++The runtime representation of 'TypeRepMap' is an array, not a tree. This makes+'lookup' significantly more efficient.++-}+data TypeRepMap (f :: k -> Type) =+ TypeRepMap+ { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ first components of key fingerprints+ , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ second components of key fingerprints+ , anys :: {-# UNPACK #-} !(Array Any) -- ^ values stored in the map+ }+ -- ^ an unsafe constructor for 'TypeRepMap'++-- | Shows only 'Fingerprint's.+instance Show (TypeRepMap f) where+ show = show . toFingerprints++-- | Uses 'union' to combine 'TypeRepMap's.+instance Semigroup (TypeRepMap f) where+ (<>) :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f+ (<>) = union+ {-# INLINE (<>) #-}++instance Monoid (TypeRepMap f) where+ mempty = TypeRepMap mempty mempty mempty+ mappend = (<>)+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.+toFingerprints :: TypeRepMap f -> [Fingerprint]+toFingerprints TypeRepMap{..} =+ zipWith Fingerprint (GHC.toList fingerprintAs) (GHC.toList fingerprintBs)++{- |++A 'TypeRepMap' with no values stored in it.++prop> size empty == 0+prop> member @a empty == False++-}+empty :: TypeRepMap f+empty = mempty+{-# INLINE empty #-}++{- |++Construct a 'TypeRepMap' with a single element.++prop> size (one x) == 1+prop> member @a (one (x :: f a)) == True++-}+one :: forall a f . Typeable a => f a -> TypeRepMap f+one x = insert x empty+{-# INLINE one #-}++{- |++Insert a value into a 'TypeRepMap'.++prop> size (insert v tm) >= size tm+prop> member @a (insert (x :: f a) tm) == True++-}+insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f+insert x = fromListPairs . addX . toPairList+ where+ pairX :: (Fingerprint, Any)+ pairX@(fpX, _) = (calcFp x, toAny x)++ addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]+ addX l = pairX : deleteByFst fpX l+{-# INLINE insert #-}++-- Extract the kind of a type. We use it to work around lack of syntax for+-- inferred type variables (which are not subject to type applications).+type KindOf (a :: k) = k++{- | Delete a value from a 'TypeRepMap'.++prop> size (delete @a tm) <= size tm+prop> member @a (delete @a tm) == False++>>> tm = delete @Bool $ insert (Just True) $ one (Just 'a')+>>> size tm+1+>>> member @Bool tm+False+>>> member @Char tm+True+-}+delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f+delete = fromListPairs . deleteByFst (typeFp @a) . toPairList+{-# INLINE delete #-}++{- | Map over the elements of a 'TypeRepMap'.++>>> tm = insert (Identity True) $ one (Identity 'a')+>>> lookup @Bool tm+Just (Identity True)+>>> lookup @Char tm+Just (Identity 'a')+>>> tm2 = hoist ((:[]) . runIdentity) tm+>>> lookup @Bool tm2+Just [True]+>>> lookup @Char tm2+Just "a"+-}+hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g+hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ mapArray' (toAny . f . fromAny) ans+{-# INLINE hoist #-}++-- | The union of two 'TypeRepMap's using a combining function.+unionWith :: (forall x. f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f+unionWith f m1 m2 = fromListPairs+ $ Map.toList+ $ Map.unionWith combine+ (Map.fromList $ toPairList m1)+ (Map.fromList $ toPairList m2)+ where+ combine :: Any -> Any -> Any+ combine a b = toAny $ f (fromAny a) (fromAny b)+{-# INLINE unionWith #-}++-- | The (left-biased) union of two 'TypeRepMap's. It prefers the first map when+-- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@.+union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f+union = unionWith const+{-# INLINE union #-}++{- | Check if a value of the given type is present in a 'TypeRepMap'.++>>> member @Char $ one (Identity 'a')+True+>>> member @Bool $ one (Identity 'a')+False+-}+member :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> Bool+member tm = case lookup @a tm of+ Nothing -> False+ Just _ -> True+{-# INLINE member #-}++{- | Lookup a value of the given type in a 'TypeRepMap'.++>>> x = lookup $ insert (Identity (11 :: Int)) empty+>>> x :: Maybe (Identity Int)+Just (Identity 11)+>>> x :: Maybe (Identity ())+Nothing+-}+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)+lookup tVect = fromAny . (anys tVect `indexArray`)+ <$> cachedBinarySearch (typeFp @a)+ (fingerprintAs tVect)+ (fingerprintBs tVect)+{-# INLINE lookup #-}++-- | Get the amount of elements in a 'TypeRepMap'.+size :: TypeRepMap f -> Int+size = sizeofPrimArray . fingerprintAs+{-# INLINE size #-}++-- | Binary searched based on this article+-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html+-- with modification for our two-vector search case.+cachedBinarySearch :: Fingerprint -> PrimArray Word64 -> PrimArray Word64 -> Maybe Int+cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)+ where+ go :: Int# -> Maybe Int+ go i = case i <# len of+ 0# -> Nothing+ _ -> let !(W64# valA) = indexPrimArray fpAs (I# i) in case a `ltWord#` valA of+ 0# -> case a `eqWord#` valA of+ 0# -> go (2# *# i +# 2#)+ _ -> let !(W64# valB) = indexPrimArray fpBs (I# i) in case b `eqWord#` valB of+ 0# -> case b `ltWord#` valB of+ 0# -> go (2# *# i +# 2#)+ _ -> go (2# *# i +# 1#)+ _ -> Just (I# i)+ _ -> go (2# *# i +# 1#)++ len :: Int#+ len = let !(I# l) = sizeofPrimArray fpAs in l+{-# INLINE cachedBinarySearch #-}++----------------------------------------------------------------------------+-- Internal functions+----------------------------------------------------------------------------++toAny :: f a -> Any+toAny = unsafeCoerce++fromAny :: Any -> f a+fromAny = unsafeCoerce++typeFp :: forall a . Typeable a => Fingerprint+typeFp = typeRepFingerprint $ typeRep $ Proxy @a+{-# INLINE typeFp #-}++toPairList :: TypeRepMap f -> [(Fingerprint, Any)]+toPairList tm = zip (toFingerprints tm) (GHC.toList $ anys tm)++deleteByFst :: Eq a => a -> [(a, b)] -> [(a, b)]+deleteByFst x = filter ((/= x) . fst)++nubByFst :: (Eq a) => [(a, b)] -> [(a, b)]+nubByFst = nubBy ((==) `on` fst)++----------------------------------------------------------------------------+-- Functions for testing and benchmarking+----------------------------------------------------------------------------++-- | Existential wrapper around 'Typeable' indexed by @f@ type parameter.+-- Useful for 'TypeRepMap' structure creation form list of 'TF's.+data TF f where+ TF :: Typeable a => f a -> TF f++instance Show (TF f) where+ show (TF tf) = show $ calcFp tf++{- | Creates 'TypeRepMap' from a list of 'TF's.++>>> size $ fromList [TF $ Identity True, TF $ Identity 'a']+2++-}+fromList :: forall f . [TF f] -> TypeRepMap f+fromList = fromListPairs . map (fp &&& an)+ where+ fp :: TF f -> Fingerprint+ fp (TF x) = calcFp x++ an :: TF f -> Any+ an (TF x) = toAny x++fromF :: Typeable a => f a -> Proxy a+fromF _ = Proxy++calcFp :: Typeable a => f a -> Fingerprint+calcFp = typeRepFingerprint . typeRep . fromF++fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f+fromListPairs kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans)+ where+ (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps+ (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs++----------------------------------------------------------------------------+-- Tree-like conversion+----------------------------------------------------------------------------++fromSortedList :: forall a . [a] -> [a]+fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)+ where+ -- state monad could be used here, but it's another dependency+ go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)+ go i first result vector =+ if i >= IM.size vector+ then (result, first)+ else do+ let (newResult, newFirst) = go (2 * i + 1) first result vector+ let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult+ go (2 * i + 2) (newFirst + 1) withCur vector
+ test/Test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
+ test/Test/TypeRep/CMap.hs view
@@ -0,0 +1,41 @@+module Test.TypeRep.CMap where++import Prelude hiding (lookup)++import Data.Functor.Identity (Identity (..))++import Test.Tasty.Hspec++import Data.TypeRep.CMap++-- Simple test for 'lookup', 'insert' and 'size' functions.+spec_insertLookup :: Spec+spec_insertLookup = do+ describe "Lookup Test" $ do+ it "returns the inserted element" $+ lookup (insert (Identity 'a') empty) `shouldBe` Just (Identity 'a')+ it "returns the second inserted value of the same type" $+ lookup (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` Just (Identity 'b')++ describe "Size Test" $ do+ it "is empty" $+ size empty `shouldBe` 0+ it "is of size 1 when 1 element inserted" $+ size (insert (Identity 'a') empty) `shouldBe` 1+ it "doesn't increase size when element of the same type is added" $+ size (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` 1+ it "returns 10 when 10 different types are inserted" $+ size mapOf10 `shouldBe` 10+++mapOf10 :: TypeRepMap Identity+mapOf10 = insert (Identity True)+ $ insert (Identity [True, False])+ $ insert (Identity $ Just True)+ $ insert (Identity $ Just ())+ $ insert (Identity [()])+ $ insert (Identity ())+ $ insert (Identity "aaa")+ $ insert (Identity $ Just 'a')+ $ insert (Identity 'a')+ $ insert (Identity (11 :: Int)) empty
+ test/Test/TypeRep/CacheMap.hs view
@@ -0,0 +1,48 @@+module Test.TypeRep.CacheMap where++import Prelude hiding (lookup)++import Data.Functor.Identity (Identity (..))+import Test.Tasty.Hspec (Spec, describe, it, shouldBe)++import Data.TypeRepMap.Internal (TF (..), fromList)+import Data.TMap (TMap, empty, insert, lookup, one, size, union)++-- Simple test for 'lookup', 'insert' and 'size' functions.+spec_insertLookup :: Spec+spec_insertLookup = do+ describe "Lookup Test" $ do+ it "returns the inserted element" $+ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just 'a'+ it "returns the second inserted value of the same type" $+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just 'b'++ describe "Size Test" $ do+ it "is empty" $+ size empty `shouldBe` 0+ it "is of size 1 when 1 element inserted" $+ size (one 'a') `shouldBe` 1+ it "doesn't increase size when element of the same type is added" $+ size (insert 'b' $ insert 'a' empty) `shouldBe` 1+ it "returns 10 when 10 different types are inserted" $+ size mapOf10 `shouldBe` 10++ describe "Union test" $ do+ let m = fromList [TF $ Identity 'a', TF $ Identity True] `union` fromList [TF $ Identity 'b']+ it "lookup works on union as expected" $ do+ lookup m `shouldBe` Just 'a'+ lookup m `shouldBe` Just True+ lookup @Int m `shouldBe` Nothing+++mapOf10 :: TMap+mapOf10 = insert True+ $ insert [True, False]+ $ insert (Just True)+ $ insert (Just ())+ $ insert [()]+ $ insert ()+ $ insert "aaa"+ $ insert (Just 'a')+ $ insert 'a'+ $ insert (11 :: Int) empty
+ test/Test/TypeRep/MapProperty.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Test.TypeRep.MapProperty where++import Prelude hiding (lookup)++import Data.Proxy (Proxy (..))+import Data.Semigroup (Semigroup (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits (Nat, SomeNat (..), someNatVal)+import Hedgehog (MonadGen, PropertyT, forAll, property, (===))+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Data.TypeRepMap.Internal (TF (..), TypeRepMap (..), delete, fromList, insert, lookup, member)++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++----------------------------------------------------------------------------+-- Common utils+----------------------------------------------------------------------------++type PropertyTest = [TestTree]++prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest+prop testName = pure . testProperty testName . property++----------------------------------------------------------------------------+-- Map modification properties+----------------------------------------------------------------------------++test_InsertLookup :: PropertyTest+test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do+ m <- forAll genMap+ TF (proxy :: IntProxy n) <- forAll genTF++ lookup @n @IntProxy (insert proxy m) === Just proxy++test_InsertInsert :: PropertyTest+test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do+ m <- forAll genMap+ TF a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF+ let b = IntProxy proxy (i + 1)+ lookup @n @IntProxy (insert b $ insert a m) === Just b++test_DeleteMember :: PropertyTest+test_DeleteMember = prop "member k . delete k == False" $ do+ m <- forAll genMap+ TF (proxy :: IntProxy n) <- forAll genTF+ shouldInsert <- forAll Gen.bool++ if shouldInsert then+ member @n (delete @n $ insert proxy m) === False+ else+ member @n (delete @n m) === False++----------------------------------------------------------------------------+-- Semigroup and Monoid laws+----------------------------------------------------------------------------++-- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's+-- not a good idea to write such `Eq` instance for `TypeRepMap` itself because+-- it doesn't compare values so it's not true equality. But this should be+-- enough for tests.+newtype FpMap f = FpMap (TypeRepMap f)+ deriving (Show, Semigroup, Monoid)++instance Eq (FpMap f) where+ FpMap (TypeRepMap as1 bs1 _) == FpMap (TypeRepMap as2 bs2 _) =+ as1 == as2 && bs1 == bs2++test_SemigroupAssoc :: PropertyTest+test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do+ x <- FpMap <$> forAll genMap+ y <- FpMap <$> forAll genMap+ z <- FpMap <$> forAll genMap++ (x <> (y <> z)) === ((x <> y) <> z)++test_MonoidIdentity :: PropertyTest+test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do+ x <- FpMap <$> forAll genMap++ x <> mempty === x+ mempty <> x === x++----------------------------------------------------------------------------+-- Generators+----------------------------------------------------------------------------++data IntProxy (n :: Nat) = IntProxy (Proxy n) Int+ deriving (Show, Eq)++genMap :: MonadGen m => m (TypeRepMap IntProxy)+genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF++genTF :: MonadGen m => m (TF IntProxy)+genTF = do+ randNat :: Integer <- Gen.integral (Range.linear 0 10000)+ randInt <- Gen.int Range.constantBounded+ case someNatVal randNat of+ Just (SomeNat proxyNat) -> pure $ TF $ IntProxy proxyNat randInt+ Nothing -> error "Invalid test generator"
+ test/Test/TypeRep/Vector.hs view
@@ -0,0 +1,18 @@+module Test.TypeRep.Vector where++import Prelude hiding (lookup)++import Data.Functor.Identity (Identity (..))++import Test.Tasty.Hspec++import Data.TypeRep.Vector++-- Simple test for 'lookup', 'insert' and 'size' functions.+spec_insertLookup :: Spec+spec_insertLookup =+ describe "Lookup Test" $ do+ it "returns the inserted element" $+ lookup (fromList [TF (Identity 'a')]) `shouldBe` Just (Identity 'a')+ it "returns the second inserted value of the same type" $+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just (Identity 'b')
+ test/Test/TypeRep/VectorOpt.hs view
@@ -0,0 +1,18 @@+module Test.TypeRep.VectorOpt where++import Prelude hiding (lookup)++import Data.Functor.Identity (Identity (..))++import Test.Tasty.Hspec++import Data.TypeRep.OptimalVector (TF (..), fromList, lookup)++-- Simple test for 'lookup', 'insert' and 'size' functions.+spec_insertLookup :: Spec+spec_insertLookup =+ describe "Lookup Test" $ do+ it "returns the inserted element" $+ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a')+ it "returns the second inserted value of the same type" $+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just (Identity 'b')
+ typerep-extra-impls/Data/TypeRep/CMap.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++module Data.TypeRep.CMap+ ( TypeRepMap (..)+ , empty+ , insert+ , keys+ , lookup+ , size+ ) where++import Prelude hiding (lookup)++import Data.Proxy (Proxy (..))+import Data.Typeable (TypeRep, Typeable, typeRep)+import GHC.Base (Any)+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.Map.Lazy as LMap++-- | Map-like data structure with types served as the keys.+newtype TypeRepMap (f :: k -> *) = TypeRepMap+ { unMap :: LMap.Map TypeRep Any+ }++-- | Empty structure.+empty :: TypeRepMap f+empty = TypeRepMap mempty++-- | Inserts the value with its type as a key.+insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f+insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap++-- | 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 => TypeRepMap f -> Maybe (f a)+lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap++size :: TypeRepMap f -> Int+size = LMap.size . unMap++keys :: TypeRepMap f -> [TypeRep]+keys = LMap.keys . unMap
+ typerep-extra-impls/Data/TypeRep/OptimalVector.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Data.TypeRep.OptimalVector+ ( -- * Map type+ TypeRepMap (..)++ -- 'TypeRepMap' interface+ , empty+ , insert+ , lookup+ , size++ -- * Helpful testing functions+ , TF (..)+ , fromList+ ) where++import Prelude hiding (lookup)++import Control.Arrow ((&&&))+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)+import Data.Word (Word64)+import GHC.Base (Any, Int (..), Int#, uncheckedIShiftRA#, (+#), (-#), (<#))+import GHC.Exts (inline, sortWith)+import GHC.Fingerprint (Fingerprint (..))+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as Unboxed++data TypeRepMap (f :: k -> Type) = TypeRepMap+ { fingerprintAs :: Unboxed.Vector Word64+ , fingerprintBs :: Unboxed.Vector Word64+ , anys :: V.Vector Any+ }++fromAny :: Any -> f a+fromAny = unsafeCoerce++-- | Empty structure.+empty :: TypeRepMap f+empty = TypeRepMap mempty mempty mempty++-- | Inserts the value with its type as a key.+insert :: forall a f . Typeable a => a -> TypeRepMap f -> TypeRepMap f+insert = 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 => TypeRepMap f -> Maybe (f a)+lookup tVect = fromAny . (anys tVect V.!)+ <$> binarySearch (typeRepFingerprint $ typeRep $ Proxy @a)+ (fingerprintAs tVect)+ (fingerprintBs tVect)++-- | Returns the size of the 'TypeRepMap'.+size :: TypeRepMap f -> Int+size = Unboxed.length . fingerprintAs++-- | Returns the index is found.+binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int+binarySearch (Fingerprint a b) fpAs fpBs =+ let+ !(I# len) = Unboxed.length fpAs+ checkfpBs :: Int# -> Maybe Int+ checkfpBs i =+ case i <# len of+ 0# -> Nothing+ _ | a /= Unboxed.unsafeIndex fpAs (I# i) -> Nothing+ | b == Unboxed.unsafeIndex fpBs (I# i) -> Just (I# i)+ | otherwise -> checkfpBs (i +# 1#)+ in+ inline (checkfpBs (binSearchHelp (-1#) len))+ where+ binSearchHelp :: Int# -> Int# -> Int#+ binSearchHelp l r = case l <# (r -# 1#) of+ 0# -> r+ _ ->+ let m = uncheckedIShiftRA# (l +# r) 1# in+ if Unboxed.unsafeIndex fpAs (I# m) < a+ then binSearchHelp m r+ else binSearchHelp l m++----------------------------------------------------------------------------+-- Functions for testing and benchmarking+----------------------------------------------------------------------------++data TF f where+ TF :: Typeable a => f a -> TF f++fromF :: Typeable a => f a -> Proxy a+fromF _ = Proxy++fromList :: forall f . [TF f] -> TypeRepMap f+fromList tfs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)+ where+ (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs++ fp :: TF f -> Fingerprint+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x++ an :: TF f -> Any+ an (TF x) = unsafeCoerce x
+ typerep-extra-impls/Data/TypeRep/Vector.hs view
@@ -0,0 +1,188 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++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 (MFingerprintVector x _) = M.basicLength x+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i m (MFingerprintVector a b) =+ MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)+ {-# INLINE basicOverlaps #-}+ basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) =+ M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n_ = do+ as <- M.basicUnsafeNew n_+ bs <- M.basicUnsafeNew n_+ return $ MFingerprintVector as bs+ {-# INLINE basicInitialize #-}+ basicInitialize (MFingerprintVector as bs) = do+ M.basicInitialize as+ M.basicInitialize bs+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeReplicate n_ (Fingerprint a b) = do+ as <- M.basicUnsafeReplicate n_ a+ bs <- M.basicUnsafeReplicate n_ b+ return $ MFingerprintVector as bs+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (MFingerprintVector as bs) i_ = do+ a <- M.basicUnsafeRead as i_+ b <- M.basicUnsafeRead bs i_+ return (Fingerprint a b)+ {-# INLINE basicUnsafeWrite #-}+ basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do+ M.basicUnsafeWrite as i_ a+ M.basicUnsafeWrite bs i_ b+ {-# INLINE basicClear #-}+ basicClear (MFingerprintVector as bs) = do+ M.basicClear as+ M.basicClear bs+ {-# INLINE basicSet #-}+ basicSet (MFingerprintVector as bs) (Fingerprint a b) = do+ M.basicSet as a+ M.basicSet bs b+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do+ M.basicUnsafeCopy as1 as2+ M.basicUnsafeCopy bs1 bs2+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do+ M.basicUnsafeMove as1 as2+ M.basicUnsafeMove bs1 bs2+ {-# INLINE basicUnsafeGrow #-}+ basicUnsafeGrow (MFingerprintVector as bs) m_ = do+ as' <- M.basicUnsafeGrow as m_+ bs' <- M.basicUnsafeGrow bs m_+ return $ MFingerprintVector as' bs'++instance G.Vector Unboxed.Vector Fingerprint where+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeFreeze (MFingerprintVector as bs) = do+ as' <- G.basicUnsafeFreeze as+ bs' <- G.basicUnsafeFreeze bs+ return $ FingerprintVector as' bs'+ {-# INLINE basicUnsafeThaw #-}+ basicUnsafeThaw (FingerprintVector as bs) = do+ as' <- G.basicUnsafeThaw as+ bs' <- G.basicUnsafeThaw bs+ return $ MFingerprintVector as' bs'+ {-# INLINE basicLength #-}+ basicLength (FingerprintVector x _) = G.basicLength x+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i_ m_ (FingerprintVector as bs) =+ FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs)+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeIndexM (FingerprintVector as bs) i_ = do+ a <- G.basicUnsafeIndexM as i_+ b <- G.basicUnsafeIndexM bs i_+ return (Fingerprint a b)+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do+ G.basicUnsafeCopy as1 as2+ G.basicUnsafeCopy bs1 bs2+ {-# INLINE elemseq #-}+ elemseq _ (Fingerprint a b)+ = G.elemseq (undefined :: Unboxed.Vector a) a+ . G.elemseq (undefined :: Unboxed.Vector b) b++data TypeRepVector f = TypeRepVect+ { fingerprints :: Unboxed.Vector Fingerprint+ , anys :: V.Vector Any+ }++fromAny :: Any -> f a+fromAny = unsafeCoerce++-- | Empty structure.+empty :: TypeRepVector f+empty = TypeRepVect mempty mempty++-- | Inserts the value with its type as a key.+insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f+insert = 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 tVect = fromAny . (anys tVect V.!)+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)++-- | Returns the size of the 'TypeRepVect'.+size :: TypeRepVector f -> Int+size = Unboxed.length . fingerprints++data TF f where+ TF :: Typeable a => f a -> TF f++fromF :: Typeable a => f a -> Proxy a+fromF _ = Proxy++fromList :: forall f . [TF f] -> TypeRepVector f+fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)+ where+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs++ fp :: TF f -> Fingerprint+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x++ an :: TF f -> Any+ an (TF x) = unsafeCoerce x++-- | Returns the index is found.+binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int+binarySearch fp fpVect =+ let+ !(I# len) = Unboxed.length fpVect+ ind = I# (binSearchHelp (-1#) len)+ in+ if fp == (fpVect Unboxed.! ind) then Just ind else Nothing+ where+ binSearchHelp :: Int# -> Int# -> Int#+ binSearchHelp l r = case l <# (r -# 1#) of+ 0# -> r+ _ ->+ let m = uncheckedIShiftRA# (l +# r) 1# in+ if Unboxed.unsafeIndex fpVect (I# m) < fp+ then binSearchHelp m r+ else binSearchHelp l m
+ typerep-map.cabal view
@@ -0,0 +1,119 @@+name: typerep-map+version: 0.1.0+synopsis: Efficient implementation of a dependent map with types as keys+description:+ A dependent map from type representations to values of these types.+ .+ Here is an illustration of such a map:+ .+ > TMap+ > ---------------+ > Int -> 5+ > Bool -> True+ > Char -> 'x'+ .+ In addition to @TMap@, we provide @TypeRepMap@ parametrized by a+ @vinyl@-style interpretation. This data structure is equivalent to @DMap+ TypeRep@, but with significantly more efficient lookups.++homepage: https://github.com/kowainik/typerep-map+bug-reports: https://github.com/kowainik/typerep-map/issues+license: MIT+license-file: LICENSE+author: Kowainik, Vladislav Zavialov+maintainer: xrom.xkov@gmail.com+copyright: 2017-2018 Kowainik+category: Data, Data Structures, Types+build-type: Simple+extra-doc-files: README.md+ , CHANGELOG.md+cabal-version: 2.0+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.3++source-repository head+ type: git+ location: https://github.com/kowainik/typerep-map.git++library+ hs-source-dirs: src+ exposed-modules: Data.TMap+ Data.TypeRepMap+ Data.TypeRepMap.Internal+ ghc-options: -Wall+ build-depends: base >= 4.9 && < 5+ , containers+ , ghc-prim+ , primitive >= 0.6.4+ default-extensions: OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ default-language: Haskell2010++library typerep-extra-impls+ hs-source-dirs: typerep-extra-impls+ exposed-modules: Data.TypeRep.CMap+ Data.TypeRep.OptimalVector+ Data.TypeRep.Vector+ ghc-options: -Wall+ build-depends: base+ , containers+ , vector+ default-extensions: OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ TypeApplications++ default-language: Haskell2010++test-suite typerep-map-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ other-modules: Test.TypeRep.CMap+ , Test.TypeRep.CacheMap+ , Test.TypeRep.MapProperty+ , Test.TypeRep.Vector+ , Test.TypeRep.VectorOpt+ build-depends: base+ , ghc-typelits-knownnat+ , hedgehog+ , typerep-map+ , typerep-extra-impls+ , tasty+ , tasty-discover >= 4.1.1+ , tasty-hedgehog+ , tasty-hspec+ build-tool-depends: tasty-discover:tasty-discover+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-extensions: ScopedTypeVariables+ TypeApplications++ default-language: Haskell2010++benchmark typerep-map-benchmark+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0+ hs-source-dirs: benchmark+ main-is: Main.hs+ other-modules: CMap+ , CacheMap+ , Vector+ , OptimalVector+ build-depends: base+ , criterion+ , deepseq+ , dependent-map+ , dependent-sum+ , ghc-typelits-knownnat+ , typerep-map+ , typerep-extra-impls+ default-extensions: OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ if impl(ghc >= 8.2.2)+ other-modules: DMap