diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,55 @@ +# typerep-map + +[![Hackage](https://img.shields.io/hackage/v/typerep-map.svg)](https://hackage.haskell.org/package/typerep-map) +[![Build status](https://secure.travis-ci.org/kowainik/typerep-map.svg)](https://travis-ci.org/kowainik/typerep-map) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](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 +:---------:|:-----------: +![DMap 8.2.2](https://user-images.githubusercontent.com/4276606/42495129-c700f21e-8454-11e8-98b4-ba080259c712.png) | ![DMap 8.4.3](https://user-images.githubusercontent.com/4276606/42495168-ebb1d13c-8454-11e8-9d17-f6da29d2169a.png) +![TMap 8.2.2](https://user-images.githubusercontent.com/4276606/42494935-3a352d96-8454-11e8-985e-ebc77cc51ca0.png) | ![TMap 8.4.3](https://user-images.githubusercontent.com/4276606/42495147-d884bdf4-8454-11e8-887f-9815fd2b8d68.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/CMap.hs b/benchmark/CMap.hs new file mode 100644 --- /dev/null +++ b/benchmark/CMap.hs @@ -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) diff --git a/benchmark/CacheMap.hs b/benchmark/CacheMap.hs new file mode 100644 --- /dev/null +++ b/benchmark/CacheMap.hs @@ -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)) diff --git a/benchmark/DMap.hs b/benchmark/DMap.hs new file mode 100644 --- /dev/null +++ b/benchmark/DMap.hs @@ -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 diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -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 + ] diff --git a/benchmark/OptimalVector.hs b/benchmark/OptimalVector.hs new file mode 100644 --- /dev/null +++ b/benchmark/OptimalVector.hs @@ -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) diff --git a/benchmark/Vector.hs b/benchmark/Vector.hs new file mode 100644 --- /dev/null +++ b/benchmark/Vector.hs @@ -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) diff --git a/src/Data/TMap.hs b/src/Data/TMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/TMap.hs @@ -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 #-} diff --git a/src/Data/TypeRepMap.hs b/src/Data/TypeRepMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypeRepMap.hs @@ -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 diff --git a/src/Data/TypeRepMap/Internal.hs b/src/Data/TypeRepMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypeRepMap/Internal.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/Test/TypeRep/CMap.hs b/test/Test/TypeRep/CMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/CMap.hs @@ -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 diff --git a/test/Test/TypeRep/CacheMap.hs b/test/Test/TypeRep/CacheMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/CacheMap.hs @@ -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 diff --git a/test/Test/TypeRep/MapProperty.hs b/test/Test/TypeRep/MapProperty.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/MapProperty.hs @@ -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" diff --git a/test/Test/TypeRep/Vector.hs b/test/Test/TypeRep/Vector.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/Vector.hs @@ -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') diff --git a/test/Test/TypeRep/VectorOpt.hs b/test/Test/TypeRep/VectorOpt.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/VectorOpt.hs @@ -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') diff --git a/typerep-extra-impls/Data/TypeRep/CMap.hs b/typerep-extra-impls/Data/TypeRep/CMap.hs new file mode 100644 --- /dev/null +++ b/typerep-extra-impls/Data/TypeRep/CMap.hs @@ -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 diff --git a/typerep-extra-impls/Data/TypeRep/OptimalVector.hs b/typerep-extra-impls/Data/TypeRep/OptimalVector.hs new file mode 100644 --- /dev/null +++ b/typerep-extra-impls/Data/TypeRep/OptimalVector.hs @@ -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 diff --git a/typerep-extra-impls/Data/TypeRep/Vector.hs b/typerep-extra-impls/Data/TypeRep/Vector.hs new file mode 100644 --- /dev/null +++ b/typerep-extra-impls/Data/TypeRep/Vector.hs @@ -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 diff --git a/typerep-map.cabal b/typerep-map.cabal new file mode 100644 --- /dev/null +++ b/typerep-map.cabal @@ -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