diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/Data/Hetero/Dict.hs b/Data/Hetero/Dict.hs new file mode 100644 --- /dev/null +++ b/Data/Hetero/Dict.hs @@ -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 , +-- 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)) + ++ "}" diff --git a/Data/Hetero/DynDict.hs b/Data/Hetero/DynDict.hs new file mode 100644 --- /dev/null +++ b/Data/Hetero/DynDict.hs @@ -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) + ++ "}" diff --git a/Data/Hetero/KVList.hs b/Data/Hetero/KVList.hs new file mode 100644 --- /dev/null +++ b/Data/Hetero/KVList.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,139 @@ +hetero-dict: fast heterogeneous data structures +=============================================== + +[![Travis-CI](https://travis-ci.org/winterland1989/hetero-dict.svg)](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) +``` 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/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/hetero-dict.cabal b/hetero-dict.cabal new file mode 100644 --- /dev/null +++ b/hetero-dict.cabal @@ -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 , + Winterland +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