vinyl 0.7.0 → 0.8.1
raw patch · 13 files changed
+446/−51 lines, 13 filesdep +arraydep +microlensdep +taggeddep ~base
Dependencies added: array, microlens, tagged
Dependency ranges changed: base
Files
- CHANGELOG.md +8/−0
- Data/Vinyl.hs +2/−1
- Data/Vinyl/ARec.hs +116/−0
- Data/Vinyl/Core.hs +10/−5
- Data/Vinyl/Derived.hs +130/−4
- Data/Vinyl/Lens.hs +34/−27
- Data/Vinyl/Tutorial/Overview.hs +1/−1
- Data/Vinyl/TypeLevel.hs +38/−0
- benchmarks/AccessorsBench.hs +46/−0
- benchmarks/StorableBench.hs +22/−3
- tests/Intro.lhs +1/−1
- tests/Spec.hs +22/−4
- vinyl.cabal +16/−5
CHANGELOG.md view
@@ -1,3 +1,11 @@+# 0.8.0++- Overhaul of `FieldRec`: records with named fields. We now take advantage of the `-XOverloadedLabels` extension to support referring to record fields by names such a `#myField`.++- A new `ARec` type for constant-time field access. You can convert a classic, HList-like `Rec` into an `ARec` with `toARec`, or back the other way with `fromARec`. An `ARec` uses an `Array` to store record fields, so the usual trade-offs between lists and arrays apply: lists are cheap to construct by adding an element to the head, but slow to access; it is expensive to modify the shape of an array, but element lookup is constant-time.++**Compatibility Break**: The operator `=:` for constructing a record with a single field has changed. That operation is now known as `=:=`, while `=:` is now used to construct an `ElField`. It was decided that single-field record construction was not a common use-case, so the shorter name could be used for the more common operation. Apologies for making the upgrade a bit bumpy.+ # 0.7.0 - Simplified `match` - Added `Data.Vinyl.Curry`
Data/Vinyl.hs view
@@ -1,10 +1,11 @@ module Data.Vinyl ( module Data.Vinyl.Core+ , module Data.Vinyl.ARec , module Data.Vinyl.Derived , module Data.Vinyl.Lens ) where import Data.Vinyl.Core+import Data.Vinyl.ARec (ARec, toARec, fromARec) import Data.Vinyl.Derived import Data.Vinyl.Lens-
+ Data/Vinyl/ARec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Constant-time field accessors for extensible records. The+-- trade-off is the usual lists vs arrays one: it is fast to add an+-- 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.+module Data.Vinyl.ARec where+import Data.Vinyl.Core+import Data.Vinyl.Lens (RecElem(..), RecSubset(..))+import Data.Vinyl.TypeLevel++import qualified Data.Array as Array+import qualified Data.Array.Base as BArray+import Data.Proxy+import GHC.Exts (Any)+import Unsafe.Coerce++-- | An array-backed extensible record with constant-time field+-- access.+newtype ARec (f :: k -> *) (ts :: [k]) = ARec (Array.Array Int Any)++-- | 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 #-}++-- | 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+instance (NatToInt (RIndex t ts)) => IndexableField ts t where++-- | Convert an 'ARec' into a 'Rec'.+fromARec :: forall f ts.+ (RecApplicative ts, AllConstrained (IndexableField ts) ts)+ => ARec f ts -> Rec f ts+fromARec (ARec arr) = rpureConstrained (Proxy :: Proxy (IndexableField ts)) aux+ where aux :: forall t. NatToInt (RIndex t ts) => f t+ aux = unsafeCoerce (arr Array.! 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)))+{-# INLINE aget #-}++-- | Set a field in an 'ARec'.+aput :: forall t f ts. (NatToInt (RIndex t ts))+ => f t -> ARec f ts -> ARec f ts+aput x (ARec arr) = ARec (arr Array.// [(i, unsafeCoerce x)])+ where i = natToInt @(RIndex t ts)+{-# INLINE aput #-}++-- | Define a lens for a field of an 'ARec'.+alens :: (Functor g, NatToInt (RIndex t ts))+ => (f t -> g (f t)) -> ARec f ts -> g (ARec f ts)+alens f ar = fmap (flip aput ar) (f (aget ar))+{-# INLINE alens #-}++instance (i ~ RIndex t ts, NatToInt (RIndex t ts)) => RecElem ARec t ts i where+ rlens _ = alens+ rget _ = aget+ rput = aput++-- | Get a subset of a record's fields.+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)+{-# 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)+{-# INLINE arecSetSubset #-}++instance (is ~ RImage rs ss, IndexWitnesses is, NatToInt (RLength rs))+ => RecSubset ARec rs ss is where+ rsubset f big = fmap (arecSetSubset big) (f (arecGetSubset big))+ {-# INLINE rsubset #-}++instance (AllConstrained (IndexableField rs) rs,+ RecApplicative rs,+ Show (Rec f rs)) => Show (ARec f rs) where+ show = show . fromARec++instance (AllConstrained (IndexableField rs) rs,+ RecApplicative rs,+ Eq (Rec f rs)) => Eq (ARec f rs) where+ x == y = fromARec x == fromARec y++instance (AllConstrained (IndexableField rs) rs,+ RecApplicative rs,+ Ord (Rec f rs)) => Ord (ARec f rs) where+ compare x y = compare (fromARec x) (fromARec y)
Data/Vinyl/Core.hs view
@@ -15,7 +15,8 @@ module Data.Vinyl.Core where -import Data.Monoid+import Data.Monoid (Monoid)+import Data.Semigroup import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..)) import Data.Vinyl.Functor@@ -199,11 +200,11 @@ -- | Build a record whose elements are derived solely from a -- constraint satisfied by each.-rpureConstrained :: forall c (f :: * -> *) proxy ts.+rpureConstrained :: forall c (f :: u -> *) proxy ts. (AllConstrained c ts, RecApplicative ts) => proxy c -> (forall a. c a => f a) -> Rec f ts-rpureConstrained _ f = go (rpure Nothing)- where go :: AllConstrained c ts' => Rec Maybe ts' -> Rec f ts'+rpureConstrained _ f = go (rpure Proxy)+ where go :: AllConstrained c ts' => Rec Proxy ts' -> Rec f ts' go RNil = RNil go (_ :& xs) = f :& go xs @@ -226,13 +227,17 @@ . rmap (\(Compose (Dict x)) -> Const $ show x) $ reifyConstraint (Proxy :: Proxy Show) xs +instance Semigroup (Rec f '[]) where+instance (Monoid (f r), Monoid (Rec f rs))+ => Semigroup (Rec f (r ': rs)) where+ instance Monoid (Rec f '[]) where mempty = RNil RNil `mappend` RNil = RNil instance (Monoid (f r), Monoid (Rec f rs)) => Monoid (Rec f (r ': rs)) where mempty = mempty :& mempty- (x :& xs) `mappend` (y :& ys) = (x <> y) :& (xs <> ys)+ (x :& xs) `mappend` (y :& ys) = (mappend x y) :& (mappend xs ys) instance Eq (Rec f '[]) where _ == _ = True
Data/Vinyl/Derived.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -5,33 +7,60 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+-- | Commonly used 'Rec' instantiations. module Data.Vinyl.Derived where import Data.Proxy+import Data.Vinyl.ARec import Data.Vinyl.Core import Data.Vinyl.Functor+import Data.Vinyl.Lens+import Data.Vinyl.TypeLevel (Fst, Snd, AllConstrained, RIndex) import Foreign.Ptr (castPtr) import Foreign.Storable+import GHC.OverloadedLabels import GHC.TypeLits +-- | Alias for Field spec+type a ::: b = '(a, b)+ data ElField (field :: (Symbol, *)) where Field :: KnownSymbol s => !t -> ElField '(s,t) +-- | A record of named fields. type FieldRec = Rec ElField++-- | An 'ARec' of named fields to provide constant-time field access.+type AFieldRec ts = ARec ElField ts++-- | Heterogeneous list whose elements are evaluated during list+-- construction. type HList = Rec Identity++-- | Heterogeneous list whose elements are left as-is during list+-- construction (cf. 'HList'). type LazyHList = Rec Thunk deriving instance Eq t => Eq (ElField '(s,t)) deriving instance Ord t => Ord (ElField '(s,t)) instance Show t => Show (ElField '(s,t)) where- show (Field x) = (symbolVal (Proxy::Proxy s))++" :-> "++show x+ show (Field x) = symbolVal (Proxy::Proxy s) ++" :-> "++show x -- | Get the data payload of an 'ElField'. getField :: ElField '(s,t) -> t getField (Field x) = x +-- | Get the label name of an 'ElField'.+getLabel :: forall s t. ElField '(s,t) -> String+getLabel (Field _) = symbolVal (Proxy::Proxy s)+ -- | 'ElField' is isomorphic to a functor something like @Compose -- ElField ('(,) s)@. fieldMap :: (a -> b) -> ElField '(s,a) -> ElField '(s,b)@@ -43,9 +72,48 @@ rfield f (Field x) = fmap Field (f x) {-# INLINE rfield #-} +infix 8 =:++-- | Operator for creating an 'ElField'. With the @-XOverloadedLabels@+-- extension, this permits usage such as, @#foo =: 23@ to produce a+-- value of type @ElField ("foo" ::: Int)@.+(=:) :: KnownSymbol l => Label (l :: Symbol) -> (v :: *) -> ElField (l ::: v)+_ =: v = Field v++-- | Get a named field from a record.+rgetf+ :: forall l f v record us. HasField record l us v+ => Label l -> record f us -> f (l ::: v)+rgetf _ = rget (Proxy :: Proxy (l ::: v))++-- | Get the value associated with a named field from a record.+rvalf+ :: HasField record l us v => Label l -> record ElField us -> v+rvalf x = getField . rgetf x++-- | Set a named field. @rputf #foo 23@ sets the field named @#foo@ to+-- @23@.+rputf :: forall l v record us. (HasField record l us v, KnownSymbol l)+ => Label l -> v -> record ElField us -> record ElField us+rputf _ = rput . (Field :: v -> ElField '(l,v))++-- | A lens into a 'Rec' identified by a 'Label'.+rlensf' :: forall l v record g f us. (Functor g, HasField record l us v)+ => Label l+ -> (f (l ::: v) -> g (f (l ::: v)))+ -> record f us+ -> g (record f us)+rlensf' _ f = rlens (Proxy :: Proxy (l ::: v)) f++-- | A lens into the payload value of a 'Rec' field identified by a+-- 'Label'.+rlensf :: forall l v record g f us. (Functor g, HasField record l us v)+ => Label l -> (v -> g v) -> record ElField us -> g (record ElField us)+rlensf _ f = rlens (Proxy :: Proxy (l ::: v)) (rfield f)+ -- | Shorthand for a 'FieldRec' with a single field.-(=:) :: KnownSymbol s => proxy '(s,a) -> a -> FieldRec '[ '(s,a) ]-(=:) _ x = Field x :& RNil+(=:=) :: KnownSymbol s => proxy '(s,a) -> a -> FieldRec '[ '(s,a) ]+(=:=) _ x = Field x :& RNil -- | A proxy for field types. data SField (field :: k) = SField@@ -61,3 +129,61 @@ alignment _ = alignment (undefined::t) peek ptr = Field `fmap` peek (castPtr ptr) poke ptr (Field x) = poke (castPtr ptr) x++type family FieldType l fs where+ FieldType l '[] = TypeError ('Text "Cannot find label "+ ':<>: 'ShowType l+ ':<>: 'Text " in fields")+ FieldType l ((l ::: v) ': fs) = v+ FieldType l ((l' ::: v') ': fs) = FieldType l fs++-- | Constraint that a label is associated with a particular type in a+-- record.+type HasField record l fs v =+ (RecElem record (l ::: v) fs (RIndex (l ::: v) fs), FieldType l fs ~ v)++-- | Proxy for label type+data Label (a :: Symbol) = Label+ deriving (Eq, Show)++instance s ~ s' => IsLabel s (Label s') where+#if __GLASGOW_HASKELL__ < 802+ fromLabel _ = Label+#else+ fromLabel = Label+#endif++-- | Defines a constraint that lets us extract the label from an+-- 'ElField'. Used in 'rmapf' and 'rpuref'.+class (KnownSymbol (Fst a), a ~ '(Fst a, Snd a)) => KnownField a where+instance KnownSymbol l => KnownField (l ::: v) where++-- | Shorthand for working with records of fields as in 'rmapf' and+-- 'rpuref'.+type AllFields fs = (AllConstrained KnownField fs, RecApplicative fs)++-- | Map a function between functors across a 'Rec' taking advantage+-- of knowledge that each element is an 'ElField'.+rmapf :: AllFields fs+ => (forall a. KnownField a => f a -> g a)+ -> Rec f fs -> Rec g fs+rmapf f = (rpureConstrained (Proxy :: Proxy KnownField) (Lift f) <<*>>)++-- | Construct a 'Rec' with 'ElField' elements.+rpuref :: AllFields fs => (forall a. KnownField a => f a) -> Rec f fs+rpuref f = rpureConstrained (Proxy :: Proxy KnownField) f++-- | Operator synonym for 'rmapf'.+(<<$$>>)+ :: AllFields fs+ => (forall a. KnownField a => f a -> g a) -> Rec f fs -> Rec g fs+(<<$$>>) = rmapf++-- | Produce a 'Rec' of the labels of a 'Rec' of 'ElField's.+rlabels :: AllFields fs => Rec (Const String) fs+rlabels = rpuref getLabel'+ where getLabel' :: forall l v. KnownSymbol l+ => Const String (l ::: v)+ getLabel' = Const (symbolVal (Proxy::Proxy l))++-- * Specializations for working with an 'ARec' of named fields.
Data/Vinyl/Lens.hs view
@@ -7,10 +7,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-+-- | Lenses into record fields. module Data.Vinyl.Lens- ( RElem(..)- , RSubset(..)+ ( RecElem(..)+ , RElem+ , RecSubset(..)+ , RSubset , REquivalent , type (∈) , type (⊆)@@ -28,7 +30,7 @@ -- The third parameter to 'RElem', @i@, is there to help the constraint solver -- realize that this is a decidable predicate with respect to the judgemental -- equality in @k@.-class i ~ RIndex r rs => RElem (r :: k) (rs :: [k]) (i :: Nat) where+class i ~ RIndex r rs => RecElem record (r :: k) (rs :: [k]) (i :: Nat) where -- | We can get a lens for getting and setting the value of a field which is -- in a record. As a convenience, we take a proxy argument to fix the@@ -40,13 +42,13 @@ :: Functor g => sing r -> (f r -> g (f r))- -> Rec f rs- -> g (Rec f rs)+ -> record f rs+ -> g (record f rs) -- | For Vinyl users who are not using the @lens@ package, we provide a getter. rget :: sing r- -> Rec f rs+ -> record f rs -> f r -- | For Vinyl users who are not using the @lens@ package, we also provide a@@ -54,21 +56,24 @@ -- and so we do not take a proxy argument here. rput :: f r- -> Rec f rs- -> Rec f rs+ -> record f rs+ -> record f rs +-- | 'RecElem' for classic vinyl 'Rec' types.+type RElem = RecElem Rec+ -- This is an internal convenience stolen from the @lens@ library. lens :: Functor f- => (t -> s)- -> (t -> a -> b)- -> (s -> f a)- -> t- -> f b+ => (s -> a)+ -> (s -> b -> t)+ -> (a -> f b)+ -> s+ -> f t lens sa sbt afb s = fmap (sbt s) $ afb (sa s) {-# INLINE lens #-} -instance RElem r (r ': rs) 'Z where+instance RecElem Rec r (r ': rs) 'Z where rlens _ f (x :& xs) = fmap (:& xs) (f x) {-# INLINE rlens #-} rget k = getConst . rlens k Const@@ -76,7 +81,7 @@ rput y = getIdentity . rlens Proxy (\_ -> Identity y) {-# INLINE rput #-} -instance (RIndex r (s ': rs) ~ 'S i, RElem r rs i) => RElem r (s ': rs) ('S i) where+instance (RIndex r (s ': rs) ~ 'S i, RElem r rs i) => RecElem Rec r (s ': rs) ('S i) where rlens p f (x :& xs) = fmap (x :&) (rlens p f xs) {-# INLINE rlens #-} rget k = getConst . rlens k Const@@ -88,38 +93,40 @@ -- record to the former's is evident. That is, we can either cast a larger -- record to a smaller one, or we may replace the values in a slice of a -- record.-class is ~ RImage rs ss => RSubset (rs :: [k]) (ss :: [k]) is where+class is ~ RImage rs ss => RecSubset record (rs :: [k]) (ss :: [k]) is where -- | This is a lens into a slice of the larger record. Morally, we have: -- -- > rsubset :: Lens' (Rec f ss) (Rec f rs) rsubset :: Functor g- => (Rec f rs -> g (Rec f rs))- -> Rec f ss- -> g (Rec f ss)+ => (record f rs -> g (record f rs))+ -> record f ss+ -> g (record f ss) -- | The getter of the 'rsubset' lens is 'rcast', which takes a larger record -- to a smaller one by forgetting fields. rcast- :: Rec f ss- -> Rec f rs+ :: record f ss+ -> record f rs rcast = getConst . rsubset Const {-# INLINE rcast #-} -- | The setter of the 'rsubset' lens is 'rreplace', which allows a slice of -- a record to be replaced with different values. rreplace- :: Rec f rs- -> Rec f ss- -> Rec f ss+ :: record f rs+ -> record f ss+ -> record f ss rreplace rs = getIdentity . rsubset (\_ -> Identity rs) {-# INLINE rreplace #-} -instance RSubset '[] ss '[] where+type RSubset = RecSubset Rec++instance RecSubset Rec '[] ss '[] where rsubset = lens (const RNil) const -instance (RElem r ss i , RSubset rs ss is) => RSubset (r ': rs) ss (i ': is) where+instance (RElem r ss i , RSubset rs ss is) => RecSubset Rec (r ': rs) ss (i ': is) where rsubset = lens (\ss -> rget Proxy ss :& rcast ss) set where set :: Rec f ss -> Rec f (r ': rs) -> Rec f ss
Data/Vinyl/Tutorial/Overview.hs view
@@ -27,7 +27,7 @@ >>> import Control.Lens.TH >>> import Data.Char >>> import Test.DocTest->>> import Data.Singletons.TH+>>> import Data.Singletons.TH (genSingletons) >>> import Data.Maybe Let's define a universe of fields which we want to use.
Data/Vinyl/TypeLevel.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -16,6 +19,41 @@ -- | A mere approximation of the natural numbers. And their image as lifted by -- @-XDataKinds@ corresponds to the actual natural numbers. data Nat = Z | S !Nat++-- | Produce a runtime 'Int' value corresponding to a 'Nat' type.+class NatToInt (n :: Nat) where+ natToInt :: Int++instance NatToInt 'Z where+ natToInt = 0+ {-# INLINE natToInt #-}++instance NatToInt n => NatToInt ('S n) where+ natToInt = 1 + natToInt @n+ {-# INLINE natToInt #-}++-- | Reify a list of type-level natural number indices as runtime+-- 'Int's relying on instances of 'NatToInt'.+class IndexWitnesses (is :: [Nat]) where+ indexWitnesses :: [Int]++instance IndexWitnesses '[] where+ indexWitnesses = []+ {-# INLINE indexWitnesses #-}++instance (IndexWitnesses is, NatToInt i) => IndexWitnesses (i ': is) where+ indexWitnesses = natToInt @i : indexWitnesses @is+ {-# INLINE indexWitnesses #-}++-- | Project the first component of a type-level tuple.+type family Fst (a :: (k1,k2)) where Fst '(x,y) = x++-- | Project the second component of a type-level tuple.+type family Snd (a :: (k1,k2)) where Snd '(x,y) = y++type family RLength xs where+ RLength '[] = 'Z+ RLength (x ': xs) = 'S (RLength xs) -- | A partial relation that gives the index of a value in a list. type family RIndex (r :: k) (rs :: [k]) :: Nat where
+ benchmarks/AccessorsBench.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++import Control.Monad (unless)+import Criterion.Main+import Data.Vinyl+import System.Exit (exitFailure)++newF :: FieldRec '[ '( "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 = 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++main :: IO ()+main =+ do let arec = toARec newF+ unless (rvalf #a15 arec == rvalf #a15 newF)+ (do putStrLn "AFieldRec accessor disagrees with rvalf"+ exitFailure)+ defaultMain+ [ bgroup "FieldRec"+ [ bench "a0" $ nf (rvalf #a0) newF+ , bench "a4" $ nf (rvalf #a4) newF+ , bench "a8" $ nf (rvalf #a8) newF+ , bench "a12" $ nf (rvalf #a12) newF+ , bench "a15" $ nf (rvalf #a15) newF+ ]+ , bgroup "AFieldRec"+ [ bench "a0" $ nf (rvalf #a0) arec+ , bench "a4" $ nf (rvalf #a4) arec+ , bench "a8" $ nf (rvalf #a8) arec+ , bench "a12" $ nf (rvalf #a12) arec+ , bench "a15" $ nf (rvalf #a15) arec+ ]+ ]
benchmarks/StorableBench.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-}+{-# LANGUAGE DataKinds, GADTs, OverloadedLabels, ScopedTypeVariables,+ TypeOperators #-} -- A benchmark where we initialize a 'V.Vector' of random vertices, -- each carrying 3D position, 2D texture coordinates, and a 3D normal -- vector. A calculation is carried out where we multiply the y@@ -7,7 +8,8 @@ -- by interfacing the vertex data as a flat record, a traditional -- record of "Linear" finite dimensional vector types, and a vinyl -- record of linear fields.-import Control.Lens+import Lens.Micro+import Lens.Micro.Extras (view) import Control.Monad (when) import qualified Data.Foldable as F import Data.Proxy@@ -33,9 +35,19 @@ type MyFields a = [ '("pos", V3 a), '("tex", V2 a), '("normal", V3 a) ] type MyVertex a = FieldRec (MyFields a) +(*~) :: Num a => ASetter s t a a -> a -> s -> t+l *~ x = l %~ (* x)+infixr 4 *~+ vinylNormSumLens :: (Num a, Storable a) => V.Vector (MyVertex a) -> a vinylNormSumLens = V.sum . V.map (F.sum . view (rlens vNorm . rfield)) +vinylNormSumLabelLens :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSumLabelLens = V.sum . V.map (F.sum . view (rlensf #normal))++vinylNormSumLabel :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSumLabel = V.sum . V.map (F.sum . rvalf #normal)+ doubleNormYLens :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float) doubleNormYLens = V.map (rlens vNorm . rfield . _y *~ (2::Float)) @@ -53,9 +65,12 @@ reasVerts = V.unsafeCast vals vinylAns = vinylNormSum $ doubleNormY vinylVerts vinylLans = vinylNormSumLens $ doubleNormYLens vinylVerts+ vinylLabAns = vinylNormSumLabel $ doubleNormYLens vinylVerts+ vinylLabLans = vinylNormSumLabelLens $ doubleNormYLens vinylVerts flatAns = flatNormSum $ doubleNormFlat flatVerts reasAns = reasNormSum $ doubleNormReas reasVerts- when (any (/= vinylAns) [vinylLans, flatAns, reasAns])+ when (any (/= vinylAns) [ vinylLans, flatAns, reasAns+ , vinylLabAns, vinylLabLans ]) (error "Not all versions compute the same answer") defaultMain [ bench "flat" $ whnf (flatNormSum . doubleNormFlat) flatVerts@@ -63,6 +78,10 @@ whnf (vinylNormSum . doubleNormY) vinylVerts , bench "vinyl-lens" $ whnf (vinylNormSumLens . doubleNormYLens) vinylVerts+ , bench "vinyl-label" $+ whnf (vinylNormSumLabel . doubleNormYLens) vinylVerts+ , bench "vinyl-label-lens" $+ whnf (vinylNormSumLabelLens . doubleNormYLens) vinylVerts , bench "reasonable" $ whnf (reasNormSum . doubleNormReas) reasVerts ] where n = 1000
tests/Intro.lhs view
@@ -27,7 +27,7 @@ > import Control.Lens.TH > import Data.Char > import Test.DocTest-> import Data.Singletons.TH+> import Data.Singletons.TH (genSingletons) Let’s define a universe of fields which we want to use.
tests/Spec.hs view
@@ -1,8 +1,13 @@-{-# LANGUAGE DataKinds, FlexibleContexts, GADTs, ScopedTypeVariables,+{-# LANGUAGE CPP, DataKinds, FlexibleContexts, GADTs, ScopedTypeVariables, TypeOperators #-}+#if __GLASGOW_HASKELL__ > 800+{-# LANGUAGE OverloadedLabels #-}+#endif+ {-# OPTIONS_GHC -Wall #-} import Data.Vinyl import Data.Vinyl.Functor (Lift(..), Const(..), Compose(..), (:.))+import Lens.Micro import Test.Hspec import qualified CoRecSpec as C@@ -15,13 +20,13 @@ -- :& Field @"Y" (id :: String -> String) -- :& RNil -d1' :: Rec (Const String) '[ '("X", Int), '("Y", String) ]+d1' :: Rec (Const String) '[ '("x", Int), '("y", String) ] d1' = Const "5" :& Const "Hi" :& RNil -d2' :: Rec ((->) String :. ElField) '[ '("X", Int), '("Y", String) ]+d2' :: Rec ((->) String :. ElField) '[ '("x", Int), '("y", String) ] d2' = Compose (Field . read) :& Compose (Field . id) :& RNil -d3 :: Rec ElField '[ '("X", Int), '("Y", String) ]+d3 :: Rec ElField '[ '("x", Int), '("y", String) ] d3 = rmap (\(Compose f) -> Lift (f . getConst)) d2' <<*>> d1' main :: IO ()@@ -29,3 +34,16 @@ C.spec describe "Rec is like an Applicative" $ do it "Can apply parsing functions" $ d3 `shouldBe` Field 5 :& Field "Hi" :& RNil+#if __GLASGOW_HASKELL__ > 800+ 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+ 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+ it "Can go back and forth" $+ rvalf #y (toARec (rlensf #y %~ (show . length) $+ fromARec (rputf #x 7 (toARec d3))))+ `shouldBe` "2"+#endif
vinyl.cabal view
@@ -1,18 +1,18 @@ name: vinyl-version: 0.7.0+version: 0.8.1 synopsis: Extensible Records -- description: license: MIT license-file: LICENSE author: Jonathan Sterling-maintainer: jonsterling@me.com+maintainer: acowley@gmail.com -- copyright: category: Records stability: Experimental build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md-tested-with: GHC == 7.10.3, GHC == 8.0.2+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 description: Extensible records for Haskell with lenses. @@ -22,6 +22,7 @@ library exposed-modules: Data.Vinyl+ , Data.Vinyl.ARec , Data.Vinyl.Class.Method , Data.Vinyl.Core , Data.Vinyl.CoRec@@ -33,7 +34,8 @@ , Data.Vinyl.Notation , Data.Vinyl.Tutorial.Overview build-depends: base >=4.7 && <= 5,- ghc-prim+ ghc-prim,+ array default-language: Haskell2010 ghc-options: -fwarn-dodgy-exports -fwarn-dodgy-imports -fwarn-unused-matches -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-record-updates -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-orphans -fwarn-overlapping-patterns -fwarn-tabs -fwarn-type-defaults @@ -46,7 +48,7 @@ criterion, vinyl, mwc-random,- lens,+ microlens, linear, primitive ghc-options: -O2@@ -61,6 +63,14 @@ ghc-options: -O2 default-language: Haskell2010 +benchmark accessors+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: AccessorsBench.hs+ build-depends: base >= 4.7 && <= 5, criterion, tagged, vinyl+ ghc-options: -O2+ default-language: Haskell2010+ test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -75,6 +85,7 @@ other-modules: CoRecSpec build-depends: base , vinyl+ , microlens , hspec >= 2.2.4 && < 2.5 , should-not-typecheck >= 2.0 && < 2.2 ghc-options: -threaded -rtsopts -with-rtsopts=-N