diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/Data/Vinyl.hs b/Data/Vinyl.hs --- a/Data/Vinyl.hs +++ b/Data/Vinyl.hs @@ -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 - diff --git a/Data/Vinyl/ARec.hs b/Data/Vinyl/ARec.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/ARec.hs @@ -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) diff --git a/Data/Vinyl/Core.hs b/Data/Vinyl/Core.hs --- a/Data/Vinyl/Core.hs +++ b/Data/Vinyl/Core.hs @@ -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 diff --git a/Data/Vinyl/Derived.hs b/Data/Vinyl/Derived.hs --- a/Data/Vinyl/Derived.hs +++ b/Data/Vinyl/Derived.hs @@ -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. diff --git a/Data/Vinyl/Lens.hs b/Data/Vinyl/Lens.hs --- a/Data/Vinyl/Lens.hs +++ b/Data/Vinyl/Lens.hs @@ -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 diff --git a/Data/Vinyl/Tutorial/Overview.hs b/Data/Vinyl/Tutorial/Overview.hs --- a/Data/Vinyl/Tutorial/Overview.hs +++ b/Data/Vinyl/Tutorial/Overview.hs @@ -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. diff --git a/Data/Vinyl/TypeLevel.hs b/Data/Vinyl/TypeLevel.hs --- a/Data/Vinyl/TypeLevel.hs +++ b/Data/Vinyl/TypeLevel.hs @@ -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 diff --git a/benchmarks/AccessorsBench.hs b/benchmarks/AccessorsBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AccessorsBench.hs @@ -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 + ] + ] diff --git a/benchmarks/StorableBench.hs b/benchmarks/StorableBench.hs --- a/benchmarks/StorableBench.hs +++ b/benchmarks/StorableBench.hs @@ -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 diff --git a/tests/Intro.lhs b/tests/Intro.lhs --- a/tests/Intro.lhs +++ b/tests/Intro.lhs @@ -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. diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 diff --git a/vinyl.cabal b/vinyl.cabal --- a/vinyl.cabal +++ b/vinyl.cabal @@ -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