hetero-dict 0.1.0.1 → 0.1.1.0

raw patch · 8 files changed

+303/−154 lines, 8 filesdep +aesondep +textdep +unordered-containersdep −containersdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, text, unordered-containers, vinyl

Dependencies removed: containers

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Data/Hetero/Dict.hs +10/−7
• Data/Hetero/DynDict.hs +66/−54
• Data/Hetero/KVList.hs +2/−2
• README.md +56/−75
• bench/Bench.hs +77/−12
• bench/ProxySymbolTH.hs +79/−0
• hetero-dict.cabal +7/−4

@@ -1,5 +1,11 @@ # Revision history for hetero-dict +## 0.1.1.0  -- 2016-05-31++* Change DynDict's implementation to linked-list.++* add From/ToJSON instance to DynDict.+ ## 0.1.0.1  -- 2016-05-31  * fix DynDict's Show instance.

@@ -28,6 +28,9 @@ --      3. Following access will be a simple O(1) array indexing, --      with index computed at compile time so you can't get missing keys. --+-- In theory, it's faster than linked-list based data structures when n is large,+-- but it needs more benchmark to be sure.+-- -- Typical usage: a heterogeneous lookup table, indexed by type level string. -- -- @@@ -42,7 +45,7 @@ module Data.Hetero.Dict     (     -- ** Store-      Store+      Store(..)     , emptyStore     , add     -- ** Dict@@ -87,7 +90,7 @@ -- emptyStore :: Store '[] emptyStore = Store 0 Empty-{-# INLINABLE emptyStore #-}+{-# INLINE emptyStore #-}   -- | O(1) add key value pair to 'Store'.@@ -100,9 +103,9 @@ -- Store {bar = "baz" :: [Char], foo = 12 :: Int} -- @ ---add :: (NotHasKey k kvs) => proxy k -> v -> Store kvs -> Store (k ':= v ': kvs)+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 #-}+{-# INLINE add #-}  -------------------------------------------------------------------------------- @@ -135,14 +138,14 @@ 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 :: forall i 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+    get' :: Proxy k -> Dict kvs -> v  #if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} InDict k v (k ':= v ': kvs) where@@ -158,7 +161,7 @@  -- | O(1) get value using associated key from 'Dict'. ---get :: InDict k v kvs => proxy k -> Dict kvs -> v+get :: InDict k v kvs => Proxy k -> Dict kvs -> v get = get' {-# INLINE get #-} 

@@ -15,10 +15,13 @@ {-# LANGUAGE OverlappingInstances   #-} #endif --- | Fast persistent heterogeneous sequence.+-- | Fast persistent heterogeneous list. ----- This module define 'DynDict', which use 'S.Seq' as underline data structure,--- so all operations(add, get, modify, set)'s time complexity are similar.+-- This module define 'DynDict', which wrap a 'KVList' linked-list,+-- benchmark showed that it's faster than previouse @Data.Sequence@ version,+-- since usually the element number is small(<20).+-- so even operations(add, get, modify, set)'s time complexity+-- are not as good as 'Seq', it's constantly faster in practice. -- -- Typical usage: a heterogeneous state store, indexed by type level string. --@@ -44,107 +47,116 @@     , get     , modify     , set+    , size     -- ** re-export from KVList     , key     , KV(..)     , KVList(..)     , NotHasKey     , Ix-    -- ** Internal helpers-    , ShowDynDict(..)     ) where  import           Data.Hetero.KVList+import           Data.Hetero.Dict (Store(..), ShowDict(..), mkDict) 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+import           Data.Proxy (Proxy(..))+import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Object))+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T  --------------------------------------------------------------------------------  -- | 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)-+newtype DynDict (kvs :: [KV *]) = DynDict (KVList kvs)  -- | A empty 'DynDict'. -- empty :: DynDict '[]-empty = DynDict S.empty-{-# INLINABLE empty #-}+empty = DynDict Empty+{-# INLINE 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)+add :: (NotHasKey k kvs) => Proxy k -> v -> DynDict kvs -> DynDict (k ':= v ': kvs)+add _ v (DynDict kvs) = DynDict (Cons v kvs) {-# 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+    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+    get' _ (DynDict (Cons v _)) =  v     {-# INLINE get' #-}-    modify' = modifyImpl+    modify' _ f (DynDict (Cons v kvs)) = DynDict $ Cons (f v) kvs     {-# 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+    get' p (DynDict (Cons _ kvs)) =  get' p (DynDict kvs)     {-# INLINE get' #-}-    modify' = modifyImpl+    modify' p f (DynDict (Cons v kvs)) =+        let DynDict kvs' = modify' p f (DynDict kvs)+        in DynDict (Cons v kvs')     {-# INLINE modify' #-} --- | O(log(min(i,n-i))) get value using associated key.+-- | O(m) get value using associated key. ---get :: InDict k v kvs => proxy k -> DynDict kvs -> v+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+-- | O(m) 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+-- | O(m) 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 #-} +-- | O(n) size+size :: DynDict kvs -> Int+size (DynDict Empty) = 0+size (DynDict (Cons _ kvs)) = 1 + size (DynDict kvs)+{-# INLINE size #-}+ -------------------------------------------------------------------------------- --- | Helper class for defining store's 'Show' instance.-class ShowDynDict (kvs :: [KV *]) where-    showDict :: Int -> DynDict kvs -> [(String, String, TypeRep)]+instance ShowDict kvs => Show (DynDict kvs) where+    show d@(DynDict kvs) = "DynDict {" +++        (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 (mkDict s))+        ++ "}"+      where+        s = Store (size d) kvs -instance ShowDynDict '[] where-    showDict _ _ = []+instance ToJSON (DynDict '[]) where+    toJSON _ = Object HM.empty -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 (KnownSymbol k, ToJSON v, ToJSON (DynDict kvs)) => ToJSON (DynDict (k ':= v ': kvs)) where+    toJSON (DynDict (Cons v kvs)) =+        let (Object obj) = toJSON (DynDict kvs)+            k = T.pack (symbolVal (Proxy :: Proxy k))+            obj' = HM.insert k (toJSON v) obj+        in Object obj' -instance ShowDynDict kvs => Show (DynDict kvs) where-    show d = "DynDict {" ++-        (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d)-        ++ "}"+instance FromJSON (DynDict '[]) where+    parseJSON (Object _) = return (DynDict Empty)+    parseJSON _          = fail "expect an object"++instance (KnownSymbol k, FromJSON v, FromJSON (DynDict kvs)) => FromJSON (DynDict (k ':= v ': kvs)) where+    parseJSON v@(Object obj) =+        let kString = symbolVal (Proxy :: Proxy k)+            k = T.pack kString+        in case HM.lookup k obj of+            Just v' -> do+                DynDict kvs <- parseJSON v+                v'' <- parseJSON v'+                return (DynDict (Cons v'' kvs))+            Nothing -> fail ("missing key: " ++ kString)+    parseJSON _          = fail "expect an object"

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns        #-} {-# LANGUAGE ConstraintKinds        #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-}@@ -37,7 +38,7 @@ -- | A simple heterogeneous kv linked-list. -- data KVList (kvs :: [KV *]) where-    Cons  :: v -> KVList kvs -> KVList (k ':= v ': kvs)+    Cons  :: !v -> KVList kvs -> KVList (k ':= v ': kvs)     Empty :: KVList '[]  @@ -86,7 +87,6 @@   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. --

@@ -8,8 +8,10 @@  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.+1. `DynDict` which use linked-list(see module document for details). +Features simple api, good performance and good error message, `Show` and `From/ToJSON` instances are provided.+ Example ------- @@ -44,97 +46,76 @@ Benchmark --------- -We use [hvect](http://hackage.haskell.org/package/hvect) package as a linked-list based reference.+We use [hvect](http://hackage.haskell.org/package/hvect) and [vinyl](http://hackage.haskell.org/package/vinyl) as references.  ```-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)+time                 8.656 ns   (8.396 ns .. 9.040 ns)+                     0.987 R²   (0.964 R² .. 0.999 R²)+mean                 8.784 ns   (8.503 ns .. 9.318 ns)+std dev              1.322 ns   (767.5 ps .. 2.059 ns)+variance introduced by outliers: 97% (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)+time                 6.400 ns   (6.340 ns .. 6.467 ns)+                     0.999 R²   (0.999 R² .. 1.000 R²)+mean                 6.394 ns   (6.348 ns .. 6.454 ns)+std dev              183.8 ps   (153.3 ps .. 230.6 ps)+variance introduced by outliers: 49% (moderately 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)+time                 14.12 ns   (13.99 ns .. 14.25 ns)+                     0.999 R²   (0.999 R² .. 1.000 R²)+mean                 14.09 ns   (13.95 ns .. 14.25 ns)+std dev              520.1 ps   (445.4 ps .. 608.7 ps)+variance introduced by outliers: 60% (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 = 3/Index Vinyl+time                 6.735 ns   (6.635 ns .. 6.849 ns)+                     0.999 R²   (0.998 R² .. 1.000 R²)+mean                 6.706 ns   (6.656 ns .. 6.763 ns)+std dev              186.4 ps   (142.7 ps .. 252.2 ps)+variance introduced by outliers: 47% (moderately inflated)  benchmarking n = 15/Index Dict-time                 281.6 ns   (279.6 ns .. 283.8 ns)+time                 9.482 ns   (9.395 ns .. 9.564 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)+mean                 9.460 ns   (9.387 ns .. 9.529 ns)+std dev              252.6 ps   (212.2 ps .. 328.3 ps)+variance introduced by outliers: 44% (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)+time                 10.66 ns   (10.47 ns .. 10.94 ns)+                     0.998 R²   (0.996 R² .. 1.000 R²)+mean                 10.52 ns   (10.43 ns .. 10.65 ns)+std dev              389.0 ps   (286.7 ps .. 575.8 ps)+variance introduced by outliers: 61% (severely inflated)  benchmarking n = 15/Index HVect-time                 693.4 ns   (687.0 ns .. 698.7 ns)+time                 14.35 ns   (14.24 ns .. 14.46 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)+mean                 14.35 ns   (14.20 ns .. 14.51 ns)+std dev              513.6 ps   (395.2 ps .. 693.4 ps)+variance introduced by outliers: 59% (severely inflated) +benchmarking n = 15/Index Vinyl+time                 11.62 ns   (11.47 ns .. 11.75 ns)+                     0.999 R²   (0.999 R² .. 0.999 R²)+mean                 11.63 ns   (11.52 ns .. 11.74 ns)+std dev              373.0 ps   (314.5 ps .. 452.0 ps)+variance introduced by outliers: 54% (severely inflated)+ benchmarking n = 15/Modify DynDict-time                 98.74 ns   (97.12 ns .. 100.8 ns)+time                 10.30 ns   (10.13 ns .. 10.50 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)+mean                 10.26 ns   (10.18 ns .. 10.38 ns)+std dev              335.2 ps   (260.3 ps .. 427.1 ps)+variance introduced by outliers: 55% (severely inflated)++benchmarking n = 15/Modify Vinyl+time                 11.74 ns   (11.60 ns .. 11.86 ns)+                     0.999 R²   (0.999 R² .. 0.999 R²)+mean                 11.67 ns   (11.55 ns .. 11.79 ns)+std dev              398.9 ps   (330.5 ps .. 487.9 ps)+variance introduced by outliers: 56% (severely inflated) ```

@@ -2,8 +2,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} +-- mostly for fget_qux0+{-# LANGUAGE TypeOperators, ExplicitNamespaces #-}+ module Main (main) where +import Data.Vinyl (Rec(..), FieldRec, type (∈))++import ProxySymbolTH -- stage restriction+ import Criterion.Main import qualified Data.Hetero.Dict as D import qualified Data.Hetero.DynDict as DD@@ -19,14 +26,28 @@  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+    [ bench "Index Dict"    $ nf (D.get [key|qux0|]) dict+    , bench "Index DynDict" $ nf (DD.get [key|qux0|]) dynDict+    , bench "Index HVect"   $ nf ((SSucc SZero) !!) hvect+    , bench "Index Vinyl"   $ nf (fget_qux0) vinyl     ]   where++    vinyl+        = field [ps|foo0|] (1 :: Int)+       :& field [ps|bar0|] "bar"+       :& field [ps|qux0|] True+       :& RNil++    getAllVinyl d =+      ( fget [ps|foo0|] d :: Int+       --NOTE the annotations are unnecessary with:+       -- type Bar0 = '("bar0",String)+       -- fget [pr|Bar0|] -- pr from Data.Tagged.TH+      , fget [ps|bar0|] d :: String+      , fget [ps|qux0|] d :: Bool+      )+     hvect = (1 :: Int)  :&: (1 :: Int)                         :&: "bar"                         :&: True@@ -62,15 +83,56 @@  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 "Index Dict"    $ nf (D.get [key|qux0|]) dict+    , bench "Index DynDict" $ nf (DD.get [key|qux0|]) dynDict+    , bench "Index HVect"   $ nf ((SSucc SZero)!!) hvect+    , bench "Index Vinyl"   $ nf (fget_qux0) vinyl+     , bench "Modify DynDict" $ nf (DD.get [key|qux0|] . DD.modify [key|qux0|] not) dynDict+    , bench "Modify Vinyl"   $ nf (fget_qux0 . fmodify [ps|qux0|] not) vinyl     ]+   where++    getAllVinyl d = (+        ( fget [ps|foo0|] d :: Int+        , fget [ps|foo1|] d :: Int+        , fget [ps|foo2|] d :: Int+        , fget [ps|foo3|] d :: Int+        , fget [ps|foo4|] d :: Int+        ),+        ( fget [ps|bar0|] d :: String+        , fget [ps|bar1|] d :: String+        , fget [ps|bar2|] d :: String+        , fget [ps|bar3|] d :: String+        , fget [ps|bar4|] d :: String+        ),+        ( fget [ps|qux0|] d :: Bool+        , fget [ps|qux1|] d :: Bool+        , fget [ps|qux2|] d :: Bool+        , fget [ps|qux3|] d :: Bool+        , fget [ps|qux4|] d :: Bool+        ))++    vinyl+        = field [ps|foo0|] (1 :: Int)+       :& field [ps|foo1|] (1 :: Int)+       :& field [ps|foo2|] (1 :: Int)+       :& field [ps|foo3|] (1 :: Int)+       :& field [ps|foo4|] (1 :: Int)+       :& field [ps|bar0|] "bar"+       :& field [ps|bar1|] "bar"+       :& field [ps|bar2|] "bar"+       :& field [ps|bar3|] "bar"+       :& field [ps|bar4|] "bar"+       :& field [ps|qux0|] True+       :& field [ps|qux1|] True+       :& field [ps|qux2|] True+       :& field [ps|qux3|] True+       :& field [ps|qux4|] True+       :& RNil++     getAllDict d = (         ( D.get [key|foo0|] d         , D.get [key|foo1|] d@@ -182,3 +244,6 @@             . DD.add [key|qux3|] True             . DD.add [key|qux4|] True             $ DD.empty++fget_qux0 :: ('("qux0",Bool) ∈ fields) => FieldRec fields -> Bool+fget_qux0 = fget [ps|qux0|]

@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++{-# LANGUAGE DataKinds, ScopedTypeVariables, ExplicitNamespaces, TypeOperators, FlexibleContexts, PolyKinds #-}++module ProxySymbolTH where -- TODO i'll move this out somewhere++import Data.Vinyl+-- import Data.Vinyl.Notation (type (∈))++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.Proxy+import GHC.TypeLits++--------------------------------------------------------------------------------++-- | get a value from its key in the record+fget+ :: forall s a fields proxy. ('(s,a) ∈ fields)+ => proxy s -> FieldRec fields -> a+fget _ record = getField $ rget (Proxy :: Proxy '(s,a)) record++fmodify+  :: forall s a fields proxy. ('(s,a) ∈ fields)+  => proxy s -> (a -> a) -> FieldRec fields -> FieldRec fields+fmodify _ function input = output+ where+ output = rput b input+ b = fieldMap function a+ a = rget (Proxy :: Proxy '(s,a)) input++-- | construct a key-value pair+field :: (KnownSymbol s) => proxy s -> a -> ElField '(s,a)+field _ a = Field a++--------------------------------------------------------------------------------++-- | splices a proxy for a type-level string+ps :: QuasiQuoter+ps = defaultQuasiQuoter{quoteExp}+ where+ quoteExp = proxySymbolQ++proxySymbolQ :: String -> ExpQ+proxySymbolQ = proxyExpQ . litT . strTyLit++proxyTypeQ :: TypeQ -> TypeQ+proxyTypeQ t = appT (conT proxy_tc) t++proxyExpQ :: TypeQ -> ExpQ+proxyExpQ t = sigE (conE proxy_d) (proxyTypeQ t)++-- makeSymbol :: String -> Type+-- makeSymbol = LitT . StrTyLit++proxy_tc :: Name+proxy_tc = ''Proxy++proxy_d :: Name+proxy_d = 'Proxy++defaultQuasiQuoter :: QuasiQuoter+defaultQuasiQuoter = QuasiQuoter{..}+ where++ quoteExp  :: String -> Q Exp+ quoteExp  = error $ message "expressions"++ quotePat  :: String -> Q Pat+ quotePat  = error $ message "patterns"++ quoteType :: String -> Q Type+ quoteType = error $ message "types"++ quoteDec  :: String -> Q [Dec]+ quoteDec  = error $ message "declarations"++ message x = "this QuasiQuoter doesn't support " ++ x

@@ -1,5 +1,5 @@ name:                hetero-dict-version:             0.1.0.1+version:             0.1.1.0 synopsis:            Fast heterogeneous data structures description:         Fast heterogeneous data structures license:             MIT@@ -10,7 +10,7 @@ copyright:           (c) 2014-2015 Hirotomo Moriwaki, 2016 Winterland category:            Data build-type:          Simple-extra-source-files:  ChangeLog.md, README.md+extra-source-files:  ChangeLog.md, README.md, bench/ProxySymbolTH.hs cabal-version:       >=1.10  library@@ -21,17 +21,20 @@     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+                        ,   aeson       >=0.7+                        ,   unordered-containers >=0.2.5+                        ,   text        >=1.1      ghc-options:         -Wall -O2     default-language:    Haskell2010  benchmark criterion-    build-depends:    base, deepseq, hvect, hetero-dict, criterion == 1.1.*+    build-depends:    base, deepseq, template-haskell, vinyl ==0.5.2, hvect, hetero-dict, criterion == 1.1.*     default-language: Haskell2010     hs-source-dirs:   bench     main-is:          Bench.hs     type:             exitcode-stdio-1.0+    ghc-options:      -O2  source-repository head     type:     git