hetero-dict (empty) → 0.1.0.0
raw patch · 9 files changed
+822/−0 lines, 9 filesdep +basedep +containersdep +criterionsetup-changed
Dependencies added: base, containers, criterion, deepseq, hetero-dict, hvect, primitive, template-haskell
Files
- ChangeLog.md +5/−0
- Data/Hetero/Dict.hs +187/−0
- Data/Hetero/DynDict.hs +150/−0
- Data/Hetero/KVList.hs +97/−0
- LICENSE +20/−0
- README.md +139/−0
- Setup.hs +2/−0
- bench/Bench.hs +184/−0
- hetero-dict.cabal +38/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for hetero-array++## 0.1.0.0 -- 2016-05-31++* First version. extract from web-routing, drop GHC 7.6 support.
+ Data/Hetero/Dict.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++-- | Fast read-only heterogeneous array.+--+-- This module is extracted from <http://hackage.haskell.org/package/web-routing web-routing>,+-- orginally desgined for high performance type safe routing.+-- The basic idea is:+--+-- 1. Construct a heterogeneous linked-list is O(n), since prepend is O(1).+--+-- 2. Convert it into a heterogeneous array in O(n).+--+-- 3. Following access will be a simple O(1) array indexing,+-- with index computed at compile time so you can't get missing keys.+--+-- Typical usage: a heterogeneous lookup table, indexed by type level string.+--+-- @+-- > :set -XDataKinds -XQuasiQuotes+-- > let d = mkDict . add [key|foo|] 12 . add [key|bar|] "baz" $ emptyStore+-- > get [key|foo|] d+-- 12+-- > get [key|bar|] d+-- "baz"+-- @+--+module Data.Hetero.Dict+ (+ -- ** Store+ Store+ , emptyStore+ , add+ -- ** Dict+ , Dict+ , mkDict'+ , mkDict+ , InDict+ , get+ -- ** re-export from KVList+ , key+ , KV(..)+ , KVList(..)+ , NotHasKey+ , Ix+ -- ** helpers+ , ShowDict(..)+ ) where++import qualified Control.Monad.Primitive as P+import Control.Monad.ST (ST, runST)+import Data.Hetero.KVList+import Data.List (intercalate)+import qualified Data.Primitive.Array as P+import Data.Proxy+import Data.Typeable (TypeRep, Typeable, typeOf)+import GHC.Exts (Any)+import GHC.TypeLits+import Unsafe.Coerce++--------------------------------------------------------------------------------++-- | Heterogeneous linked-list with a size field.+--+-- use 'mkDict' to convert it into a 'Dict'.+--+data Store kvs = Store+ { storeSize :: {-# UNPACK #-} !Int+ , storeBody :: KVList kvs+ }++-- | An empty 'Store'+--+emptyStore :: Store '[]+emptyStore = Store 0 Empty+{-# INLINABLE emptyStore #-}+++-- | O(1) add key value pair to 'Store'.+--+-- @+-- > let a = add [key|foo|] (12 :: Int) emptyStore+-- > a+-- Store {foo = 12 :: Int}+-- > add [key|bar|] "baz" a+-- Store {bar = "baz" :: [Char], foo = 12 :: Int}+-- @+--+add :: (NotHasKey k kvs) => proxy k -> v -> Store kvs -> Store (k ':= v ': kvs)+add _ v (Store l c) = Store (l + 1) (Cons v c)+{-# INLINABLE add #-}++--------------------------------------------------------------------------------++-- | Read-Only heterogeneous array.+--+-- The underline data structure is a boxed array,+-- support 'get' operation only.+newtype Dict (kvs :: [KV *]) = Dict (P.Array Any)++-- | O(n) convert a 'Store' into a 'Dict' inside 'ST' monad.+--+mkDict' :: forall s kvs. Store kvs -> ST s (Dict kvs)+mkDict' store = do+ ary <- P.newArray (storeSize store) undefined+ go ary+ Dict `fmap` P.unsafeFreezeArray ary+ where+ go :: P.MutableArray (P.PrimState (ST s)) Any -> ST s ()+ go array = loop 0 (storeBody store)+ where+ loop :: Int -> KVList kvs' -> ST s ()+ loop !i (Cons v ss) = do+ P.writeArray array i (unsafeCoerce v)+ loop (i + 1) ss+ loop _ Empty = return ()+{-# INLINABLE mkDict' #-}++-- | O(n) convert "Store" to 'Dict'.+mkDict :: Store kvs -> Dict kvs+mkDict store = runST $ mkDict' store+{-# INLINABLE mkDict #-}++getImpl :: forall i proxy k kvs v. ('Index i ~ Ix k kvs, KnownNat i) => proxy (k :: Symbol) -> Dict kvs -> v+getImpl _ (Dict d) = unsafeCoerce $ d `P.indexArray` fromIntegral (natVal (Proxy :: Proxy i))+{-# INLINABLE getImpl #-}++-- | Constraint ensure 'Dict' must contain k-v pair.+--+class InDict (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where+ get' :: proxy k -> Dict kvs -> v++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} InDict k v (k ':= v ': kvs) where+#else+instance InDict k v (k ':= v ': kvs) where+#endif+ get' = getImpl+ {-# INLINE get' #-}++instance (InDict k v kvs, 'Index i ~ Ix k (k' ':= v' ': kvs), KnownNat i) => InDict k v (k' ':= v' ': kvs) where+ get' = getImpl+ {-# INLINE get' #-}++-- | O(1) get value using associated key from 'Dict'.+--+get :: InDict k v kvs => proxy k -> Dict kvs -> v+get = get'+{-# INLINE get #-}++--------------------------------------------------------------------------------++-- | Helper class for defining store's 'Show' instance.+class ShowDict (kvs :: [KV *]) where+ showDict :: Int -> Dict kvs -> [(String, String, TypeRep)]++instance ShowDict '[] where+ showDict _ _ = []++instance (KnownSymbol k, Typeable v, Show v, ShowDict kvs) => ShowDict (k ':= v ': kvs) where+ showDict i (Dict t) =+ (symbolVal (Proxy :: Proxy k), show (unsafeCoerce $ P.indexArray t i :: v), typeOf (undefined :: v)):+ showDict (i + 1) (unsafeCoerce $ Dict t :: Dict kvs)++instance ShowDict kvs => Show (Dict kvs) where+ show d = "Dict {" +++ (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d)+ ++ "}"++instance ShowDict kvs => Show (Store kvs) where+ show d = "Store {" +++ (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 (mkDict d))+ ++ "}"
+ Data/Hetero/DynDict.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++-- | Fast persistent heterogeneous sequence.+--+-- This module define 'DynDict', which use 'S.Seq' as underline data structure,+-- so all operations(add, get, modify, set)'s time complexity are similar.+--+-- Typical usage: a heterogeneous state store, indexed by type level string.+--+-- @+-- > :set -XDataKinds -XQuasiQuotes+-- > let d = add [key|foo|] 12 . add [key|bar|] "baz" $ empty+-- > get [key|foo|] d+-- 12+-- > get [key|bar|] d+-- "baz"+-- > let d' = set [key|foo] 13 d+-- > get [key|foo|] d'+-- 13+-- @+--+module Data.Hetero.DynDict+ (+ -- ** DynDict+ DynDict+ , empty+ , add+ , InDict+ , get+ , modify+ , set+ -- ** re-export from KVList+ , key+ , KV(..)+ , KVList(..)+ , NotHasKey+ , Ix+ -- ** Internal helpers+ , ShowDynDict(..)+ ) where++import Data.Hetero.KVList+import Data.List (intercalate)+import Data.Proxy+import qualified Data.Sequence as S+import Data.Typeable (TypeRep, Typeable, typeOf)+import GHC.Exts (Any)+import GHC.TypeLits+import Unsafe.Coerce++--------------------------------------------------------------------------------++-- | heterogeneous persistent sequence.+--+-- The underline data structure is 'S.Seq'.+-- support efficient 'add', 'get' and 'modify' operations.+newtype DynDict (kvs :: [KV *]) = DynDict (S.Seq Any)+++-- | A empty 'DynDict'.+--+empty :: DynDict '[]+empty = DynDict S.empty+{-# INLINABLE empty #-}++-- | O(1) insert new k-v pair into 'DynDict'.+add :: (NotHasKey k kvs) => proxy k -> v -> DynDict kvs -> DynDict (k ':= v ': kvs)+add _ v (DynDict d) = DynDict (unsafeCoerce v S.<| d)+{-# INLINE add #-}++getImpl :: forall i proxy k kvs v. ('Index i ~ Ix k kvs, KnownNat i) => proxy (k :: Symbol) -> DynDict kvs -> v+getImpl _ (DynDict d) = unsafeCoerce $ d `S.index` fromIntegral (natVal (Proxy :: Proxy i))+{-# INLINABLE getImpl #-}++modifyImpl :: forall i proxy k kvs v. ('Index i ~ Ix k kvs, KnownNat i) => proxy (k :: Symbol) -> (v -> v) -> DynDict kvs -> DynDict kvs+modifyImpl _ f (DynDict d) = DynDict $+ S.adjust (unsafeCoerce . f . unsafeCoerce) (fromIntegral (natVal (Proxy :: Proxy i))) d+{-# INLINABLE modifyImpl #-}++-- | Constraint ensure 'DynDict' must contain k-v pair.+--+class InDict (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where+ get' :: proxy k -> DynDict kvs -> v+ modify' :: proxy k -> (v -> v) -> DynDict kvs -> DynDict kvs++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} InDict k v (k ':= v ': kvs) where+#else+instance InDict k v (k ':= v ': kvs) where+#endif+ get' = getImpl+ {-# INLINE get' #-}+ modify' = modifyImpl+ {-# INLINE modify' #-}++instance (InDict k v kvs, 'Index i ~ Ix k (k' ':= v' ': kvs), KnownNat i) => InDict k v (k' ':= v' ': kvs) where+ get' = getImpl+ {-# INLINE get' #-}+ modify' = modifyImpl+ {-# INLINE modify' #-}++-- | O(log(min(i,n-i))) get value using associated key.+--+get :: InDict k v kvs => proxy k -> DynDict kvs -> v+get = get'+{-# INLINE get #-}++-- | O(log(min(i,n-i))) modify value by associated key.+modify :: (InDict k v kvs) => proxy k -> (v -> v) -> DynDict kvs -> DynDict kvs+modify = modify'+{-# INLINE modify #-}++-- | O(log(min(i,n-i))) modify value by associated key.+set :: (InDict k v kvs) => proxy k -> v -> DynDict kvs -> DynDict kvs+set p v = modify' p (const v)+{-# INLINE set #-}++--------------------------------------------------------------------------------++-- | Helper class for defining store's 'Show' instance.+class ShowDynDict (kvs :: [KV *]) where+ showDict :: Int -> DynDict kvs -> [(String, String, TypeRep)]++instance ShowDynDict '[] where+ showDict _ _ = []++instance (KnownSymbol k, Typeable v, Show v, ShowDynDict kvs) => ShowDynDict (k ':= v ': kvs) where+ showDict i (DynDict t) =+ (symbolVal (Proxy :: Proxy k), show (unsafeCoerce $ t `S.index` i :: v), typeOf (undefined :: v)):+ showDict (i + 1) (unsafeCoerce $ DynDict t :: DynDict kvs)++instance ShowDynDict kvs => Show (DynDict kvs) where+ show d = "Dict {" +++ (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d)+ ++ "}"
+ Data/Hetero/KVList.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | A simple heterogeneous linked-list for k-v pairs.+--+module Data.Hetero.KVList+ ( KV(..)+ , KVList(..)+ , key+ , AddKey+ , AddResult(..)+ , NotHasKey+ , GetResult(..)+ , Ix+ ) where++import Data.Proxy+import GHC.TypeLits+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote (QuasiQuoter (..))++--------------------------------------------------------------------------------++-- | (kind) key-value pair+--+data KV v = Symbol := v++-- | A simple heterogeneous kv linked-list.+--+data KVList (kvs :: [KV *]) where+ Cons :: v -> KVList kvs -> KVList (k ':= v ': kvs)+ Empty :: KVList '[]+++-- | Quoter for constructing string literal proxy.+--+-- @[key|foo|] == (Proxy :: Proxy "foo")@+--+key :: QuasiQuoter+key = QuasiQuoter+ { quoteExp = \s -> [| Proxy :: Proxy $(TH.litT $ TH.strTyLit s) |]+ , quotePat = error "key qq only exp or type."+ , quoteType = \s -> [t| Proxy $(TH.litT $ TH.strTyLit s) |]+ , quoteDec = error "key qq only exp or type."+ }++-- | (kind) pretty print type error for 'NotHasKey'.+--+-- @+-- > add [key|foo|] 12 $ add [key|foo|] "a" emptyStore+-- Couldn't match type ‘'DuplicatedKey "foo"’ with ‘'HasKey "foo"’+-- @+--+data AddResult = HasKey Symbol | DuplicatedKey Symbol++-- | Add a key's type to 'KVList' if not existed.+--+type family AddKey (k :: Symbol) (kvs :: [KV *]) :: AddResult where+ AddKey k '[] = 'HasKey k+ AddKey k (k ':= v ': kvs) = 'DuplicatedKey k+ AddKey k (k' ':= v ': kvs) = AddKey k kvs++-- | Constraint ensure a key will be inserted into 'Store'.+--+type NotHasKey k kvs = AddKey k kvs ~ 'HasKey k++-- | (kind) pretty print type error for 'Ix'+--+-- @+-- > get [key|b|] (mkDict $ add [key|a|] 123 emptyStore)+-- Couldn't match type ‘'Index i0’ with ‘'NotFoundKey "b"’+-- @+--+data GetResult = Index Nat | NotFoundKey Symbol++type family Ix' (i :: Nat) (k :: Symbol) (kvs :: [KV *]) :: GetResult where+ Ix' i k '[] = 'NotFoundKey k+ Ix' i k (k ':= v ': kvs) = 'Index i+ Ix' i k (k' ':= v ': kvs) = Ix' (i + 1) k kvs+++-- | Indexing a key at compile time.+--+type Ix k kvs = Ix' 0 k kvs
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 HirotomoMoriwaki, 2016 winterland1989++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,139 @@+hetero-dict: fast heterogeneous data structures+===============================================++[](https://travis-ci.org/winterland1989/hetero-dict)++This package provide two flavor fast and easy to use heterogeneous data structures:++1. `Dict` which use boxed array, it's read-only with O(1) get.++1. `DynDict` which use `Seq` from `Data.Sequence`, it has O(log(min(i,n-i))) get, modify and O(1) add.++Example+-------++```haskell+> :set -XDataKinds -XQuasiQuotes+> :m + Data.Hetero.Dict+> let d = mkDict . add [key|foo|] 12 . add [key|bar|] "baz" $ emptyStore+> :t d+d :: Num v => Dict '["foo" ':= v, "bar" ':= [Char]]+> get [key|foo|] d+12+> get [key|bar|] d+"baz"+> get [key|qux|] d+ • Couldn't match type ‘'Index i1’ with ‘'NotFoundKey "qux"’+ ...+```++```haskell+> :set -XDataKinds -XQuasiQuotes+> :m + Data.Hetero.DynDict+> let d = add [key|foo|] 12 . add [key|bar|] "baz" $ empty+> get [key|foo|] d+12+> get [key|bar|] d+"baz"+> let d' = set [key|foo] 13 d+> get [key|foo|] d'+13+```++Benchmark+---------++We use [hvect](http://hackage.haskell.org/package/hvect) package as a linked-list based reference.++```+benchmarking n = 3/Build Dict+time 11.78 ns (11.63 ns .. 11.93 ns)+ 0.999 R² (0.999 R² .. 1.000 R²)+mean 11.72 ns (11.62 ns .. 11.82 ns)+std dev 336.9 ps (282.4 ps .. 406.1 ps)+variance introduced by outliers: 48% (moderately inflated)++benchmarking n = 3/Build DynDict+time 18.10 ns (17.96 ns .. 18.24 ns)+ 0.998 R² (0.995 R² .. 1.000 R²)+mean 18.42 ns (18.10 ns .. 19.84 ns)+std dev 1.676 ns (550.3 ps .. 3.725 ns)+variance introduced by outliers: 90% (severely inflated)++benchmarking n = 3/Build HVect+time 16.39 ns (15.90 ns .. 17.05 ns)+ 0.994 R² (0.990 R² .. 0.998 R²)+mean 16.72 ns (16.34 ns .. 17.31 ns)+std dev 1.686 ns (1.254 ns .. 2.193 ns)+variance introduced by outliers: 92% (severely inflated)++benchmarking n = 3/Index Dict+time 56.35 ns (54.47 ns .. 58.42 ns)+ 0.990 R² (0.986 R² .. 0.995 R²)+mean 55.85 ns (54.31 ns .. 57.90 ns)+std dev 5.972 ns (4.253 ns .. 7.946 ns)+variance introduced by outliers: 92% (severely inflated)++benchmarking n = 3/Index DynDict+time 72.03 ns (70.14 ns .. 74.63 ns)+ 0.989 R² (0.980 R² .. 0.995 R²)+mean 75.49 ns (73.19 ns .. 78.75 ns)+std dev 9.245 ns (7.589 ns .. 11.76 ns)+variance introduced by outliers: 94% (severely inflated)++benchmarking n = 3/Index HVect+time 69.21 ns (67.27 ns .. 71.86 ns)+ 0.994 R² (0.989 R² .. 0.999 R²)+mean 68.69 ns (67.69 ns .. 70.13 ns)+std dev 4.080 ns (2.918 ns .. 5.949 ns)+variance introduced by outliers: 78% (severely inflated)++benchmarking n = 15/Build Dict+time 10.80 ns (10.65 ns .. 10.97 ns)+ 0.997 R² (0.995 R² .. 1.000 R²)+mean 10.85 ns (10.71 ns .. 11.15 ns)+std dev 628.9 ps (344.3 ps .. 1.078 ns)+variance introduced by outliers: 79% (severely inflated)++benchmarking n = 15/Build DynDict+time 37.11 ns (36.55 ns .. 37.94 ns)+ 0.997 R² (0.994 R² .. 0.999 R²)+mean 37.77 ns (37.04 ns .. 38.72 ns)+std dev 2.827 ns (2.096 ns .. 3.682 ns)+variance introduced by outliers: 86% (severely inflated)++benchmarking n = 15/Build HVect+time 15.82 ns (15.23 ns .. 16.59 ns)+ 0.991 R² (0.985 R² .. 0.999 R²)+mean 15.61 ns (15.31 ns .. 16.07 ns)+std dev 1.221 ns (803.7 ps .. 1.757 ns)+variance introduced by outliers: 87% (severely inflated)++benchmarking n = 15/Index Dict+time 281.6 ns (279.6 ns .. 283.8 ns)+ 0.999 R² (0.999 R² .. 1.000 R²)+mean 281.7 ns (279.9 ns .. 283.9 ns)+std dev 6.878 ns (5.580 ns .. 8.830 ns)+variance introduced by outliers: 34% (moderately inflated)++benchmarking n = 15/Index DynDict+time 659.2 ns (652.3 ns .. 665.6 ns)+ 0.999 R² (0.998 R² .. 0.999 R²)+mean 662.4 ns (656.8 ns .. 669.8 ns)+std dev 22.28 ns (17.73 ns .. 30.08 ns)+variance introduced by outliers: 48% (moderately inflated)++benchmarking n = 15/Index HVect+time 693.4 ns (687.0 ns .. 698.7 ns)+ 0.999 R² (0.999 R² .. 1.000 R²)+mean 690.7 ns (683.2 ns .. 695.8 ns)+std dev 20.66 ns (16.34 ns .. 29.80 ns)+variance introduced by outliers: 42% (moderately inflated)++benchmarking n = 15/Modify DynDict+time 98.74 ns (97.12 ns .. 100.8 ns)+ 0.998 R² (0.997 R² .. 0.999 R²)+mean 98.60 ns (97.18 ns .. 100.1 ns)+std dev 5.091 ns (3.999 ns .. 6.935 ns)+variance introduced by outliers: 72% (severely inflated)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}++module Main (main) where++import Criterion.Main+import qualified Data.Hetero.Dict as D+import qualified Data.Hetero.DynDict as DD+import Data.HVect (HVect(..), (!!), SNat(..))+import Data.Hetero.KVList+import Prelude hiding ((!!))++main :: IO ()+main = defaultMain+ [ bgroup "n = 3" small+ , bgroup "n = 15" large+ ]++small :: [Benchmark]+small =+ [ bench "Build Dict" $ nf (D.get [key|qux0|]) dict+ , bench "Build DynDict" $ nf (DD.get [key|qux0|]) dynDict+ , bench "Build HVect" $ nf ((SSucc SZero)!!) hvect+ , bench "Index Dict" $ nf getAllDict dict+ , bench "Index DynDict" $ nf getAllDynDict dynDict+ , bench "Index HVect" $ nf getAllHVect hvect+ ]+ where+ hvect = (1 :: Int) :&: (1 :: Int)+ :&: "bar"+ :&: True+ :&: HNil++ getAllDict d =+ ( D.get [key|foo0|] d+ , D.get [key|bar0|] d+ , D.get [key|qux0|] d+ )++ dict = D.mkDict . D.add [key|foo0|] (1 :: Int)+ . D.add [key|bar0|] "bar"+ . D.add [key|qux0|] True+ $ D.emptyStore++ getAllDynDict d =+ ( DD.get [key|foo0|] d+ , DD.get [key|bar0|] d+ , DD.get [key|qux0|] d+ )++ getAllHVect v =+ ( ((SZero)!!) v+ , ((SSucc SZero)!!) v+ , ((SSucc $ SSucc SZero)!!) v+ )++ dynDict = DD.add [key|foo0|] (1 :: Int)+ . DD.add [key|bar0|] "bar"+ . DD.add [key|qux0|] True+ $ DD.empty++large :: [Benchmark]+large =+ [ bench "Build Dict" $ nf (D.get [key|qux0|]) dict+ , bench "Build DynDict" $ nf (DD.get [key|qux0|]) dynDict+ , bench "Build HVect" $ nf ((SSucc SZero)!!) hvect+ , bench "Index Dict" $ nf getAllDict dict+ , bench "Index DynDict" $ nf getAllDynDict dynDict+ , bench "Index HVect" $ nf getAllHVect hvect+ , bench "Modify DynDict" $ nf (DD.get [key|qux0|] . DD.modify [key|qux0|] not) dynDict+ ]+ where+ getAllDict d = (+ ( D.get [key|foo0|] d+ , D.get [key|foo1|] d+ , D.get [key|foo2|] d+ , D.get [key|foo3|] d+ , D.get [key|foo4|] d+ ),+ ( D.get [key|bar0|] d+ , D.get [key|bar1|] d+ , D.get [key|bar2|] d+ , D.get [key|bar3|] d+ , D.get [key|bar4|] d+ ),+ ( D.get [key|qux0|] d+ , D.get [key|qux1|] d+ , D.get [key|qux2|] d+ , D.get [key|qux3|] d+ , D.get [key|qux4|] d+ ))++ getAllDynDict d = (+ ( DD.get [key|foo0|] d+ , DD.get [key|foo1|] d+ , DD.get [key|foo2|] d+ , DD.get [key|foo3|] d+ , DD.get [key|foo4|] d+ ),+ ( DD.get [key|bar0|] d+ , DD.get [key|bar1|] d+ , DD.get [key|bar2|] d+ , DD.get [key|bar3|] d+ , DD.get [key|bar4|] d+ ),+ ( DD.get [key|qux0|] d+ , DD.get [key|qux1|] d+ , DD.get [key|qux2|] d+ , DD.get [key|qux3|] d+ , DD.get [key|qux4|] d+ ))++ getAllHVect v = (+ ( ((SZero)!!) v+ , ((SSucc SZero)!!) v+ , ((SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ ),+ ( ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ ),+ ( ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ , ((SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero)!!) v+ ))++ hvect = (1 :: Int) :&: (1 :: Int)+ :&: (1 :: Int)+ :&: (1 :: Int)+ :&: (1 :: Int)+ :&: (1 :: Int)+ :&: "bar"+ :&: "bar"+ :&: "bar"+ :&: "bar"+ :&: "bar"+ :&: True+ :&: True+ :&: True+ :&: True+ :&: True+ :&: HNil+++ dict = D.mkDict . D.add [key|foo0|] (1 :: Int)+ . D.add [key|foo1|] (1 :: Int)+ . D.add [key|foo2|] (1 :: Int)+ . D.add [key|foo3|] (1 :: Int)+ . D.add [key|foo4|] (1 :: Int)+ . D.add [key|bar0|] "bar"+ . D.add [key|bar1|] "bar"+ . D.add [key|bar2|] "bar"+ . D.add [key|bar3|] "bar"+ . D.add [key|bar4|] "bar"+ . D.add [key|qux0|] True+ . D.add [key|qux1|] True+ . D.add [key|qux2|] True+ . D.add [key|qux3|] True+ . D.add [key|qux4|] True+ $ D.emptyStore++ dynDict = DD.add [key|foo0|] (1 :: Int)+ . DD.add [key|foo1|] (1 :: Int)+ . DD.add [key|foo2|] (1 :: Int)+ . DD.add [key|foo3|] (1 :: Int)+ . DD.add [key|foo4|] (1 :: Int)+ . DD.add [key|bar0|] "bar"+ . DD.add [key|bar1|] "bar"+ . DD.add [key|bar2|] "bar"+ . DD.add [key|bar3|] "bar"+ . DD.add [key|bar4|] "bar"+ . DD.add [key|qux0|] True+ . DD.add [key|qux1|] True+ . DD.add [key|qux2|] True+ . DD.add [key|qux3|] True+ . DD.add [key|qux4|] True+ $ DD.empty
+ hetero-dict.cabal view
@@ -0,0 +1,38 @@+name: hetero-dict+version: 0.1.0.0+synopsis: Fast read-only heterogeneous data structures+description: Fast read-only heterogeneous data structures+license: MIT+license-file: LICENSE+author: Hirotomo Moriwaki <philopon.dependence@gmail.com>,+ Winterland <drkoster@qq.com>+maintainer: drkoster@qq.com+copyright: (c) 2014-2015 Hirotomo Moriwaki, 2016 Winterland+category: Data+build-type: Simple+extra-source-files: ChangeLog.md, README.md+cabal-version: >=1.10++library+ exposed-modules: Data.Hetero.Dict+ , Data.Hetero.DynDict+ , Data.Hetero.KVList++ build-depends: base >=4.7 && <5.0+ , primitive >=0.5 && <0.7+ , template-haskell >=2.9 && <2.12+ , containers >=0.4.2.0 && <0.6++ ghc-options: -Wall -O2+ default-language: Haskell2010++benchmark criterion+ build-depends: base, deepseq, hvect, hetero-dict, criterion == 1.1.*+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Bench.hs+ type: exitcode-stdio-1.0++source-repository head+ type: git+ location: https://github.com/winterland1989/hetero-dict.git