From 5a996aceee6d0cead8d2f9d699e7d9c8c579a5bc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 19 May 2021 22:38:15 +0200 Subject: [PATCH] Implement improvements to ARec (#150, #153) * Move from Array to SmallArray# to avoid intermediate list during construction * Use class instead of recursive function in toARec for improved inlining --- Data/Vinyl/ARec/Internal.hs | 167 ++++++++++++++++++++----- Data/Vinyl/ARec/Internal/SmallArray.hs | 56 +++++++++ benchmarks/AccessorsBench.hs | 53 +++++--- benchmarks/Bench/ARec.hs | 39 ++++++ benchmarks/Bench/Rec.hs | 37 ++++++ benchmarks/Bench/SRec.hs | 34 +++++ tests/Aeson.hs | 2 +- tests/Spec.hs | 2 +- vinyl.cabal | 4 + 9 files changed, 346 insertions(+), 48 deletions(-) create mode 100644 Data/Vinyl/ARec/Internal/SmallArray.hs create mode 100644 benchmarks/Bench/ARec.hs create mode 100644 benchmarks/Bench/Rec.hs create mode 100644 benchmarks/Bench/SRec.hs diff --git a/Data/Vinyl/ARec/Internal.hs b/Data/Vinyl/ARec/Internal.hs index d42fda8..b30bff1 100644 --- a/Data/Vinyl/ARec/Internal.hs +++ b/Data/Vinyl/ARec/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -23,9 +24,26 @@ -- element to the head of a list, but element access is linear time; -- array access time is uniform, but extending the array is more -- slower. + +-- Tradeoffs: +-- +-- * No sharing of the spine (i.e. when you change elements in the front of the +-- record the tail can't be re-used) +-- * ARec requires (4 + n) words + size of the fields +-- * 1 for the ARec constructor +-- * 1 for the pointer to the SmallArray# +-- * The SmallArray# has 2 words as header (1 for GC, 1 for number of elements) +-- * 1 pointer per element to the actual data +-- * Rec requires (2n) words + size of Fields +-- * 1 word per (:&) constructor +-- * 1 word for the pointer to the element module Data.Vinyl.ARec.Internal ( ARec (..) , IndexableField + , arec + , ARecBuilder (..) + , arcons + , arnil , toARec , fromARec , aget @@ -39,28 +57,36 @@ module Data.Vinyl.ARec.Internal import Data.Vinyl.Core import Data.Vinyl.Lens (RecElem(..), RecSubset(..)) import Data.Vinyl.TypeLevel +import Data.Vinyl.ARec.Internal.SmallArray +import Control.Monad.ST -import qualified Data.Array as Array -import qualified Data.Array.Base as BArray -import GHC.Exts (Any) import Unsafe.Coerce #if __GLASGOW_HASKELL__ < 806 import Data.Constraint.Forall (Forall) #endif -import Data.Coerce (Coercible) -import Data.Type.Coercion (Coercion (..)) +import Data.Type.Coercion (Coercion (..)) +import GHC.Types -- | An array-backed extensible record with constant-time field -- access. -newtype ARec (f :: k -> *) (ts :: [k]) = ARec (Array.Array Int Any) +newtype ARec (f :: k -> *) (ts :: [k]) = ARec SmallArray type role ARec representational nominal +-- | Get the ith element from the ARec +unsafeIxARec + :: forall a k (f :: k -> *) (ts :: [k]). + ARec f ts + -> Int + -> a +unsafeIxARec (ARec ar) ix = indexSmallArray ar ix +{-# INLINE unsafeIxARec #-} + -- | Given that @xs@ and @ys@ have the same length, and mapping -- @f@ over @xs@ and @g@ over @ys@ produces lists whose elements -- are pairwise 'Coercible', @ARec f xs@ and @ARec g ys@ are -- 'Coercible'. arecRepsMatchCoercion :: AllRepsMatch f xs g ys => Coercion (ARec f xs) (ARec g ys) -arecRepsMatchCoercion = Coercion +arecRepsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ()) -- | Given that @forall x. Coercible (f x) (g x)@, produce a coercion from -- @ARec f xs@ to @ARec g xs@. While the constraint looks a lot like @@ -69,7 +95,7 @@ arecRepsMatchCoercion = Coercion #if __GLASGOW_HASKELL__ >= 806 arecConsMatchCoercion :: (forall (x :: k). Coercible (f x) (g x)) => Coercion (ARec f xs) (ARec g xs) -arecConsMatchCoercion = Coercion +arecConsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ()) #else arecConsMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs) @@ -78,6 +104,28 @@ arecConsMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). arecConsMatchCoercion = unsafeCoerce (Coercion :: Coercion (Rec f xs) (Rec f xs)) #endif +-- Using a class instead of a recursive function allows aRecValues to be +-- completely inlined +class ToARec (us :: [k]) where + aRecValues :: Rec f us -> ARecBuilder f us + +instance ToARec '[] where + aRecValues RNil = arnil + {-# INLINE aRecValues #-} + +instance ToARec us => ToARec (u ': us) where + aRecValues (x :& xs) = x `arcons` aRecValues xs + {-# INLINE aRecValues #-} + +-- | Convert a 'Rec' into an 'ARec' for constant-time field access. +toARec + :: forall f ts. + (NatToInt (RLength ts), ToARec ts) + => Rec f ts + -> ARec f ts +toARec rs = arec (aRecValues rs) +{-# INLINE toARec #-} + {- -- This is sensible, but the ergonomics are likely quite bad thanks to the -- interaction between Coercible resolution and resolution in the presence of @@ -89,14 +137,63 @@ arecConsMatchCoercible :: forall k f g rep (r :: TYPE rep). arecConsMatchCoercible f = f -} --- | Convert a 'Rec' into an 'ARec' for constant-time field access. -toARec :: forall f ts. (NatToInt (RLength ts)) => Rec f ts -> ARec f ts -toARec = go id - where go :: ([Any] -> [Any]) -> Rec f ts' -> ARec f ts - go acc RNil = ARec $! Array.listArray (0, n - 1) (acc []) - go acc (x :& xs) = go (acc . (unsafeCoerce x :)) xs - n = natToInt @(RLength ts) -{-# INLINE toARec #-} +-- | An efficient builder for ARec values +-- +-- Use the pseudo-constructors 'arcons' and 'arnil' to construct an +-- 'ARecBuilder' and then turn it into an 'ARec' with 'arec' +-- +-- Example: (requires -XOverloadedLabels and ) +-- +-- > user :: ARec ElField '[ "name" ::: String +-- > , "age" ::: Int +-- > , "active" ::: Bool] +-- > user = arec ( #name =: "Peter" +-- > `arcons` #age =: 4 +-- > `arcons` #active =: True +-- > `arcons` arnil +-- > ) +newtype ARecBuilder f us = + -- A function that writes values to the correct position in the underlying array + -- Takes the current index + ARecBuilder ( forall s. + Int -- Index to write to + -> SmallMutableArray s -- Arrray to write to + -> ST s () + ) + +infixr 1 `arcons` +-- | Pseudo-constructor for an ARecBuilder +-- +-- "Cons" a field to an ARec under construction +-- +-- See 'ARecBuilder' +arcons :: f u -> ARecBuilder f us -> ARecBuilder f (u ': us) +arcons !v (ARecBuilder fvs) = ARecBuilder $ \i mArr -> do + writeSmallArray mArr i v + fvs (i+1) mArr +{-# INLINE arcons #-} + +-- | Pseudo-constructor for 'ARecBuilder' +-- +-- Build an ARec without fields +-- +-- See 'ARecBuilder' +arnil :: ARecBuilder f '[] +arnil = ARecBuilder $ \_i _arr -> return () +{-# INLINE arnil #-} + +-- | Turn an ARecBuilder into an ARec +-- +-- See 'ARecBuilder' +arec + :: forall k (us :: [k] ) f + . (NatToInt (RLength us)) => + ARecBuilder f us + -> ARec f us +arec (ARecBuilder fillArray) = ARec $ + runST $ withNewSmallArray (natToInt @(RLength us)) + $ fillArray 0 +{-# INLINE arec #-} -- | Defines a constraint that lets us index into an 'ARec' in order -- to produce a 'Rec' using 'fromARec'. @@ -107,22 +204,22 @@ instance (NatToInt (RIndex t ts)) => IndexableField ts t where fromARec :: forall f ts. (RecApplicative ts, RPureConstrained (IndexableField ts) ts) => ARec f ts -> Rec f ts -fromARec (ARec arr) = rpureConstrained @(IndexableField ts) aux +fromARec ar = rpureConstrained @(IndexableField ts) aux where aux :: forall t. NatToInt (RIndex t ts) => f t - aux = unsafeCoerce (arr Array.! natToInt @(RIndex t ts)) + aux = unsafeIxARec ar (natToInt @(RIndex t ts)) {-# INLINE fromARec #-} -- | Get a field from an 'ARec'. aget :: forall t f ts. (NatToInt (RIndex t ts)) => ARec f ts -> f t -aget (ARec arr) = - unsafeCoerce (BArray.unsafeAt arr (natToInt @(RIndex t ts))) +aget ar = unsafeIxARec ar (natToInt @(RIndex t ts)) {-# INLINE aget #-} -- | Set a field in an 'ARec'. unsafeAput :: forall t t' f ts ts'. (NatToInt (RIndex t ts)) => f t' -> ARec f ts -> ARec f ts' -unsafeAput x (ARec arr) = ARec (arr Array.// [(i, unsafeCoerce x)]) - where i = natToInt @(RIndex t ts) +unsafeAput x (ARec arr) = ARec $ runST $ + withThawedSmallArray arr $ \mArr -> + writeSmallArray mArr (natToInt @(RIndex t ts)) x {-# INLINE unsafeAput #-} -- | Define a lens for a field of an 'ARec'. @@ -157,19 +254,31 @@ instance (RIndex t (s ': ts) ~ 'S i, NatToInt i, RecElem ARec t t' ts ts' i) arecGetSubset :: forall rs ss f. (IndexWitnesses (RImage rs ss), NatToInt (RLength rs)) => ARec f ss -> ARec f rs -arecGetSubset (ARec arr) = ARec (Array.listArray (0, n-1) $ - go (indexWitnesses @(RImage rs ss))) - where go :: [Int] -> [Any] - go = map (arr Array.!) - n = natToInt @(RLength rs) +arecGetSubset (ARec arr) = + ARec $ runST $ + withNewSmallArray (natToInt @(RLength rs)) $ \mArr -> + go mArr 0 (indexWitnesses @(RImage rs ss)) + where + go :: SmallMutableArray s -> Int -> [Int] -> ST s () + go _mArr _to [] = return () + go mArr to (from : froms) = do + writeSmallArray mArr to (indexSmallArray arr from :: Any) + go mArr (to + 1) froms {-# INLINE arecGetSubset #-} -- | Set a subset of a larger record's fields to all of the fields of -- a smaller record. arecSetSubset :: forall rs ss f. (IndexWitnesses (RImage rs ss)) => ARec f ss -> ARec f rs -> ARec f ss -arecSetSubset (ARec arrBig) (ARec arrSmall) = ARec (arrBig Array.// updates) - where updates = zip (indexWitnesses @(RImage rs ss)) (Array.elems arrSmall) +arecSetSubset (ARec arrBig) (ARec arrSmall) = ARec $ runST $ + withThawedSmallArray arrBig $ \mArr -> do + go mArr 0 (indexWitnesses @(RImage rs ss)) + where + go :: SmallMutableArray s -> Int -> [Int] -> ST s () + go _mArr _ [] = return () + go mArr from (to : tos) = do + writeSmallArray mArr to (indexSmallArray arrSmall from) + go mArr (from + 1) tos {-# INLINE arecSetSubset #-} instance (is ~ RImage rs ss, IndexWitnesses is, NatToInt (RLength rs)) diff --git a/Data/Vinyl/ARec/Internal/SmallArray.hs b/Data/Vinyl/ARec/Internal/SmallArray.hs new file mode 100644 index 0000000..00a81fc --- /dev/null +++ b/Data/Vinyl/ARec/Internal/SmallArray.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} + +-- | Helper functions for SmallArray# +-- +-- This module exposes _unsafe_ functions to work with SmallArrays. That means +-- that specifically neither index bounds nor element types are checked So this +-- functionality should only be used in a context that enforces them by some +-- other means, e.g. ARec's type index + +module Data.Vinyl.ARec.Internal.SmallArray where + +import GHC.Prim +import GHC.Types +import Unsafe.Coerce +import GHC.ST + +data SmallArray = SmallArray !(SmallArray# Any) +data SmallMutableArray s = SmallMutableArray !(SmallMutableArray# s Any) + +indexSmallArray :: SmallArray -> Int -> a +indexSmallArray (SmallArray arr) (I# ix) = + case indexSmallArray# arr ix of + (# v #) -> unsafeCoerce v +{-# INLINE indexSmallArray #-} + +withNewSmallArray :: Int -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray +withNewSmallArray (I# len#) f = + ST $ \s0 -> case newSmallArray# len# (error "withNewSmallArray exploded") s0 of + (# s1, mArr #) -> + case f (SmallMutableArray mArr) of + ST st -> case st s1 of + (# s2, () #) -> case unsafeFreezeSmallArray# mArr s2 of + (# s3, ar #) -> (# s3, SmallArray ar #) +{-# INLINE withNewSmallArray #-} + +writeSmallArray :: SmallMutableArray s -> Int -> a -> ST s () +writeSmallArray (SmallMutableArray mArr) (I# n#) x = ST $ \s -> + case writeSmallArray# mArr n# (unsafeCoerce x) s of + s' -> (# s', () #) +{-# INLINE writeSmallArray #-} + +withThawedSmallArray :: SmallArray + -> (SmallMutableArray s -> ST s ()) + -> ST s SmallArray +withThawedSmallArray (SmallArray arr) f = ST $ \s0 -> + let !(I# z#) = 0 + in case thawSmallArray# arr z# (sizeofSmallArray# arr) s0 of + (# s1, mArr #) -> + case f (SmallMutableArray mArr) of + ST st -> case st s1 of + (# s2, () #) -> case unsafeFreezeSmallArray# mArr s2 of + (# s3, ar #) -> (# s3, SmallArray ar #) +{-# INLINE withThawedSmallArray #-} diff --git a/benchmarks/AccessorsBench.hs b/benchmarks/AccessorsBench.hs index bde2e64..71b625b 100644 --- a/benchmarks/AccessorsBench.hs +++ b/benchmarks/AccessorsBench.hs @@ -8,21 +8,12 @@ import Criterion.Main import Data.Monoid (Endo(..)) import Data.Vinyl import Data.Vinyl.Syntax () -import Lens.Micro ((%~), (&)) -import System.Exit (exitFailure) - -type Fields = '[ '( "a0", Int ), '( "a1", Int ), '( "a2", Int ), '( "a3", Int ) - , '( "a4", Int ), '( "a5", Int ), '( "a6", Int ), '( "a7", Int ) - , '( "a8", Int ), '( "a9", Int ), '( "a10", Int ), '( "a11", Int ) - , '( "a12", Int ), '( "a13", Int ), '( "a14", Int ), '( "a15", Int ) - ] - -newF :: FieldRec Fields -newF = Field 0 :& Field 0 :& Field 0 :& Field 0 :& - Field 0 :& Field 0 :& Field 0 :& Field 0 :& - Field 0 :& Field 0 :& Field 0 :& Field 0 :& - Field 0 :& Field 0 :& Field 0 :& Field 99 :& - RNil +import Lens.Micro ((%~), (&)) +import System.Exit (exitFailure) + +import Bench.ARec +import Bench.SRec +import Bench.Rec data HaskRec = HaskRec { a0 :: Int, @@ -45,6 +36,10 @@ data HaskRec = HaskRec { haskRec :: HaskRec haskRec = HaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 +sumHaskRec r = + a0 r + a1 r + a2 r + a3 r + a4 r + a5 r + a6 r + a7 r + a8 r + a9 r + + a10 r + a11 r + a12 r + a13 r + a14 r + a15 r + data StrictHaskRec = StrictHaskRec { sa0 :: !Int, sa1 :: !Int, @@ -66,6 +61,10 @@ data StrictHaskRec = StrictHaskRec { shaskRec :: StrictHaskRec shaskRec = StrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 +sumSHaskRec r = + sa0 r + sa1 r + sa2 r + sa3 r + sa4 r + sa5 r + sa6 r + sa7 r + sa8 r + sa9 r + + sa10 r + sa11 r + sa12 r + sa13 r + sa14 r + sa15 r + data UStrictHaskRec = UStrictHaskRec { usa0 :: {-# UNPACK #-} !Int, usa1 :: {-# UNPACK #-} !Int, @@ -87,6 +86,10 @@ data UStrictHaskRec = UStrictHaskRec { ushaskRec :: UStrictHaskRec ushaskRec = UStrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 +sumUSHaskRec r = + usa0 r + usa1 r + usa2 r + usa3 r + usa4 r + usa5 r + usa6 r + usa7 r + usa8 r + + usa9 r + usa10 r + usa11 r + usa12 r + usa13 r + usa14 r + usa15 r + type SubFields = '[ '("a0", Int), '("a8", Int), '("a15", Int)] -- updateSRec :: forall record. RecordSubset record ElField SubFields Fields @@ -115,7 +118,8 @@ updateHaskRec r = r { a0 = suba0 s, a8 = suba8 s, a15 = suba15 s } main :: IO () main = - do let arec = toARec newF + do let newF = mkRec 0 + arec = toARec newF srec = toSRec newF unless (rvalf #a15 arec == rvalf #a15 newF) (do putStrLn "AFieldRec accessor disagrees with rvalf" @@ -142,7 +146,22 @@ main = , bench "ARec" $ nf (rvalf #a15 . updateARec) arec , bench "SRec" $ nf (rvalf #a15 . updateSRec) srec ] - , bgroup "FieldRec" + , + bgroup "creating" + [ bench "vinyl record" $ whnf mkRec 0 + , bench "toSRec" $ whnf mkToSRec 0 + , bench "New style ARec with toARec " $ whnf mkToARec 0 + , bench "New style ARec with arec " $ whnf mkARec 0 + ] + ,bgroup "sums" + [ bench "haskell record" $ nf sumHaskRec haskRec + , bench "strict haskell record" $ whnf sumSHaskRec shaskRec + , bench "unboxed strict haskell record" $ whnf sumUSHaskRec ushaskRec + , bench "vinyl SRec" $ nf sumSRec srec + , bench "vinyl Rec" $ nf sumRec newF + , bench "vinyl ARec" $ nf sumARec arec + ] + , bgroup "FieldRec" [ bench "a0" $ nf (rvalf #a0) newF , bench "a4" $ nf (rvalf #a4) newF , bench "a8" $ nf (rvalf #a8) newF diff --git a/benchmarks/Bench/ARec.hs b/benchmarks/Bench/ARec.hs new file mode 100644 index 0000000..bf493f9 --- /dev/null +++ b/benchmarks/Bench/ARec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} + +module Bench.ARec where + +import Data.Vinyl +import Data.Vinyl.ARec.Internal +import Data.Vinyl.Syntax () + +import Bench.Rec + +mkARec :: Int -> ARec ElField Fields +mkARec i= arec (Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons` + Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons` + Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons` + Field i `arcons` Field i `arcons` Field i `arcons` Field 99 `arcons` + arnil) + + +mkToARec :: Int -> ARec ElField Fields +mkToARec i= toARec (Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field 99 :& + RNil) + +sumARec :: ARec ElField Fields -> Int +sumARec str = + get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str + + get #a5 str + get #a6 str + get #a7 str + get #a8 str + + get #a9 str + get #a10 str + get #a11 str + get #a12 str + + get #a13 str + get #a14 str + get #a15 str + where + get label r = rvalf label r + {-# INLINE get #-} diff --git a/benchmarks/Bench/Rec.hs b/benchmarks/Bench/Rec.hs new file mode 100644 index 0000000..3856b5a --- /dev/null +++ b/benchmarks/Bench/Rec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} + +module Bench.Rec where + +import Data.Vinyl +import Data.Vinyl.Syntax () + + +type Fields = '[ '( "a0", Int ), '( "a1", Int ), '( "a2", Int ), '( "a3", Int ) + , '( "a4", Int ), '( "a5", Int ), '( "a6", Int ), '( "a7", Int ) + , '( "a8", Int ), '( "a9", Int ), '( "a10", Int ), '( "a11", Int ) + , '( "a12", Int ), '( "a13", Int ), '( "a14", Int ), '( "a15", Int ) + ] + +mkRec :: Int -> Rec ElField Fields +mkRec i= Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field 99 :& + RNil + +sumRec :: Rec ElField Fields -> Int +sumRec str = + get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str + + get #a5 str + get #a6 str + get #a7 str + get #a8 str + + get #a9 str + get #a10 str + get #a11 str + get #a12 str + + get #a13 str + get #a14 str + get #a15 str + where + get (_label :: Label s) r = + let (Field v) = rget @'(s, _) r + in v + {-# INLINE get #-} diff --git a/benchmarks/Bench/SRec.hs b/benchmarks/Bench/SRec.hs new file mode 100644 index 0000000..7cd8c57 --- /dev/null +++ b/benchmarks/Bench/SRec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} + +module Bench.SRec where + +import Data.Vinyl.SRec +import Data.Vinyl + +import Bench.Rec (Fields) + + +mkToSRec :: Int -> SRec ElField Fields +mkToSRec i= toSRec (Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field 99 :& + RNil) + + +sumSRec :: SRec ElField Fields -> Int +sumSRec str = + get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str + + get #a5 str + get #a6 str + get #a7 str + get #a8 str + + get #a9 str + get #a10 str + get #a11 str + get #a12 str + + get #a13 str + get #a14 str + get #a15 str + where + get (label :: Label s) r = + case rget @'(s, Int) r of + Field v -> v + {-# INLINE get #-} diff --git a/tests/Aeson.hs b/tests/Aeson.hs index aae8fbf..b3a946f 100644 --- a/tests/Aeson.hs +++ b/tests/Aeson.hs @@ -62,7 +62,7 @@ instance ToJSON a => ToJSON (Identity a) where -- | A named field serializes to a JSON object with a single named -- field. -instance ToJSON a => ToJSON (ElField '(s,a)) where +instance (KnownSymbol s, ToJSON a) => ToJSON (ElField '(s,a)) where toJSON x = object [(T.pack (getLabel x), toJSON (getField x))] -- | A @((Text,) :. f) a@ value maps to a JSON field whose name is the diff --git a/tests/Spec.hs b/tests/Spec.hs index 0d3c61a..aa9666e 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -37,7 +37,7 @@ main = hspec $ do describe "Fields may be accessed by overloaded labels" $ do it "Can get field X" $ rvalf #x d3 `shouldBe` 5 it "Can get field Y" $ rvalf #y d3 `shouldBe` "Hi" - describe "ARec provides field accessors" $ do + describe "ARec" $ do it "Can get field Y" $ rvalf #y (toARec d3) `shouldBe` "Hi" it "Can set field X" $ rvalf #x (rputf #x 7 (toARec d3)) `shouldBe` 7 describe "Converting between Rec and ARec" $ do diff --git a/vinyl.cabal b/vinyl.cabal index 0abe9a7..3de7320 100644 --- a/vinyl.cabal +++ b/vinyl.cabal @@ -24,6 +24,7 @@ library exposed-modules: Data.Vinyl , Data.Vinyl.ARec , Data.Vinyl.ARec.Internal + , Data.Vinyl.ARec.Internal.SmallArray , Data.Vinyl.Class.Method , Data.Vinyl.Core , Data.Vinyl.CoRec @@ -78,6 +79,9 @@ benchmark accessors hs-source-dirs: benchmarks main-is: AccessorsBench.hs build-depends: base, criterion, tagged, vinyl, microlens + other-modules: Bench.ARec + other-modules: Bench.SRec + Bench.Rec ghc-options: -O2 default-language: Haskell2010