vinyl 0.13.3 → 0.14.3
raw patch · 19 files changed
Files
- CHANGELOG.md +15/−0
- Data/Vinyl/ARec.hs +1/−0
- Data/Vinyl/ARec/Internal.hs +139/−29
- Data/Vinyl/ARec/Internal/SmallArray.hs +56/−0
- Data/Vinyl/Class/Method.hs +1/−1
- Data/Vinyl/Curry.hs +3/−3
- Data/Vinyl/Derived.hs +1/−1
- Data/Vinyl/FromTuple.hs +5/−4
- Data/Vinyl/Functor.hs +5/−2
- Data/Vinyl/Syntax.hs +1/−1
- Data/Vinyl/TypeLevel.hs +1/−1
- benchmarks/AccessorsBench.hs +35/−16
- benchmarks/Bench/ARec.hs +39/−0
- benchmarks/Bench/Rec.hs +37/−0
- benchmarks/Bench/SRec.hs +34/−0
- tests/Aeson.hs +56/−12
- tests/Spec.hs +4/−0
- tests/Test/ARec.hs +101/−0
- vinyl.cabal +9/−3
CHANGELOG.md view
@@ -1,3 +1,18 @@+# 0.14.3+- Compatibility with `lens-aeson` > 1.2++# 0.14.2+- Export the `ToARec` class++# 0.14.1+- Compatibility with `aeson` > 2.0++# 0.14.0+- `ARec` efficiency improvements (@Philonous)+- Make `ElField` a newtype (@Philonous)++The `ElField` change brings more opportunities for the optimizer, but can result in longer compile times.+ # 0.13.3 - Fixed CHANGELOG entry for 0.13.2: it referred to version 0.14.0 - Relax bounds on `hspec`
Data/Vinyl/ARec.hs view
@@ -8,6 +8,7 @@ module Data.Vinyl.ARec ( ARec -- Exported abstractly , IndexableField+ , ToARec , toARec , fromARec , aget
Data/Vinyl/ARec/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}@@ -23,9 +24,27 @@ -- 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 (..)+ , ToARec , IndexableField+ , arec+ , ARecBuilder (..)+ , arcons+ , arnil , toARec , fromARec , aget@@ -39,28 +58,36 @@ 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 +96,7 @@ #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 +105,28 @@ 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,15 +138,64 @@ 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'. class (NatToInt (RIndex t ts)) => IndexableField ts t where@@ -107,22 +205,22 @@ 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 +255,31 @@ 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))
+ Data/Vinyl/ARec/Internal/SmallArray.hs view
@@ -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 #-}
Data/Vinyl/Class/Method.hs view
@@ -142,7 +142,7 @@ -- | The interpretation function of the 'FieldTyper' symbols. type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where ApplyFieldTyper 'FieldId a = a- ApplyFieldTyper 'FieldSnd '(s, b) = b+ ApplyFieldTyper 'FieldSnd a = Snd a -- | A mapping of record contexts into the 'FieldTyper' function -- space. We explicitly match on 'ElField' to pick out the payload
Data/Vinyl/Curry.hs view
@@ -11,7 +11,7 @@ -} module Data.Vinyl.Curry where-+import Data.Kind (Type) import Data.Vinyl import Data.Vinyl.Functor import Data.Vinyl.XRec@@ -170,7 +170,7 @@ CurriedF Maybe '[Int, Bool, String] Int :: * = Maybe Int -> Maybe Bool -> Maybe [Char] -> Int -}-type family CurriedF (f :: u -> *) (ts :: [u]) a where+type family CurriedF (f :: u -> Type) (ts :: [u]) a where CurriedF f '[] a = a CurriedF f (t ': ts) a = f t -> CurriedF f ts a @@ -183,6 +183,6 @@ CurriedX (Maybe :. Identity) '[Int, Bool, String] Int :: * = Maybe Int -> Maybe Bool -> Maybe [Char] -> Int -}-type family CurriedX (f :: u -> *) (ts :: [u]) a where+type family CurriedX (f :: u -> Type) (ts :: [u]) a where CurriedX f '[] a = a CurriedX f (t ': ts) a = HKD f t -> CurriedX f ts a
Data/Vinyl/Derived.hs view
@@ -46,7 +46,7 @@ getField (Field x) = x -- | Get the label name of an 'ElField'.-getLabel :: forall s t. ElField '(s,t) -> String+getLabel :: forall s t. KnownSymbol s => ElField '(s,t) -> String getLabel (Field _) = symbolVal (Proxy::Proxy s) -- | 'ElField' is isomorphic to a functor something like @Compose
Data/Vinyl/FromTuple.hs view
@@ -14,6 +14,7 @@ -- example record construction using 'ElField' for named fields: -- @fieldRec (#x =: True, #y =: 'b') :: FieldRec '[ '("x", Bool), '("y", Char) ]@ module Data.Vinyl.FromTuple where+import Data.Kind (Type) import Data.Monoid (First(..)) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup (Semigroup(..))@@ -29,7 +30,7 @@ -- type constructor to a tuple of the common type constructor and a -- list of the types to which it is applied in the original -- tuple. E.g. @TupleToRecArgs f (f a, f b) ~ (f, [a,b])@.-type family TupleToRecArgs f t = (r :: (u -> *, [u])) | r -> t where+type family TupleToRecArgs f t = (r :: (u -> Type, [u])) | r -> t where TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g, f h) = '(f, [a,b,c,d,e,z,g,h]) TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g) = '(f, [a,b,c,d,e,z,g])@@ -42,12 +43,12 @@ -- | Apply the 'Rec' type constructor to a type-level tuple of its -- arguments.-type family UncurriedRec (t :: (u -> *, [u])) = r | r -> t where+type family UncurriedRec (t :: (u -> Type, [u])) = r | r -> t where UncurriedRec '(f, ts) = Rec f ts -- | Apply the 'XRec' type constructor to a type-level tuple of its -- arguments.-type family UncurriedXRec (t :: (u -> *, [u])) = r | r -> t where+type family UncurriedXRec (t :: (u -> Type, [u])) = r | r -> t where UncurriedXRec '(f, ts) = XRec f ts -- | Convert between an 'XRec' and an isomorphic tuple.@@ -90,7 +91,7 @@ (a, b, c, d, e, z, g, h) xrecX (a, b, c, d, e, z, g, h) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil -type family ListToHKDTuple (f :: u -> *) (ts :: [u]) :: * where+type family ListToHKDTuple (f :: u -> Type) (ts :: [u]) :: Type where ListToHKDTuple f '[] = HKD f () ListToHKDTuple f '[a,b] = (HKD f a, HKD f b) ListToHKDTuple f '[a,b,c] = (HKD f a, HKD f b, HKD f c)
Data/Vinyl/Functor.hs view
@@ -42,6 +42,7 @@ import GHC.Generics import GHC.TypeLits import GHC.Types (Type)+import Data.Vinyl.TypeLevel (Snd) {- $introduction This module provides functors and functor compositions@@ -107,8 +108,10 @@ -- | A value with a phantom 'Symbol' label. It is not a -- Haskell 'Functor', but it is used in many of the same places a -- 'Functor' is used in vinyl.-data ElField (field :: (Symbol, Type)) where- Field :: KnownSymbol s => !t -> ElField '(s,t)+--+-- Morally: newtype ElField (s, t) = Field t+-- But GHC doesn't allow that+newtype ElField (t :: (Symbol, Type)) = Field (Snd t) deriving instance Eq t => Eq (ElField '(s,t)) deriving instance Ord t => Ord (ElField '(s,t))
Data/Vinyl/Syntax.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleInstances, InstanceSigs,+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
Data/Vinyl/TypeLevel.hs view
@@ -73,7 +73,7 @@ RImage '[] ss = '[] RImage (r ': rs) ss = RIndex r ss ': RImage rs ss --- | Remove the first occurence of a type from a type-level list.+-- | Remove the first occurrence of a type from a type-level list. type family RDelete r rs where RDelete r (r ': rs) = rs RDelete r (s ': rs) = s ': RDelete r rs
benchmarks/AccessorsBench.hs view
@@ -8,21 +8,12 @@ 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 )- ]+import Lens.Micro ((%~), (&))+import System.Exit (exitFailure) -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 Bench.ARec+import Bench.SRec+import Bench.Rec data HaskRec = HaskRec { a0 :: Int,@@ -45,6 +36,10 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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
+ benchmarks/Bench/ARec.hs view
@@ -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 #-}
+ benchmarks/Bench/Rec.hs view
@@ -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 #-}
+ benchmarks/Bench/SRec.hs view
@@ -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 #-}
tests/Aeson.hs view
@@ -48,11 +48,42 @@ import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..)) import Data.Aeson import Data.Aeson.Encoding.Internal (wrapObject, pair)+#if MIN_VERSION_aeson(2,0,0)+import Control.Lens (_1, (%~))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#endif import Data.Aeson.Lens (_Object) import GHC.Generics (Generic, Rep) import GHC.TypeLits (KnownSymbol) import Test.Hspec +-- * Compatibility with aeson < 2+#if MIN_VERSION_aeson(2,0,0)+type KeyMap = KeyMap.KeyMap Value++keyFromString :: String -> Key+keyFromString = Key.fromString++keyFromText :: Text -> Key+keyFromText = Key.fromText++keyMapToList :: KeyMap -> [(Key,Value)]+keyMapToList = KeyMap.toList+#else+type Key = Text+type KeyMap = H.HashMap Text Value++keyFromString :: String -> Key+keyFromString = T.pack++keyFromText :: Text -> Key+keyFromText = id++keyMapToList :: KeyMap -> [(Key,Value)]+keyMapToList = H.toList+#endif+ -- * Implementing 'ToJSON' for 'Rec' -- | An 'Identity' functor is not reflected in a value's JSON@@ -62,23 +93,23 @@ -- | A named field serializes to a JSON object with a single named -- field.-instance ToJSON a => ToJSON (ElField '(s,a)) where- toJSON x = object [(T.pack (getLabel x), toJSON (getField x))]+instance (KnownSymbol s, ToJSON a) => ToJSON (ElField '(s,a)) where+ toJSON x = object [(keyFromString (getLabel x), toJSON (getField x))] -- | A @((Text,) :. f) a@ value maps to a JSON field whose name is the -- 'Text' value, and whose value has type @f a@. instance ToJSON (f a) => ToJSON ((((,) Text) :. f) a) where- toJSON (Compose (name, x)) = object [(name, toJSON x)]+ toJSON (Compose (name, x)) = object [(keyFromText name, toJSON x)] -- | Replace each field of a record with the result of serializing it -- to a JSON 'Value', and then extracting that 'Value''s single named -- field. If the serialization is not in the form of an object with a -- single field, the conversion fails with a 'Nothing'. fieldsToJSON :: (RecMapMethod1 ToJSON f rs)- => Rec f rs -> Rec (Maybe :. Const (Text,Value)) rs+ => Rec f rs -> Rec (Maybe :. Const (Key,Value)) rs fieldsToJSON = rmapMethod1 @ToJSON (Compose . aux) where aux x = case toJSON x of- Object (H.toList -> [field]) -> Just (Const field)+ Object (keyMapToList -> [field]) -> Just (Const field) _ -> Nothing -- | Convert a homogeneous record to a list factored through an outer@@ -176,19 +207,21 @@ -- loses precision in the type. class ToJSONField a where encodeJSONField :: a -> Series- toJSONField :: a -> (Text,Value)+ toJSONField :: a -> (Key,Value) -- | An @ElField '(s,a)@ value maps to a JSON field with name @s@ and -- value @a@. instance (ToJSON a, KnownSymbol s) => ToJSONField (ElField '(s,a)) where- encodeJSONField x = pair (T.pack (getLabel x)) (toEncoding (getField x))- toJSONField x = (T.pack (getLabel x), toJSON (getField x))+ encodeJSONField x = pair (keyFromString (getLabel x))+ (toEncoding (getField x))+ toJSONField x = (keyFromString (getLabel x), toJSON (getField x)) -- | A @((Text,) :. f) a@ value maps to a JSON field whose name is the -- 'Text' value, and whose value has type @f a@. instance ToJSON (f a) => ToJSONField (((,) Text :. f) a) where- encodeJSONField (Compose (name,val)) = pair name (toEncoding val)- toJSONField (Compose (name,val)) = (name, toJSON val)+ encodeJSONField (Compose (name,val)) =+ pair (keyFromText name) (toEncoding val)+ toJSONField (Compose (name,val)) = (keyFromText name, toJSON val) encodeRec :: (RFoldMap rs, RecMapMethod1 ToJSONField f rs) => Rec f rs -> Encoding@@ -207,7 +240,7 @@ -- | If a 'Value' is a nested 'Array' of 'Object's, extract the -- collection of key-value pairs from the entire recursive structure.-allAesonFields :: Value -> Maybe (H.HashMap Text Value)+allAesonFields :: Value -> Maybe Object allAesonFields (Array arr) = case V.toList arr of [] -> Just mempty@@ -224,8 +257,19 @@ -- | A lens implementation of something a bit looser than -- 'unnestFields'.-allFields :: Value -> H.HashMap Text Value+allFields :: Value -> Object+#if MIN_VERSION_aeson(2,0,0)+allFields = KeyMap.fromList+#if MIN_VERSION_lens_aeson(1,2,0)+ . keyMapToList+#else+ . map (_1 %~ Key.fromText)+ . H.toList+#endif+ . view (deep _Object)+#else allFields = view (deep _Object)+#endif -- | The generic 'ToJSON' instance is not quite right since we use the -- record's interpretation type constructor to define serialization,
tests/Spec.hs view
@@ -11,6 +11,8 @@ import qualified CoRecSpec as C import qualified XRecSpec as X +import qualified Test.ARec as ARec+ -- d1 :: FieldRec '[ '("X",String), '("Y", String) ] -- d1 = Field @"X" "5" :& Field @"Y" "Hi" :& RNil @@ -71,3 +73,5 @@ (#x .~ 2.1) d3 `shouldBe` fieldRec (#x =: 2.1, #y =: "Hi") it "Can change a field's type" $ (d3 & #y %~ length) `shouldBe` fieldRec (#x =: 5, #y =: 2)++ ARec.spec
+ tests/Test/ARec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs,+ NoMonomorphismRestriction, OverloadedLabels,+ ScopedTypeVariables, TypeApplications, TypeOperators #-}+{-# OPTIONS_GHC -Wall -Wno-type-defaults #-}++module Test.ARec where++import Data.Vinyl.ARec+import Data.Vinyl+import Test.Hspec++import Data.Vinyl.Syntax ()++type FullARec = ARec ElField '[ "f0" ::: Int , "f1" ::: Bool , "f2" ::: String+ , "f3" ::: Double, "f4" ::: Integer+ , "f2" ::: Int -- intentionally duplicate field name+ ]++type SubARecPre = ARec ElField '[ "f0" ::: Int , "f1" ::: Bool , "f2" ::: String ]++type SubARecDupes = ARec ElField '[ "f2" ::: String, "f2" ::: String+ , "f2" ::: Int, "f2" ::: String+ ]+++fullARec :: FullARec+fullARec = toARec ( #f0 =: 1 :& #f1 =: False :& #f2 =: "field2"+ :& #f3 =: 3.1415 :& #f4 =: 4444+ :& #f2 =: 666+ :& RNil+ )++-- For arecGetSubset -----------------------------------------------------------++subARecPre :: SubARecPre+subARecPre = toARec ( #f0 =: 1 :& #f1 =: False :& #f2 =: "field2" :& RNil)++subARecDupes :: SubARecDupes+subARecDupes = toARec ( #f2 =: "field2" :& #f2 =: "field2"+ :& #f2 =: 666 :& #f2 =: "field2"+ :& RNil+ )++arecWithDupes :: ARec ElField '[ "f" ::: Int, "f" ::: Int]+arecWithDupes = toARec (#f =: 1 :& #f =: 2 :& RNil)++-- For arecSetSubset -----------------------------------------------------------++subARecPreSet :: SubARecPre+subARecPreSet = toARec ( #f0 =: 11 :& #f1 =: True :& #f2 =: "field2-updated" :& RNil)++fullARecUpdated :: FullARec+fullARecUpdated = toARec ( #f0 =: 11 :& #f1 =: True :& #f2 =: "field2-updated"+ :& #f3 =: 3.1415 :& #f4 =: 4444+ :& #f2 =: 666+ :& RNil+ )++updateARecWithDupes :: ARec ElField '[ '("f0", Int), '("f0", Int), '("f0", Int)]+updateARecWithDupes = toARec (#f0 =: 3 :& #f0 =: 66 :& #f0 =: 1 :&RNil)++subARecDupesUpdated :: SubARecDupes+subARecDupesUpdated = toARec ( #f2 =: "updated" :& #f2 =: "field2"+ :& #f2 =: 666 :& #f2 =: "field2"+ :& RNil+ )++++spec :: SpecWith ()+spec = describe "ARec" $ do+ describe "arecGetSubset" $ do+ it "retrieves a prefix ARec" $+ -- The part to be retrieved is type-directed+ arecGetSubset fullARec `shouldBe` subARecPre+ it "retrieves the full ARec" $ do+ -- Should catch off-by-one errors that lead to overflow+ arecGetSubset fullARec `shouldBe` fullARec+ it "handles an empty subARec correctly" $+ arecGetSubset fullARec `shouldBe` toARec RNil+ it "handles duplicate field names correctly in the sub arec" $+ arecGetSubset fullARec `shouldBe` subARecDupes+ it "handles duplicate field names correctly in the source arec" $+ -- When both the name and the type of the field match we retrieve from the+ -- first field+ arecGetSubset arecWithDupes `shouldBe` toARec (#f =: (1 :: Int) :& RNil)+ describe "arecSetSubset" $ do+ it "sets a subset of fields" $ do+ arecSetSubset fullARec subARecPreSet `shouldBe` fullARecUpdated+ it "handles updates to every field" $ do+ -- Should catch off-by-one errors that lead to overflow+ arecSetSubset fullARec fullARec `shouldBe` fullARec+ it "handles an empty subset" $ do+ arecSetSubset fullARec (toARec RNil) `shouldBe` fullARec+ it "handles duplicates in the updating ARec" $ do+ -- The behaviour here should be that the _last_ updating field prevails+ arecSetSubset fullARec updateARecWithDupes `shouldBe` fullARec+ it "handles updatees with duplicate fields" $ do+ -- Here, only the _first_ field should be updated+ arecSetSubset subARecDupes (toARec (#f2 =: "updated" :& RNil))+ `shouldBe` subARecDupesUpdated
vinyl.cabal view
@@ -1,5 +1,5 @@ name: vinyl-version: 0.13.3+version: 0.14.3 synopsis: Extensible Records -- description: license: MIT@@ -12,7 +12,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md-tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1+tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1, GHC == 9.2.1 description: Extensible records for Haskell with lenses. @@ -24,6 +24,7 @@ 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 @@ hs-source-dirs: benchmarks main-is: AccessorsBench.hs build-depends: base, criterion, tagged, vinyl, microlens+ other-modules: Bench.ARec+ Bench.SRec+ Bench.Rec ghc-options: -O2 default-language: Haskell2010 @@ -113,7 +117,9 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs- other-modules: CoRecSpec XRecSpec+ other-modules: CoRecSpec+ XRecSpec+ Test.ARec build-depends: base , vinyl , microlens