vinyl 0.8.1.1 → 0.9.0
raw patch · 21 files changed
+1584/−291 lines, 21 files
Files
- CHANGELOG.md +16/−0
- Data/Vinyl.hs +13/−0
- Data/Vinyl/ARec.hs +34/−17
- Data/Vinyl/Class/Method.hs +111/−23
- Data/Vinyl/CoRec.hs +45/−17
- Data/Vinyl/Core.hs +126/−70
- Data/Vinyl/Derived.hs +47/−38
- Data/Vinyl/FromTuple.hs +136/−0
- Data/Vinyl/Functor.hs +83/−14
- Data/Vinyl/Lens.hs +123/−46
- Data/Vinyl/SRec.hs +398/−0
- Data/Vinyl/Syntax.hs +45/−0
- Data/Vinyl/Tutorial/Overview.hs +11/−10
- Data/Vinyl/TypeLevel.hs +1/−1
- Data/Vinyl/XRec.hs +182/−0
- benchmarks/AccessorsBench.hs +153/−12
- benchmarks/StorableBench.hs +3/−14
- tests/CoRecSpec.hs +3/−3
- tests/Intro.lhs +13/−12
- tests/Spec.hs +33/−11
- vinyl.cabal +8/−3
CHANGELOG.md view
@@ -1,3 +1,19 @@+# 0.9.0++- A new `SRec` type for constant time field access for records with densely packed `Storable` fields. Conversion from `Rec` is accomplished with `toSRec`, while `fromSRec` takes you back to `Rec`. Record updates are fairly slow compared to native Haskell records and even `Rec`, but reading a field is as fast as anything.++- Concise record construction syntax from tuples. Construct a `FieldRec` with `fieldRec (#x =: True, #y =: 'b')` and have the type inferred as `Rec ElField '[ '("x", Bool), '("y", Char) ]`. Or use `record` to build records of any functor. Thanks to @heptahedron on GitHub for prompting this feature, and @sboosali for thinking through various approaches.++- Optional concise record field lens syntax. This uses an orphan `IsLabel` instance for all function types, so will conflict with any other library that does the same. Thus it is entirely opt-in: to enable this syntax, you must explicitly `import Data.Vinyl.Syntax`. This enables the use of labels as lenses. For example, `myRec & #name %~ map toUpper` to apply `map toUpper` to the `#name` field of the record value `myRec`. This technique is thanks to Tikhon Jelvis who shared it on the Haskell-Cafe mailing list.++- Field lenses can now change the type of a record. Thanks to @heptahedron on GitHub for exploring this feature. Using the above-mentioned features, one might now write something like `myRec & #name %~ length` to produce a record whose `#name` field is the length of the`String` `#name` field of some record value, `myRec`.++- Changed the type of `=:=` again to work directly with `Label`s as this is the most convenient usage.++- Definitions in `Data.Vinyl.Core` are now consistently in terms of type classes. This permits inlining and specialization to a user's record types. In the case where the record type is known, call sites do not change. But for functions polymorphic in the record's fields, a constraint will be required. If those constraints are a nuisance, or compile times increase beyond comfort, users should use definitions from the `Data.Vinyl.Recursive` that are written in a recursive style (as in previous versions of the `vinyl` package), treating the record as a list of fields.++- Added `restrictCoRec` and `weakenCoRec` suggested by @ElvishJerricco+ # 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`.
Data/Vinyl.hs view
@@ -1,11 +1,24 @@+{-# LANGUAGE PatternSynonyms #-} module Data.Vinyl ( module Data.Vinyl.Core+ , module Data.Vinyl.Class.Method , module Data.Vinyl.ARec , module Data.Vinyl.Derived+ , module Data.Vinyl.FromTuple+ , module Data.Vinyl.Functor , module Data.Vinyl.Lens+ , module Data.Vinyl.SRec+ , module Data.Vinyl.XRec ) where import Data.Vinyl.Core+import Data.Vinyl.Class.Method (RecMapMethod(..), RecPointed(..))+import Data.Vinyl.Class.Method (rmapMethodF, mapFields) import Data.Vinyl.ARec (ARec, toARec, fromARec) import Data.Vinyl.Derived+import Data.Vinyl.FromTuple (record, fieldRec, ruple, xrec, xrecX, xrecTuple)+import Data.Vinyl.Functor (ElField(..)) import Data.Vinyl.Lens+import Data.Vinyl.SRec (SRec, toSRec, fromSRec)+import Data.Vinyl.XRec (XRec, pattern (::&), pattern XRNil, IsoXRec(..))+import Data.Vinyl.XRec (xrmap, xrapply, rmapX, XRMap, XRApply)
Data/Vinyl/ARec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -21,7 +22,6 @@ import qualified Data.Array as Array import qualified Data.Array.Base as BArray-import Data.Proxy import GHC.Exts (Any) import Unsafe.Coerce @@ -45,9 +45,9 @@ -- | Convert an 'ARec' into a 'Rec'. fromARec :: forall f ts.- (RecApplicative ts, AllConstrained (IndexableField ts) ts)+ (RecApplicative ts, RPureConstrained (IndexableField ts) ts) => ARec f ts -> Rec f ts-fromARec (ARec arr) = rpureConstrained (Proxy :: Proxy (IndexableField ts)) aux+fromARec (ARec arr) = rpureConstrained @(IndexableField ts) aux where aux :: forall t. NatToInt (RIndex t ts) => f t aux = unsafeCoerce (arr Array.! natToInt @(RIndex t ts)) {-# INLINE fromARec #-}@@ -59,23 +59,40 @@ {-# 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 :: forall t t' f ts 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))+alens :: forall f g t t' ts ts'. (Functor g, NatToInt (RIndex t ts))+ => (f t -> g (f t')) -> ARec f ts -> g (ARec f ts')+alens f ar = fmap (flip (aput @t) 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+-- instance (i ~ RIndex t ts, i ~ RIndex t' ts', NatToInt (RIndex t ts)) => RecElem ARec t t' ts ts' i where+-- rlens = alens+-- rget = aget+-- rput = aput +instance RecElem ARec t t' (t ': ts) (t' ': ts) 'Z where+ rlensC = alens+ {-# INLINE rlensC #-}+ rgetC = aget+ {-# INLINE rgetC #-}+ rputC = aput @t+ {-# INLINE rputC #-}++instance (RIndex t (s ': ts) ~ 'S i, NatToInt i, RecElem ARec t t' ts ts' i)+ => RecElem ARec t t' (s ': ts) (s ': ts') ('S i) where+ rlensC = alens+ {-# INLINE rlensC #-}+ rgetC = aget+ {-# INLINE rgetC #-}+ rputC = aput @t+ {-# INLINE rputC #-}+ -- | Get a subset of a record's fields. arecGetSubset :: forall rs ss f. (IndexWitnesses (RImage rs ss), NatToInt (RLength rs))@@ -97,20 +114,20 @@ 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 #-}+ rsubsetC f big = fmap (arecSetSubset big) (f (arecGetSubset big))+ {-# INLINE rsubsetC #-} -instance (AllConstrained (IndexableField rs) rs,+instance (RPureConstrained (IndexableField rs) rs, RecApplicative rs, Show (Rec f rs)) => Show (ARec f rs) where show = show . fromARec -instance (AllConstrained (IndexableField rs) rs,+instance (RPureConstrained (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,+instance (RPureConstrained (IndexableField rs) rs, RecApplicative rs, Ord (Rec f rs)) => Ord (ARec f rs) where compare x y = compare (fromARec x) (fromARec y)
Data/Vinyl/Class/Method.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-}@@ -6,7 +15,7 @@ {-# LANGUAGE ConstraintKinds #-} {-| This module uses 'RecAll' to extend common typeclass methods to records.- Generally, it is preferable to use the original typeclass methods to these + Generally, it is preferable to use the original typeclass methods to these variants. For example, in most places where 'recCompare' could be used, you could use 'compare' instead. They are useful in scenarios that involve working on unknown subsets of a record's fields@@ -14,10 +23,17 @@ is given at the bottom of this page. -} -module Data.Vinyl.Class.Method - ( -- * Eq Functions- recEq- -- * Ord Functions+module Data.Vinyl.Class.Method+ ( -- * Mapping methods over records+ RecMapMethod(..)+ , rmapMethodF+ , mapFields+ , RecPointed(..)+ -- * Support for 'RecMapMethod'+ , FieldTyper, ApplyFieldTyper, PayloadType+ -- * Eq Functions+ , recEq+ -- * Ord Functions , recCompare -- * Monoid Functions , recMempty@@ -38,6 +54,8 @@ ) where import Data.Vinyl.Core+import Data.Vinyl.Derived (FieldRec)+import Data.Vinyl.Functor ((:.), ElField(..)) import Data.Vinyl.TypeLevel import Data.Monoid @@ -49,12 +67,12 @@ recCompare RNil RNil = EQ recCompare (a :& as) (b :& bs) = compare a b <> recCompare as bs --- | This function differs from the original 'mempty' in that +-- | This function differs from the original 'mempty' in that -- it takes an argument. In some cases, you will already--- have a record of the type you are interested in, and +-- have a record of the type you are interested in, and -- that can be passed an the argument. In other situations -- where this is not the case, you may need the--- interpretation function of the argument record to be +-- interpretation function of the argument record to be -- @Const ()@ or @Proxy@ so the you can generate the -- argument with 'rpure'. recMempty :: RecAll f rs Monoid => Rec proxy rs -> Rec f rs@@ -85,15 +103,15 @@ recAbs :: RecAll f rs Num => Rec f rs -> Rec f rs recAbs RNil = RNil-recAbs (a :& as) = abs a :& recAbs as +recAbs (a :& as) = abs a :& recAbs as recSignum :: RecAll f rs Num => Rec f rs -> Rec f rs recSignum RNil = RNil-recSignum (a :& as) = signum a :& recAbs as +recSignum (a :& as) = signum a :& recAbs as recNegate :: RecAll f rs Num => Rec f rs -> Rec f rs recNegate RNil = RNil-recNegate (a :& as) = negate a :& recAbs as +recNegate (a :& as) = negate a :& recAbs as -- | This function differs from the original 'minBound'. -- See 'recMempty'.@@ -107,9 +125,82 @@ recMaxBound RNil = RNil recMaxBound (_ :& rs) = maxBound :& recMaxBound rs +-- | When we wish to apply a typeclass method to each field of a+-- 'Rec', we typically care about typeclass instances of the record+-- field types irrespective of the record's functor context. To expose+-- the field types themselves, we utilize a constraint built from a+-- defunctionalized type family in the 'rmapMethod' method. The+-- symbols of the function space are defined by this data type.+data FieldTyper = FieldId | FieldSnd++-- | The interpretation function of the 'FieldTyper' symbols.+type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where+ ApplyFieldTyper 'FieldId a = a+ ApplyFieldTyper 'FieldSnd '(s, b) = b++-- | A mapping of record contexts into the 'FieldTyper' function+-- space. We explicitly match on 'ElField' to pick out the payload+-- type, and 'Compose' to pick out the inner-most context. All other+-- type constructor contexts are understood to not perform any+-- computation on their arguments.+type family FieldPayload (f :: u -> *) :: FieldTyper where+ FieldPayload ElField = 'FieldSnd+ FieldPayload (f :. g) = FieldPayload g+ FieldPayload f = 'FieldId++-- | Shorthand for combining 'ApplyFieldTyper' and 'FieldPayload'.+type family PayloadType f (a :: u) :: * where+ PayloadType f a = ApplyFieldTyper (FieldPayload f) a++-- | Generate a record from fields derived from type class+-- instances.+class RecPointed c (f :: u -> *) (ts :: [u]) where+ rpointMethod :: (forall (a :: u). c (f a) => f a) -> Rec f ts++instance RecPointed c f '[] where+ rpointMethod _ = RNil+ {-# INLINE rpointMethod #-}++instance (c (f t), RecPointed c f ts)+ => RecPointed c f (t ': ts) where+ rpointMethod f = f :& rpointMethod @c f+ {-# INLINE rpointMethod #-}++-- | Apply a typeclass method to each field of a 'Rec'.+class RecMapMethod c (f :: u -> *) (ts :: [u]) where+ rmapMethod :: (forall a. c (PayloadType f a) => f a -> g a)+ -> Rec f ts -> Rec g ts++instance RecMapMethod c f '[] where+ rmapMethod _ RNil = RNil+ {-# INLINE rmapMethod #-}++instance (c (PayloadType f t), RecMapMethod c f ts)+ => RecMapMethod c f (t ': ts) where+ rmapMethod f (x :& xs) = f x :& rmapMethod @c f xs+ {-# INLINE rmapMethod #-}++-- | Apply a typeclass method to each field of a @Rec f ts@ using the+-- 'Functor' instance for @f@ to lift the function into the+-- functor. This is a commonly-used specialization of 'rmapMethod'+-- composed with 'fmap'.+rmapMethodF :: forall c f ts. (Functor f, FieldPayload f ~ 'FieldId, RecMapMethod c f ts)+ => (forall a. c a => a -> a) -> Rec f ts -> Rec f ts+rmapMethodF f = rmapMethod @c (fmap f)+{-# INLINE rmapMethodF #-}++-- | Apply a typeclass method to each field of a 'FieldRec'. This is a+-- specialization of 'rmapMethod'.+mapFields :: forall c ts. RecMapMethod c ElField ts+ => (forall a. c a => a -> a) -> FieldRec ts -> FieldRec ts+mapFields f = rmapMethod @c g+ where g :: c (PayloadType ElField t) => ElField t -> ElField t+ g (Field x) = Field (f x)+{-# INLINE mapFields #-}+ {- $example- This module provides variants of typeclass methods that have - a 'RecAll' constraint instead of the normal typeclass + This module provides variants of typeclass methods that have+ a 'RecAll' constraint instead of the normal typeclass constraint. For example, a type-specialized 'compare' would look like this: @@ -119,24 +210,24 @@ > recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering - The only difference is the constraint. Let's look at a potential + The only difference is the constraint. Let's look at a potential use case for these functions. - Let's write a function that projects out a subrecord from two records and - then compares those for equality. We can write this with + Let's write a function that projects out a subrecord from two records and+ then compares those for equality. We can write this with the '<:' operator from @Data.Vinyl.Lens@ and the normal 'compare' function. We don't need 'recCompare': > -- This needs ScopedTypeVariables-> projectAndCompare :: forall super sub f. (super <: sub, Ord (Rec f sub)) +> projectAndCompare :: forall super sub f. (super <: sub, Ord (Rec f sub)) > => Proxy sub -> Rec f super -> Rec f super -> Ordering > projectAndCompare _ a b = compare (rcast a :: Rec f sub) (rcast b :: Rec f sub) - That works fine for the majority of use cases, and it is probably how you should + That works fine for the majority of use cases, and it is probably how you should write the function if it does everything you need. However, let's consider- a somewhat more complicated case. + a somewhat more complicated case. - What if the exact subrecord we were projecting couldn't be + What if the exact subrecord we were projecting couldn't be known at compile time? Assume that the end user was allowd to choose the fields on which he or she wanted to compare records. The @projectAndCompare@ function cannot handle this because of the@@ -187,6 +278,3 @@ Notice that in this case, the 'Ord' constraint applies to the full set of fields and is then weakened to target a subset of them instead. -}---
Data/Vinyl/CoRec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns, CPP, ConstraintKinds, DataKinds, EmptyCase, FlexibleContexts, FlexibleInstances, GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds,@@ -38,30 +39,33 @@ -- reverse order. newtype Op b a = Op { runOp :: a -> b } -instance forall ts. (AllConstrained Show ts, RecApplicative ts)+instance forall ts. (RPureConstrained Show ts, RecApplicative ts) => Show (CoRec Identity ts) where show (CoRec (Identity x)) = "(Col "++show' x++")" where shower :: Rec (Op String) ts- shower = rpureConstrained (Proxy::Proxy Show) (Op show)- show' = runOp (rget Proxy shower)+ shower = rpureConstrained @Show (Op show)+ show' = runOp (rget shower) -instance forall ts. (RecAll Maybe ts Eq, RecApplicative ts)+instance forall ts. (RecApplicative ts, RecordToList ts,+ RZipWith ts, ReifyConstraint Eq Maybe ts, RMap ts) => Eq (CoRec Identity ts) where crA == crB = and . recordToList $ rzipWith f (toRec crA) (coRecToRec' crB) where f :: forall a. (Dict Eq :. Maybe) a -> Maybe a -> Const Bool a f (Compose (Dict a)) b = Const $ a == b- toRec = reifyConstraint (Proxy :: Proxy Eq) . coRecToRec'+ toRec = reifyConstraint @Eq . coRecToRec' -- | We can inject a a 'CoRec' into a 'Rec' where every field of the -- 'Rec' is 'Nothing' except for the one whose type corresponds to the -- type of the given 'CoRec' variant.-coRecToRec :: RecApplicative ts => CoRec f ts -> Rec (Maybe :. f) ts-coRecToRec (CoRec x) = rput (Compose $ Just x) (rpure (Compose Nothing))+coRecToRec :: forall f ts. RecApplicative ts+ => CoRec f ts -> Rec (Maybe :. f) ts+coRecToRec (CoRec x) = rput (Compose (Just x)) (rpure (Compose Nothing)) -- | Shorthand for applying 'coRecToRec' with common functors.-coRecToRec' :: RecApplicative ts => CoRec Identity ts -> Rec Maybe ts+coRecToRec' :: (RecApplicative ts, RMap ts)+ => CoRec Identity ts -> Rec Maybe ts coRecToRec' = rmap (fmap getIdentity . getCompose) . coRecToRec -- | Fold a field selection function over a 'Rec'.@@ -126,8 +130,7 @@ -> (forall a. AllSatisfied cs a => a -> b) -> CoRec f ts -> f b onCoRec p f (CoRec x) = fmap meth x- where meth = runOp $- rget Proxy (reifyDicts p (Op f) :: Rec (Op b) ts)+ where meth = runOp $ rget (reifyDicts p (Op f) :: Rec (Op b) ts) -- | Apply a type class method on a 'Field'. The first argument is a -- 'Proxy' value for a /list/ of 'Constraint' constructors. For@@ -151,11 +154,17 @@ -- * Extracting values from a CoRec/Pattern matching on a CoRec --- | Given a proxy of type t and a 'CoRec Identity' that might be a t, try to--- convert the CoRec to a t.-asA :: (t ∈ ts, RecApplicative ts) => proxy t -> CoRec Identity ts -> Maybe t-asA p c@(CoRec _) = rget p $ coRecToRec' c+-- | If a 'CoRec' is a variant of the requested type, return 'Just'+-- that value; otherwise return 'Nothing'.+asA :: (t ∈ ts, RecApplicative ts, RMap ts)+ => CoRec Identity ts -> Maybe t+asA c@(CoRec _) = rget $ coRecToRec' c +-- | Like 'asA', but for any interpretation functor.+asA' :: (t ∈ ts, RecApplicative ts, RMap ts)+ => CoRec f ts -> (Maybe :. f) t+asA' c@(CoRec _) = rget $ coRecToRec c+ -- | Pattern match on a CoRec by specifying handlers for each case. Note that -- the order of the Handlers has to match the type level list (t:ts). --@@ -168,8 +177,11 @@ -- :& RNil -- :} -- "my Bool is not: True thus it is False"-match :: CoRec Identity ts -> Handlers ts b -> b-match (CoRec (Identity t)) hs = case rget Proxy hs of H f -> f t+match :: forall ts b. CoRec Identity ts -> Handlers ts b -> b+match (CoRec (Identity t)) hs = aux t+ where aux :: forall a. RElem a ts (RIndex a ts) => a -> b+ aux x = case rget @a hs of+ H f -> f x -- | Helper for handling a variant of a 'CoRec': either the function -- is applied to the variant or the type of the 'CoRec' is refined to@@ -193,6 +205,7 @@ -- of the would-be handler match1 :: (Match1 t ts (RIndex t ts), RecApplicative ts,+ RMap ts, RMap (RDelete t ts), FoldRec (RDelete t ts) (RDelete t ts)) => Handler r t -> CoRec Identity ts@@ -202,7 +215,7 @@ . coRecToRec' matchNil :: CoRec f '[] -> r-matchNil (CoRec x) = case x of+matchNil (CoRec x) = case x of _ -> error "matchNil: impossible" -- | Newtype around functions for a to b newtype Handler b a = H (a -> b)@@ -211,3 +224,18 @@ -- ts. All functions produce a value of type 'b'. Hence, 'Handlers ts b' would -- represent something like the type-level list: [t -> b | t \in ts ] type Handlers ts b = Rec (Handler b) ts++-- | A 'CoRec' is either the first possible variant indicated by its+-- type, or a 'CoRec' that must be one of the remaining types.+restrictCoRec :: forall t ts f. (RecApplicative ts, FoldRec ts ts)+ => CoRec f (t ': ts) -> Either (f t) (CoRec f ts)+restrictCoRec = go . coRecToRec+ where go :: Rec (Maybe :. f) (t ': ts) -> Either (f t) (CoRec f ts)+ go (Compose Nothing :& xs) = Right (fromJust (firstField xs))+ go (Compose (Just x) :& _) = Left x++-- | A 'CoRec' whose possible types are @ts@ may be used at a type of+-- 'CoRec' whose possible types are @t:ts@.+weakenCoRec :: (RecApplicative ts, FoldRec (t ': ts) (t ': ts))+ => CoRec f ts -> CoRec f (t ': ts)+weakenCoRec = fromJust . firstField . (Compose Nothing :&) . coRecToRec
Data/Vinyl/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}@@ -9,10 +10,25 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | Core vinyl definitions. The 'Rec' data type is defined here, but+-- also of interest are definitions commonly used functions like+-- 'rmap', 'rapply', and 'rtraverse'.+--+-- The definitions in this module are written in terms of type classes+-- so that the definitions may be specialized to each record type at+-- which they are used. This usually helps with runtime performance,+-- but can slow down compilation time. If you are experiencing poor+-- compile times, you may wish to try the semantically equivalent+-- definitions in the "Data.Vinyl.Recursive" module: they should+-- produce the same results given the same inputs as functions defined+-- in this module, but they will not be specialized to your record+-- type. Instead, they treat the record as a list of fields, so will+-- have performance linear in the size of the record. module Data.Vinyl.Core where import Data.Monoid (Monoid)@@ -20,10 +36,6 @@ import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..)) import Data.Vinyl.Functor-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (Const(..))-#endif-import Data.Typeable (Proxy(..)) import Data.List (intercalate) import Data.Vinyl.TypeLevel import Data.Type.Equality (TestEquality (..), (:~:) (..))@@ -76,17 +88,21 @@ -- | 'Rec' @_ rs@ with labels in kind @u@ gives rise to a functor @Hask^u -> -- Hask@; that is, a natural transformation between two interpretation functors -- @f,g@ may be used to transport a value from 'Rec' @f rs@ to 'Rec' @g rs@.-rmap- :: (forall x. f x -> g x)- -> Rec f rs- -> Rec g rs-rmap _ RNil = RNil-rmap η (x :& xs) = η x :& (η `rmap` xs)-{-# INLINE rmap #-}+class RMap rs where+ rmap :: (forall x. f x -> g x) -> Rec f rs -> Rec g rs +instance RMap '[] where+ rmap _ RNil = RNil+ {-# INLINE rmap #-}++instance RMap xs => RMap (x ': xs) where+ rmap f (x :& xs) = f x :& rmap f xs+ {-# INLINE rmap #-}+ -- | A shorthand for 'rmap'. (<<$>>)- :: (forall x. f x -> g x)+ :: RMap rs+ => (forall x. f x -> g x) -> Rec f rs -> Rec g rs (<<$>>) = rmap@@ -94,7 +110,8 @@ -- | An inverted shorthand for 'rmap'. (<<&>>)- :: Rec f rs+ :: RMap rs+ => Rec f rs -> (forall x. f x -> g x) -> Rec g rs xs <<&>> f = rmap f xs@@ -102,17 +119,23 @@ -- | A record of components @f r -> g r@ may be applied to a record of @f@ to -- get a record of @g@.-rapply- :: Rec (Lift (->) f g) rs- -> Rec f rs- -> Rec g rs-rapply RNil RNil = RNil-rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs)-{-# INLINE rapply #-}+class RApply rs where+ rapply :: Rec (Lift (->) f g) rs+ -> Rec f rs+ -> Rec g rs +instance RApply '[] where+ rapply _ RNil = RNil+ {-# INLINE rapply #-}++instance RApply xs => RApply (x ': xs) where+ rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs)+ {-# INLINE rapply #-}+ -- | A shorthand for 'rapply'. (<<*>>)- :: Rec (Lift (->) f g) rs+ :: RApply rs+ => Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs (<<*>>) = rapply@@ -147,35 +170,51 @@ -- have a natural transformation from the product of @'Rec' f@ and @'Rec' g@ to -- @'Rec' h@. You can also think about this operation as zipping two records -- with the same element types but different interpretations.-rzipWith- :: (forall x . f x -> g x -> h x)- -> (forall xs . Rec f xs -> Rec g xs -> Rec h xs)-rzipWith m = \r -> case r of- RNil -> \RNil -> RNil- (fa :& fas) -> \(ga :& gas) -> m fa ga :& rzipWith m fas gas+class RZipWith xs where+ rzipWith :: (forall x . f x -> g x -> h x)+ -> Rec f xs -> Rec g xs -> Rec h xs +instance RZipWith '[] where+ rzipWith _ RNil RNil = RNil+ {-# INLINE rzipWith #-}++instance RZipWith xs => RZipWith (x ': xs) where+ rzipWith m (fa :& fas) (ga :& gas) = m fa ga :& rzipWith m fas gas+ {-# INLINE rzipWith #-}+ -- | Map each element of a record to a monoid and combine the results.-rfoldMap :: forall f m rs.- Monoid m- => (forall x. f x -> m)- -> Rec f rs- -> m-rfoldMap f = go mempty- where- go :: forall ss. m -> Rec f ss -> m- go !m record = case record of- RNil -> m- r :& rs -> go (mappend m (f r)) rs- {-# INLINABLE go #-}+class RFoldMap rs where+ rfoldMapAux :: Monoid m+ => (forall x. f x -> m)+ -> m+ -> Rec f rs+ -> m++instance RFoldMap '[] where+ rfoldMapAux _ m RNil = m+ {-# INLINE rfoldMapAux #-}++instance RFoldMap xs => RFoldMap (x ': xs) where+ rfoldMapAux f m (r :& rs) = rfoldMapAux f (mappend m (f r)) rs+ {-# INLINE rfoldMapAux #-}++rfoldMap :: forall rs m f. (Monoid m, RFoldMap rs)+ => (forall x. f x -> m) -> Rec f rs -> m+rfoldMap f = rfoldMapAux f mempty {-# INLINE rfoldMap #-} -- | A record with uniform fields may be turned into a list.-recordToList- :: Rec (Const a) rs- -> [a]-recordToList RNil = []-recordToList (x :& xs) = getConst x : recordToList xs+class RecordToList rs where+ recordToList :: Rec (Const a) rs -> [a] +instance RecordToList '[] where+ recordToList RNil = []+ {-# INLINE recordToList #-}++instance RecordToList xs => RecordToList (x ': xs) where+ recordToList (x :& xs) = getConst x : recordToList xs+ {-# INLINE recordToList #-}+ -- | Wrap up a value with a capability given by its type data Dict c a where Dict@@ -188,48 +227,64 @@ -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly, -- the constraint solver is not quite smart enough to realize this and we must -- make it patently obvious by reifying the constraint pointwise with proof.-reifyConstraint- :: RecAll f rs c- => proxy c- -> Rec f rs- -> Rec (Dict c :. f) rs-reifyConstraint prx rec =- case rec of- RNil -> RNil- (x :& xs) -> Compose (Dict x) :& reifyConstraint prx xs+class ReifyConstraint c f rs where+ reifyConstraint+ :: Rec f rs+ -> Rec (Dict c :. f) rs +instance ReifyConstraint c f '[] where+ reifyConstraint RNil = RNil+ {-# INLINE reifyConstraint #-}++instance (c (f x), ReifyConstraint c f xs)+ => ReifyConstraint c f (x ': xs) where+ reifyConstraint (x :& xs) = Compose (Dict x) :& reifyConstraint xs+ {-# INLINE reifyConstraint #-}+ -- | Build a record whose elements are derived solely from a -- constraint satisfied by each.-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 Proxy)- where go :: AllConstrained c ts' => Rec Proxy ts' -> Rec f ts'- go RNil = RNil- go (_ :& xs) = f :& go xs+class RPureConstrained c ts where+ rpureConstrained :: (forall a. c a => f a) -> Rec f ts +instance RPureConstrained c '[] where+ rpureConstrained _ = RNil+ {-# INLINE rpureConstrained #-}++instance (c x, RPureConstrained c xs) => RPureConstrained c (x ': xs) where+ rpureConstrained f = f :& rpureConstrained @c @xs f+ {-# INLINE rpureConstrained #-}+ -- | Build a record whose elements are derived solely from a -- list of constraint constructors satisfied by each.-rpureConstraints :: forall cs (f :: * -> *) proxy ts. (AllAllSat cs ts, RecApplicative ts)- => proxy cs -> (forall a. AllSatisfied cs a => f a) -> Rec f ts-rpureConstraints _ f = go (rpure Nothing)- where go :: AllAllSat cs ts' => Rec Maybe ts' -> Rec f ts'- go RNil = RNil- go (_ :& xs) = f :& go xs+class RPureConstraints cs ts where+ rpureConstraints :: (forall a. AllSatisfied cs a => f a) -> Rec f ts +instance RPureConstraints cs '[] where+ rpureConstraints _ = RNil+ {-# INLINE rpureConstraints #-}++instance (AllSatisfied cs t, RPureConstraints cs ts)+ => RPureConstraints cs (t ': ts) where+ rpureConstraints f = f :& rpureConstraints @cs @ts f+ {-# INLINE rpureConstraints #-}+ -- | Records may be shown insofar as their points may be shown. -- 'reifyConstraint' is used to great effect here.-instance RecAll f rs Show => Show (Rec f rs) where+instance (RMap rs, ReifyConstraint Show f rs, RecordToList rs)+ => Show (Rec f rs) where show xs = (\str -> "{" <> str <> "}") . intercalate ", " . recordToList . rmap (\(Compose (Dict x)) -> Const $ show x)- $ reifyConstraint (Proxy :: Proxy Show) xs+ $ reifyConstraint @Show xs instance Semigroup (Rec f '[]) where-instance (Monoid (f r), Monoid (Rec f rs))+ RNil <> RNil = RNil++instance (Semigroup (f r), Semigroup (Rec f rs)) => Semigroup (Rec f (r ': rs)) where+ (x :& xs) <> (y :& ys) = (x <> y) :& (xs <> ys) instance Monoid (Rec f '[]) where mempty = RNil@@ -255,7 +310,8 @@ peek _ = return RNil poke _ RNil = return () -instance (Storable (f r), Storable (Rec f rs)) => Storable (Rec f (r ': rs)) where+instance (Storable (f r), Storable (Rec f rs))+ => Storable (Rec f (r ': rs)) where sizeOf _ = sizeOf (undefined :: f r) + sizeOf (undefined :: Rec f rs) {-# INLINE sizeOf #-} alignment _ = alignment (undefined :: f r)
Data/Vinyl/Derived.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -21,18 +20,13 @@ 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 Data.Vinyl.TypeLevel (Fst, Snd, RIndex) 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 @@ -47,12 +41,6 @@ -- 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- -- | Get the data payload of an 'ElField'. getField :: ElField '(s,t) -> t getField (Field x) = x@@ -82,37 +70,65 @@ -- | Get a named field from a record. rgetf- :: forall l f v record us. HasField record l us v+ :: forall l f v record us.+ (HasField record l us us v v, RecElemFCtx record f) => Label l -> record f us -> f (l ::: v)-rgetf _ = rget (Proxy :: Proxy (l ::: v))+rgetf _ = rget @(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+ :: (HasField record l us us v v, RecElemFCtx record ElField)+ => Label l -> record ElField us -> v rvalf x = getField . rgetf x --- | Set a named field. @rputf #foo 23@ sets the field named @#foo@ to+-- | 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))+rputf' :: forall l v v' record us us'.+ (HasField record l us us' v v', KnownSymbol l, RecElemFCtx record ElField)+ => Label l -> v' -> record ElField us -> record ElField us'+rputf' _ = rput' @(l:::v) . (Field :: v' -> ElField '(l,v')) +-- | Set a named field without changing its type. @rputf #foo 23@ sets+-- the field named @#foo@ to @23@.+rputf :: forall l v record us.+ (HasField record l us us v v, KnownSymbol l, RecElemFCtx record ElField)+ => Label l -> v -> record ElField us -> record ElField us+rputf _ = rput @(l:::v) . Field+ -- | A lens into a 'Rec' identified by a 'Label'.-rlensf' :: forall l v record g f us. (Functor g, HasField record l us v)+rlensfL' :: forall l v v' record g f us us'.+ (Functor g, HasField record l us us' v v', RecElemFCtx record f)+ => Label l+ -> (f (l ::: v) -> g (f (l ::: v')))+ -> record f us+ -> g (record f us')+rlensfL' _ f = rlens' @(l ::: v) f++-- | A type-preserving lens into a 'Rec' identified by a 'Label'.+rlensfL :: forall l v record g f us.+ (Functor g, HasField record l us us v v, RecElemFCtx record f) => Label l -> (f (l ::: v) -> g (f (l ::: v))) -> record f us -> g (record f us)-rlensf' _ f = rlens (Proxy :: Proxy (l ::: v)) f+rlensfL _ f = rlens' @(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)+rlensf' :: forall l v v' record g us us'.+ (Functor g, HasField record l us us' v v', RecElemFCtx record ElField)+ => Label l -> (v -> g v') -> record ElField us -> g (record ElField us')+rlensf' _ f = rlens' @(l ::: v) (rfield f) +-- | A type-preserving lens into the payload value of a 'Rec' field+-- identified by a 'Label'.+rlensf :: forall l v record g us.+ (Functor g, HasField record l us us v v, RecElemFCtx record ElField)+ => Label l -> (v -> g v) -> record ElField us -> g (record ElField us)+rlensf _ f = rlens @(l ::: v) (rfield f)+ -- | Shorthand for a 'FieldRec' with a single field.-(=:=) :: KnownSymbol s => proxy '(s,a) -> a -> FieldRec '[ '(s,a) ]+(=:=) :: KnownSymbol s => Label (s :: Symbol) -> a -> FieldRec '[ '(s,a) ] (=:=) _ x = Field x :& RNil -- | A proxy for field types.@@ -123,13 +139,6 @@ instance KnownSymbol s => Show (SField '(s,t)) where show _ = "SField "++symbolVal (Proxy::Proxy s) -instance forall s t. (KnownSymbol s, Storable t)- => Storable (ElField '(s,t)) where- sizeOf _ = sizeOf (undefined::t)- 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@@ -139,8 +148,8 @@ -- | 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)+type HasField record l fs fs' v v' =+ (RecElem record (l ::: v) (l ::: v') fs fs' (RIndex (l ::: v) fs), FieldType l fs ~ v, FieldType l fs' ~ v') -- | Proxy for label type data Label (a :: Symbol) = Label@@ -160,18 +169,18 @@ -- | Shorthand for working with records of fields as in 'rmapf' and -- 'rpuref'.-type AllFields fs = (AllConstrained KnownField fs, RecApplicative fs)+type AllFields fs = (RPureConstrained KnownField fs, RecApplicative fs, RApply 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) <<*>>)+rmapf f = (rpureConstrained @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+rpuref f = rpureConstrained @KnownField f -- | Operator synonym for 'rmapf'. (<<$$>>)
+ Data/Vinyl/FromTuple.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Concise vinyl record construction from tuples up to size 8. An+-- 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.Vinyl.Core (Rec(..))+import Data.Vinyl.Functor (ElField)+import Data.Vinyl.XRec (XRec, pattern (::&), pattern XRNil, IsoXRec(..), HKD)+import GHC.TypeLits (TypeError, ErrorMessage(Text))++-- | Convert a tuple of types formed by the application of a common+-- 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+ 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])+ TupleToRecArgs f (f a, f b, f c, f d, f e, f z) = '(f, [a,b,c,d,e,z])+ TupleToRecArgs f (f a, f b, f c, f d, f e) = '(f, [a,b,c,d,e])+ TupleToRecArgs f (f a, f b, f c, f d) = '(f, [a,b,c,d])+ TupleToRecArgs f (f a, f b, f c) = '(f, [a,b,c])+ TupleToRecArgs f (f a, f b) = '(f, [a,b])++-- | Apply the 'Rec' type constructor to a type-level tuple of its+-- arguments.+type family UncurriedRec (t :: (u -> *, [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+ UncurriedXRec '(f, ts) = XRec f ts++-- | Convert between an 'XRec' and an isomorphic tuple.+class TupleXRec (f :: u -> *) (t :: [u]) where+ -- | Convert an 'XRec' to a tuple. Useful for pattern matching on an+ -- entire record.+ xrecTuple :: XRec f t -> ListToHKDTuple f t+ -- | Build an 'XRec' from a tuple.+ xrecX :: ListToHKDTuple f t -> XRec f t++instance TupleXRec f '[a,b] where+ xrecTuple (a ::& b ::& XRNil) = (a, b)+ xrecX (a, b) = a ::& b ::& XRNil++instance TupleXRec f '[a,b,c] where+ xrecTuple (a ::& b ::& c ::& XRNil) = (a, b, c)+ xrecX (a, b, c) = a ::& b ::& c ::& XRNil++instance TupleXRec f '[a,b,c,d] where+ xrecTuple (a ::& b ::& c ::& d ::& XRNil) = (a, b, c, d)+ xrecX (a, b, c, d) = a ::& b ::& c ::& d ::& XRNil++instance TupleXRec f '[a,b,c,d,e] where+ xrecTuple (a ::& b ::& c ::& d ::& e ::& XRNil) =+ (a, b, c, d, e)+ xrecX (a, b, c, d, e) = a ::& b ::& c ::& d ::& e ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z] where+ xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& XRNil) =+ (a, b, c, d, e, z)+ xrecX (a, b, c, d, e, z) = a ::& b ::& c ::& d ::& e ::& z ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z,g] where+ xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil) =+ (a, b, c, d, e, z, g)+ xrecX (a, b, c, d, e, z, g) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z,g,h] where+ xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil) =+ (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+ ListToHKDTuple f '[a,b] = (HKD f a, HKD f b)+ ListToHKDTuple f '[a,b,c] = (HKD f a, HKD f b, HKD f c)+ ListToHKDTuple f '[a,b,c,d] = (HKD f a, HKD f b, HKD f c, HKD f d)+ ListToHKDTuple f '[a,b,c,d,e] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e)+ ListToHKDTuple f '[a,b,c,d,e,z] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z)+ ListToHKDTuple f '[a,b,c,d,e,z,g] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g)+ ListToHKDTuple f '[a,b,c,d,e,z,g,h] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g, HKD f h)+ ListToHKDTuple f x = TypeError ('Text "Tuples are only supported up to size 8")++-- | Convert a 'Rec' to a tuple going through 'HKD' to reduce+-- syntactic noise. Useful for pattern matching on an entire 'Rec'.+ruple :: (IsoXRec f ts, TupleXRec f ts)+ => Rec f ts -> ListToHKDTuple f ts+ruple = xrecTuple . toXRec++-- | Build a 'Rec' from a tuple passing through 'XRec'. This admits+-- the most concise syntax for building a 'Rec'. For example, @xrec+-- ("joe", 23) :: Rec Identity '[String, Int]@.+xrec :: (IsoXRec f t, TupleXRec f t) => ListToHKDTuple f t -> Rec f t+xrec = fromXRec . xrecX++-- | Build a 'Rec' from a tuple. An example would be building a value+-- of type @Rec f '[a,b]@ from a tuple of values with type @'(f a, f+-- b)@.+class TupleRec f t where+ record :: t -> UncurriedRec (TupleToRecArgs f t)++instance TupleRec f (f a, f b) where+ record (a,b) = a :& b :& RNil++instance TupleRec f (f a, f b, f c) where+ record (a,b,c) = a :& b :& c :& RNil++instance TupleRec f (f a, f b, f c, f d) where+ record (a,b,c,d) = a :& b :& c :& d :& RNil++instance TupleRec f (f a, f b, f c, f d, f e) where+ record (a,b,c,d,e) = a :& b :& c :& d :& e :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z) where+ record (a,b,c,d,e,z) = a :& b :& c :& d :& e :& z :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z, f g) where+ record (a,b,c,d,e,z,g) = a :& b :& c :& d :& e :& z :& g :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z, f g, f h) where+ record (a,b,c,d,e,z,g,h) = a :& b :& c :& d :& e :& z :& g :& h :& RNil++-- | Build a 'FieldRec' from a tuple of 'ElField' values.+fieldRec :: TupleRec ElField t => t -> UncurriedRec (TupleToRecArgs ElField t)+fieldRec = record @ElField
Data/Vinyl/Functor.hs view
@@ -1,37 +1,42 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -module Data.Vinyl.Functor +module Data.Vinyl.Functor ( -- * Introduction -- $introduction -- * Data Types Identity(..) , Thunk(..) , Lift(..)+ , ElField(..) , Compose(..) , (:.) , Const(..) -- * Discussion- + -- ** Example -- $example- + -- ** Ecosystem -- $ecosystem ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (Const)-import Data.Foldable-import Data.Traversable-#endif+import Data.Proxy+import Data.Semigroup+import Foreign.Ptr (castPtr) import Foreign.Storable+import GHC.TypeLits+import GHC.Types (Type) {- $introduction This module provides functors and functor compositions@@ -79,9 +84,70 @@ , Storable ) +-- | 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)++deriving instance Eq t => Eq (ElField '(s,t))+deriving instance Ord t => Ord (ElField '(s,t))++instance (Num t, KnownSymbol s) => Num (ElField '(s,t)) where+ Field x + Field y = Field (x+y)+ Field x * Field y = Field (x*y)+ abs (Field x) = Field (abs x)+ signum (Field x) = Field (signum x)+ fromInteger = Field . fromInteger+ negate (Field x) = Field (negate x)++instance Semigroup t => Semigroup (ElField '(s,t)) where+ Field x <> Field y = Field (x <> y)++instance (KnownSymbol s, Monoid t) => Monoid (ElField '(s,t)) where+ mempty = Field mempty+ mappend (Field x) (Field y) = Field (mappend x y)++instance (Real t, KnownSymbol s) => Real (ElField '(s,t)) where+ toRational (Field x) = toRational x++instance (Fractional t, KnownSymbol s) => Fractional (ElField '(s,t)) where+ fromRational = Field . fromRational+ Field x / Field y = Field (x / y)++instance (Floating t, KnownSymbol s) => Floating (ElField '(s,t)) where+ pi = Field pi+ exp (Field x) = Field (exp x)+ log (Field x) = Field (log x)+ sin (Field x) = Field (sin x)+ cos (Field x) = Field (cos x)+ asin (Field x) = Field (asin x)+ acos (Field x) = Field (acos x)+ atan (Field x) = Field (atan x)+ sinh (Field x) = Field (sinh x)+ cosh (Field x) = Field (cosh x)+ asinh (Field x) = Field (asinh x)+ acosh (Field x) = Field (acosh x)+ atanh (Field x) = Field (atanh x)++instance (RealFrac t, KnownSymbol s) => RealFrac (ElField '(s,t)) where+ properFraction (Field x) = fmap Field (properFraction x)++instance (Show t, KnownSymbol s) => Show (ElField '(s,t)) where+ show (Field x) = symbolVal (Proxy::Proxy s) ++" :-> "++show x++instance forall s t. (KnownSymbol s, Storable t)+ => Storable (ElField '(s,t)) where+ sizeOf _ = sizeOf (undefined::t)+ alignment _ = alignment (undefined::t)+ peek ptr = Field `fmap` peek (castPtr ptr)+ poke ptr (Field x) = poke (castPtr ptr) x instance Show a => Show (Const a b) where show (Const x) = "(Const "++show x ++")" +instance Eq a => Eq (Const a b) where+ Const x == Const y = x == y+ instance (Functor f, Functor g) => Functor (Compose f g) where fmap f (Compose x) = Compose (fmap (fmap f) x) @@ -95,6 +161,9 @@ pure x = Compose (pure (pure x)) Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +instance Show (f (g a)) => Show (Compose f g a) where+ show (Compose x) = show x+ instance Applicative Identity where pure = Identity Identity f <*> Identity x = Identity (f x)@@ -159,7 +228,7 @@ >>> r2 Nothing - If the fields only exist once an environment is provided, you can + If the fields only exist once an environment is provided, you can build the record as follows: >>> :{@@ -194,7 +263,7 @@ by "transformers". When GHC 7.10 was released, it was moved into "base-4.8". The "Identity" data type provided by that module is well recognized across the haskell ecosystem- and has typeclass instances for lots of common typeclasses. + and has typeclass instances for lots of common typeclasses. The significant difference between it and the copy of it provided here is that this one has a different 'Show' instance. This is illustrated below:@@ -215,10 +284,10 @@ "Identity". The story with "Compose" and "Const" is much more simple.- These also exist in "transformers", although "Const" - is named "Constant" there. Prior to the release of - "transformers-0.5", they were not polykinded, making - them unusable for certain universes. However, in + These also exist in "transformers", although "Const"+ is named "Constant" there. Prior to the release of+ "transformers-0.5", they were not polykinded, making+ them unusable for certain universes. However, in "transformers-0.5" and forward, they have been made polykinded. This means that they are just as usable with 'Rec' as the vinyl equivalents but with many more typeclass
Data/Vinyl/Lens.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,8 +14,10 @@ -- | Lenses into record fields. module Data.Vinyl.Lens ( RecElem(..)+ , rget, rput, rput', rlens, rlens' , RElem , RecSubset(..)+ , rsubset, rcast, rreplace , RSubset , REquivalent , type (∈)@@ -21,46 +27,52 @@ , type (:~:) ) where +import Data.Kind (Constraint) import Data.Vinyl.Core import Data.Vinyl.Functor import Data.Vinyl.TypeLevel-import Data.Typeable (Proxy(..)) --- | The presence of a field in a record is witnessed by a lens into its value.--- 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 => RecElem record (r :: k) (rs :: [k]) (i :: Nat) where+-- | The presence of a field in a record is witnessed by a lens into+-- its value. The fifth parameter to 'RecElem', @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 => RecElem record (r :: k) (r' :: k)+ (rs :: [k]) (rs' :: [k])+ (i :: Nat) | r r' rs i -> rs' where+ -- | An opportunity for instances to generate constraints based on+ -- the functor parameter of records passed to class methods.+ type RecElemFCtx record (f :: k -> *) :: Constraint+ type RecElemFCtx record f = () -- | 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 -- particular field being viewed. These lenses are compatible with the @lens@ -- library. Morally: --- -- > rlens :: sing r => Lens' (Rec f rs) (f r)- rlens- :: Functor g- => sing r- -> (f r -> g (f r))+ -- > rlensC :: Lens' (Rec f rs) (Rec f rs') (f r) (f r')+ rlensC+ :: (Functor g, RecElemFCtx record f)+ => (f r -> g (f r')) -> record f rs- -> g (record f rs)+ -> g (record f rs') -- | For Vinyl users who are not using the @lens@ package, we provide a getter.- rget- :: sing r- -> record f rs+ rgetC+ :: (RecElemFCtx record f, r ~ r')+ => record f rs -> f r -- | For Vinyl users who are not using the @lens@ package, we also provide a -- setter. In general, it will be unambiguous what field is being written to, -- and so we do not take a proxy argument here.- rput- :: f r- -> record f rs+ rputC+ :: RecElemFCtx record f+ => f r' -> record f rs+ -> record f rs' -- | 'RecElem' for classic vinyl 'Rec' types.-type RElem = RecElem Rec+type RElem x rs = RecElem Rec x x rs rs -- This is an internal convenience stolen from the @lens@ library. lens@@ -73,64 +85,129 @@ lens sa sbt afb s = fmap (sbt s) $ afb (sa s) {-# INLINE lens #-} -instance RecElem Rec r (r ': rs) 'Z where- rlens _ f (x :& xs) = fmap (:& xs) (f x)- {-# INLINE rlens #-}- rget k = getConst . rlens k Const- {-# INLINE rget #-}- rput y = getIdentity . rlens Proxy (\_ -> Identity y)- {-# INLINE rput #-}+instance RecElem Rec r r' (r ': rs) (r' ': rs) 'Z where+ rlensC f (x :& xs) = fmap (:& xs) (f x)+ {-# INLINE rlensC #-}+ rgetC = getConst . rlensC Const+ {-# INLINE rgetC #-}+ rputC y = getIdentity . rlensC @_ @r (\_ -> Identity y)+ {-# INLINE rputC #-} -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- {-# INLINE rget #-}- rput y = getIdentity . rlens Proxy (\_ -> Identity y)- {-# INLINE rput #-}+instance (RIndex r (s ': rs) ~ 'S i, RecElem Rec r r' rs rs' i)+ => RecElem Rec r r' (s ': rs) (s ': rs') ('S i) where+ rlensC f (x :& xs) = fmap (x :&) (rlensC f xs)+ {-# INLINE rlensC #-}+ rgetC = getConst . rlensC @_ @r @r' Const+ {-# INLINE rgetC #-}+ rputC y = getIdentity . rlensC @_ @r (\_ -> Identity y)+ {-# INLINE rputC #-} +-- | The 'rgetC' field getter with the type arguments re-ordered for+-- more convenient usage with @TypeApplications@.+rget :: forall r rs f record.+ (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)+ => record f rs -> f r+rget = rgetC++-- | The type-changing field setter 'rputC' with the type arguments+-- re-ordered for more convenient usage with @TypeApplications@.+rput' :: forall r r' rs rs' record f. (RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f)+ => f r' -> record f rs -> record f rs'+rput' = rputC @_ @r @r'++-- | Type-preserving field setter. This type is simpler to work with+-- than that of 'rput''.+rput :: forall r rs record f. (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)+ => f r -> record f rs -> record f rs+rput = rput' @r++-- | Type-changing field lens 'rlensC' with the type arguments+-- re-ordered for more convenient usage with @TypeApplications@.+rlens' :: forall r r' record rs rs' f g.+ (RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f, Functor g)+ => (f r -> g (f r')) -> record f rs -> g (record f rs')+rlens' = rlensC++-- | Type-preserving field lens. This type is simpler to work with+-- than that of 'rlens''.+rlens :: forall r record rs f g.+ (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f, Functor g)+ => (f r -> g (f r)) -> record f rs -> g (record f rs)+rlens = rlensC+ -- | If one field set is a subset another, then a lens of from the latter's -- 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 => RecSubset record (rs :: [k]) (ss :: [k]) is where+ -- | An opportunity for instances to generate constraints based on+ -- the functor parameter of records passed to class methods.+ type RecSubsetFCtx record (f :: k -> *) :: Constraint+ type RecSubsetFCtx record f = () -- | 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+ rsubsetC+ :: (Functor g, RecSubsetFCtx record f) => (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- :: record f ss+ rcastC+ :: RecSubsetFCtx record f+ => record f ss -> record f rs- rcast = getConst . rsubset Const- {-# INLINE rcast #-}+ rcastC = getConst . rsubsetC Const+ {-# INLINE rcastC #-} -- | The setter of the 'rsubset' lens is 'rreplace', which allows a slice of -- a record to be replaced with different values.- rreplace- :: record f rs+ rreplaceC+ :: RecSubsetFCtx record f+ => record f rs -> record f ss -> record f ss- rreplace rs = getIdentity . rsubset (\_ -> Identity rs)- {-# INLINE rreplace #-}+ rreplaceC rs = getIdentity . rsubsetC (\_ -> Identity rs)+ {-# INLINE rreplaceC #-} +-- | A lens into a slice of the larger record. This is 'rsubsetC' with+-- the type arguments reordered for more convenient usage with+-- @TypeApplications@.+rsubset :: forall rs ss f g record is.+ (RecSubset record (rs :: [k]) (ss :: [k]) is,+ Functor g, RecSubsetFCtx record f)+ => (record f rs -> g (record f rs)) -> record f ss -> g (record f ss)+rsubset = rsubsetC++-- | Takes a larger record to a smaller one by forgetting fields. This+-- is 'rcastC' with the type arguments reordered for more convenient+-- usage with @TypeApplications@.+rcast :: forall rs ss f record is.+ (RecSubset record rs ss is, RecSubsetFCtx record f)+ => record f ss -> record f rs+rcast = rcastC++-- | Allows a slice of a record to be replaced with different+-- values. This is 'rreplaceC' with the type arguments reordered for+-- more convenient usage with @TypeApplications@.+rreplace :: forall rs ss f record is.+ (RecSubset record rs ss is, RecSubsetFCtx record f)+ => record f rs -> record f ss -> record f ss+rreplace = rreplaceC+ type RSubset = RecSubset Rec instance RecSubset Rec '[] ss '[] where- rsubset = lens (const RNil) const+ rsubsetC = lens (const RNil) const 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+ rsubsetC = lens (\ss -> rget ss :& rcastC ss) set where set :: Rec f ss -> Rec f (r ': rs) -> Rec f ss- set ss (r :& rs) = rput r $ rreplace rs ss+ set ss (r :& rs) = rput r $ rreplaceC rs ss -- | Two record types are equivalent when they are subtypes of each other. type REquivalent rs ss is js = (RSubset rs ss is, RSubset ss rs js)
+ Data/Vinyl/SRec.hs view
@@ -0,0 +1,398 @@+-- | 'Storable' records offer an efficient flat, packed representation+-- in memory. In particular, field access is constant time (i.e. it+-- doesn't depend on where in the record the field is) and as fast as+-- possible, but updating fields may not be as efficient. The+-- requirement is that all fields of a record have 'Storable'+-- instances.+--+-- The implementation leaks into the usual vinyl lens API: the+-- requirement of 'Storable' instances necessitates specialization on+-- the functor argument of the record so that GHC can find all+-- required instances at compile time (this is required for+-- constant-time field access). What we do is allow ourselves to write+-- instances of the 'RecElem' and 'RecSubset' classes (that provide+-- the main vinyl lens API) that are restricted to particular choices+-- of the record functor. This is why the 'SRec2' type that implements+-- records here takes two functor arguments: they will usually be the+-- same; we fix one when writing instances and write instance contexts+-- that reference that type, and then require that the methods+-- (e.g. 'rget') are called on records whose functor argument is equal+-- to the one we picked. For usability, we provide an 'SRec' type+-- whose lens API is fixed to 'ElField' as the functor. Other+-- specializations are possible, and the work of those instances can+-- always be passed along to the 'SRec2' functions.+--+-- Note that the lens field accessors for 'SRec' do not support+-- changing the types of the fields as they do for 'Rec' and+-- 'ARec'.+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- We get warnings about incomplete patterns on various class+-- instances.+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+module Data.Vinyl.SRec (+ -- * Main record lens API+ SRec(..), toSRec, fromSRec+ -- * Lens API specialized to 'SRec2'+ , sget, sput, slens+ , srecGetSubset, srecSetSubset+ -- * Internals+ , toSRec2, fromSRec2, SRec2(..)+ , FieldOffset, FieldOffsetAux(..), StorableAt(..)+ , peekField, pokeField+) where+import Data.Coerce (coerce)+import Data.Vinyl.Core+import Data.Vinyl.Functor (Lift(..), Compose(..), type (:.), ElField)+import Data.Vinyl.Lens (RecElem(..), RecSubset(..), type (⊆), RecElemFCtx)+import Data.Vinyl.TypeLevel (RImage, RIndex, Nat(..), RecAll, AllConstrained)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..))+import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)++import GHC.IO (IO(IO))+import GHC.Base (realWorld#)+import GHC.TypeLits (Symbol)++import GHC.Prim (MutableByteArray#, newAlignedPinnedByteArray#, byteArrayContents#)+import GHC.Prim (unsafeCoerce#, touch#, RealWorld)+import GHC.Ptr (Ptr(..))+import GHC.Types (Int(..))++-- * Byte array code adapted from the `memory` package.++data Bytes = Bytes (MutableByteArray# RealWorld)++newBytes :: Int -> IO Bytes+newBytes (I# n) = IO $ \s ->+ case newAlignedPinnedByteArray# n 8# s of+ (# s', mbarr #) -> (# s', Bytes mbarr #)++touchBytes :: Bytes -> IO ()+touchBytes (Bytes mbarr) = IO $ \s -> case touch# mbarr s of s' -> (# s', () #)+{-# INLINE touchBytes #-}++withBytesPtr :: Bytes -> (Ptr a -> IO r) -> IO r+withBytesPtr b@(Bytes mbarr) f = do+ f (Ptr (byteArrayContents# (unsafeCoerce# mbarr))) <* touchBytes b+{-# INLINE withBytesPtr #-}++-- * Pun ForeignPtr names to ease refactoring++newtype ForeignPtr (a :: k) = ForeignPtr Bytes++withForeignPtr :: ForeignPtr a -> (Ptr b -> IO r) -> IO r+withForeignPtr (ForeignPtr b) = withBytesPtr b+{-# INLINE withForeignPtr #-}++mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes = fmap ForeignPtr . newBytes+{-# INLINE mallocForeignPtrBytes #-}++-- * The SRec types++-- | A 'Storable'-backed 'Rec'. Each field of such a value has+-- statically known size, allowing for a very efficient representation+-- and very fast field access. The @2@ suffix is due to apparently+-- taking /two/ functor arguments, but the first type parameter is+-- phantom and exists so that we can write multiple instances of+-- 'RecElem' and 'RecSubset' for different functors. The first functor+-- argument will typically be identical to the second argument. We+-- currently provide instances for the 'ElField' functor; if you wish+-- to use it at a different type, consider using 'sget', 'sput', and+-- 'slens' which work with any functor given that the necessary+-- 'Storable' instances exist.+newtype SRec2 (g :: k -> *) (f :: k -> *) (ts :: [k]) =+ SRec2 (ForeignPtr (Rec f ts))++-- | A simpler type for 'SRec2' whose 'RecElem' and 'RecSubset'+-- instances are specialized to the 'ElField' functor.+newtype SRec f ts = SRecNT { getSRecNT :: SRec2 f f ts }++-- | Create an 'SRec2' from a 'Rec'.+toSRec2 :: forall f ts. Storable (Rec f ts) => Rec f ts -> SRec2 f f ts+toSRec2 x = unsafePerformIO $ do+ ptr <- mallocForeignPtrBytes (sizeOf (undefined :: Rec f ts))+ SRec2 ptr <$ (withForeignPtr ptr (flip poke x))+{-# NOINLINE toSRec2 #-}++-- | Create an 'SRec' from a 'Rec'. This should offer very fast field+-- access, but note that its lens API (via 'RecElem' and 'RecSubset')+-- is restricted to the 'ElField' functor.+toSRec :: Storable (Rec f ts) => Rec f ts -> SRec f ts+toSRec = SRecNT . toSRec2+{-# INLINE toSRec #-}++-- | Create a 'Rec' from an 'SRec2'.+fromSRec2 :: Storable (Rec f ts) => SRec2 g f ts -> Rec f ts+fromSRec2 (SRec2 ptr) = inlinePerformIO (withForeignPtr ptr peek)+{-# INLINE fromSRec2 #-}++-- | Create a 'Rec' from an 'SRec'.+fromSRec :: Storable (Rec f ts) => SRec f ts -> Rec f ts+fromSRec (SRecNT s) = fromSRec2 s+{-# INLINE fromSRec #-}++-- | Just like unsafePerformIO, but we inline it. Big performance gains as+-- it exposes lots of things to further inlining. /Very unsafe/. In+-- particular, you should do no memory allocation inside an+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.+--+-- Copied from the @text@ package+{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r++-- | Capture a 'Storable' dictionary along with a byte offset from+-- some origin address.+data StorableAt f a where+ StorableAt :: Storable (f a) => {-# UNPACK #-} !Int -> StorableAt f a++-- | The ability to work with a particular field of a 'Rec' stored at+-- a 'Ptr'.+class (RIndex t ts ~ i, RecAll f ts Storable) => FieldOffsetAux f ts t i where+ -- | Get the byte offset of a field from the given origin and the+ -- 'Storable' dictionary needed to work with that field.+ fieldOffset :: Int -> StorableAt f t++-- | A more concise constraint equivalent to 'FieldOffsetAux'.+class FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where+instance FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where++instance (RecAll f (t ': ts) Storable) => FieldOffsetAux f (t ': ts) t 'Z where+ fieldOffset !n = StorableAt n+ {-# INLINE fieldOffset #-}++instance (RIndex t (s ': ts) ~ 'S i,+ FieldOffsetAux f ts t i,+ RecAll f (s ': ts) Storable)+ => FieldOffsetAux f (s ': ts) t ('S i) where+ fieldOffset !n = fieldOffset @f @ts @t @i (n + sizeOf (undefined :: f s))+ {-# INLINE fieldOffset #-}++-- | Set a field in a record stored at a 'ForeignPtr'.+pokeField :: forall f t ts. FieldOffset f ts t+ => ForeignPtr (Rec f ts) -> f t -> IO ()+pokeField fptr x = case fieldOffset @f @ts @t 0 of+ StorableAt i -> withForeignPtr fptr $ \ptr ->+ pokeByteOff ptr i x+{-# INLINE pokeField #-}++-- | Get a field in a record stored at a 'ForeignPtr'.+peekField :: forall f t ts. FieldOffset f ts t+ => ForeignPtr (Rec f ts) -> IO (f t)+peekField fptr = case fieldOffset @f @ts @t 0 of+ StorableAt i -> withForeignPtr fptr $ \ptr ->+ peekByteOff ptr i+{-# INLINE peekField #-}++-- | Get a field from an 'SRec'.+sget :: forall f t ts. FieldOffset f ts t+ => SRec2 f f ts -> f t+sget (SRec2 ptr) = inlinePerformIO (peekField ptr)+{-# INLINE sget #-}++mallocAndCopy :: ForeignPtr a -> Int -> IO (ForeignPtr a)+mallocAndCopy src n = do+ dst <- mallocForeignPtrBytes n+ withForeignPtr src $ \src' ->+ withForeignPtr dst $ \dst' ->+ dst <$ copyBytes dst' src' n++-- | Set a field.+sput :: forall (f :: u -> *) (t :: u) (ts :: [u]).+ ( FieldOffset f ts t+ , Storable (Rec f ts)+ , AllConstrained (FieldOffset f ts) ts)+ => f t -> SRec2 f f ts -> SRec2 f f ts+sput !x (SRec2 src) = unsafePerformIO $ do+ let !n = sizeOf (undefined :: Rec f ts)+ dst <- mallocAndCopy src n+ SRec2 dst <$ pokeField dst x+{-# INLINE [1] sput #-}++pokeFieldUnsafe :: forall f t ts. FieldOffset f ts t+ => f t -> SRec2 f f ts -> SRec2 f f ts+pokeFieldUnsafe x y@(SRec2 ptr) = unsafeDupablePerformIO (y <$ pokeField ptr x)+{-# INLINE [1] pokeFieldUnsafe #-}++{-# RULES+"sput" forall x y z. sput x (sput y z) = pokeFieldUnsafe x (sput y z)+"sputUnsafe" forall x y z. sput x (pokeFieldUnsafe y z) = pokeFieldUnsafe x (pokeFieldUnsafe y z)+ #-}++-- | A lens for a field of an 'SRec2'.+slens :: ( Functor g+ , FieldOffset f ts t+ , Storable (Rec f ts)+ , AllConstrained (FieldOffset f ts) ts)+ => (f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)+slens f sr = fmap (flip sput sr) (f (sget sr))+{-# INLINE slens #-}++-- Note: we need the functor to appear in the instance head so that we+-- can demand the needed 'Storable' instances. We do this by giving+-- 'SRec2' a phantom tag that duplicates the "real" functor parameter,+-- and define a constraint that the real argument is in fact+-- 'ElField'. This lets us write instances for different applications+-- of @SRec2@ (e.g. instance for @SRec2 Foo@ for records of type+-- @SRec2 Foo Foo ts@, and an instance for @SRec2 Bar@ for records of+-- type @SRec2 Bar Bar ts@).++-- | Field accessors for 'SRec2' specialized to 'ElField' as the+-- functor.+instance ( i ~ RIndex t ts+ , FieldOffset ElField ts t+ , Storable (Rec ElField ts)+ , AllConstrained (FieldOffset ElField ts) ts)+ => RecElem (SRec2 ElField) t t ts ts i where+ type RecElemFCtx (SRec2 ElField) f = f ~ ElField+ rlensC = slens+ {-# INLINE rlensC #-}+ rgetC = sget+ {-# INLINE rgetC #-}+ rputC = sput+ {-# INLINE rputC #-}+++coerceSRec1to2 :: SRec f ts -> SRec2 f f ts+coerceSRec1to2 = coerce++coerceSRec2to1 :: SRec2 f f ts -> SRec f ts+coerceSRec2to1 = coerce++instance ( i ~ RIndex (t :: (Symbol,*)) (ts :: [(Symbol,*)])+ , FieldOffset ElField ts t+ , Storable (Rec ElField ts)+ , AllConstrained (FieldOffset ElField ts) ts)+ => RecElem SRec (t :: (Symbol,*)) t (ts :: [(Symbol,*)]) ts i where+ type RecElemFCtx SRec f = f ~ ElField+ rlensC f = fmap coerceSRec2to1 . slens f . coerceSRec1to2+ {-# INLINE rlensC #-}+ rgetC = sget . coerceSRec1to2+ {-# INLINE rgetC #-}+ rputC x = coerceSRec2to1 . sput x . coerceSRec1to2+ {-# INLINE rputC #-}++-- | Get a subset of a record's fields.+srecGetSubset :: forall (ss :: [u]) (rs :: [u]) (f :: u -> *).+ (RPureConstrained (FieldOffset f ss) rs,+ RPureConstrained (FieldOffset f rs) rs,+ RFoldMap rs, RMap rs, RApply rs,+ Storable (Rec f rs))+ => SRec2 f f ss -> SRec2 f f rs+srecGetSubset (SRec2 ptr) = unsafeDupablePerformIO $ do+ dst <- mallocForeignPtrBytes (sizeOf (undefined :: Rec f rs))+ SRec2 dst <$ (withForeignPtr dst $ \dst' ->+ rfoldMap @rs unTagIO (peekSmallPokeBig dst'))+ where peekers :: Rec (IO :. f) rs+ peekers = rpureConstrained @(FieldOffset f ss) mkPeeker+ {-# INLINE peekers #-}+ mkPeeker :: FieldOffset f ss t => (IO :. f) t+ mkPeeker = Compose (peekField ptr)+ {-# INLINE mkPeeker #-}+ pokers :: Ptr (Rec f rs) -> Rec (Poker f) rs+ pokers dst = rpureConstrained @(FieldOffset f rs) (mkPoker dst)+ {-# INLINE pokers #-}+ mkPoker :: forall t. Ptr (Rec f rs) -> FieldOffset f rs t => Poker f t+ mkPoker dst = case fieldOffset @f @rs @t 0 of+ StorableAt i -> Lift (TaggedIO . pokeByteOff dst i)+ {-# INLINE mkPoker #-}+ peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t+ peekNPoke (Compose m) (Lift f) = TaggedIO (m >>= unTagIO . f)+ {-# INLINE peekNPoke #-}+ peekSmallPokeBig :: Ptr (Rec f rs) -> Rec TaggedIO rs+ peekSmallPokeBig dst' = Lift . peekNPoke <<$>> peekers <<*>> pokers dst'+{-# INLINE srecGetSubset #-}++-- | Phantom tagged 'IO ()' value. Used to work with vinyl's 'Lift'+-- that wants @forall a. f a -> g a@.+newtype TaggedIO a = TaggedIO { unTagIO :: IO () }++-- | A dressed up function of type @f a -> IO ()@+type Poker f = Lift (->) f TaggedIO++-- | Set a subset of a record's fields.+srecSetSubset :: forall (f :: u -> *) (ss :: [u]) (rs :: [u]).+ (rs ⊆ ss,+ RPureConstrained (FieldOffset f ss) rs,+ RPureConstrained (FieldOffset f rs) rs,+ RFoldMap rs, RMap rs, RApply rs,+ Storable (Rec f ss))+ => SRec2 f f ss -> SRec2 f f rs -> SRec2 f f ss+srecSetSubset (SRec2 srcBig) (SRec2 srcSmall) = unsafeDupablePerformIO $ do+ let n = sizeOf (undefined :: Rec f ss)+ dst <- mallocForeignPtrBytes n+ withForeignPtr srcBig $ \srcBig' ->+ withForeignPtr dst $ \dst' ->+ copyBytes dst' srcBig' n+ SRec2 dst <$ (withForeignPtr dst $ \dst' ->+ rfoldMap @rs unTagIO+ (Lift . peekNPoke <<$>> peekers <<*>> pokers dst'))+ where peekers :: Rec (IO :. f) rs+ peekers = rpureConstrained @(FieldOffset f rs) mkPeeker+ {-# INLINE peekers #-}+ mkPeeker :: FieldOffset f rs t => (IO :. f) t+ mkPeeker = Compose (peekField srcSmall)++ pokers :: Ptr (Rec f ss) -> Rec (Poker f) rs+ pokers dst = rpureConstrained @(FieldOffset f ss) (mkPoker dst)+ {-# INLINE pokers #-}+ mkPoker :: forall t. FieldOffset f ss t => Ptr (Rec f ss) -> Poker f t+ mkPoker dst = case fieldOffset @f @ss @t 0 of+ StorableAt i -> Lift (TaggedIO . pokeByteOff dst i)+ {-# INLINE mkPoker #-}+ peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t+ peekNPoke (Compose m) (Lift f) = TaggedIO (m >>= unTagIO . f)+ {-# INLINE peekNPoke #-}+{-# INLINE srecSetSubset #-}++instance (is ~ RImage rs ss,+ RecSubset Rec rs ss is,+ Storable (Rec ElField rs),+ Storable (Rec ElField ss),+ RPureConstrained (FieldOffset ElField ss) rs,+ RPureConstrained (FieldOffset ElField rs) rs,+ RFoldMap rs, RMap rs, RApply rs)+ => RecSubset (SRec2 ElField) rs ss is where+ type RecSubsetFCtx (SRec2 ElField) f = f ~ ElField+ rsubsetC :: forall g. Functor g+ => (SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs))+ -> SRec2 ElField ElField ss+ -> g (SRec2 ElField ElField ss)+ rsubsetC f big@(SRec2 _) = fmap (srecSetSubset big) (f smallRec)+ where smallRec :: SRec2 ElField ElField rs+ smallRec = srecGetSubset big+ {-# INLINE smallRec #-}+ {-# INLINE rsubsetC #-}++instance (is ~ RImage rs ss,+ RecSubset Rec rs ss is,+ Storable (Rec ElField rs),+ Storable (Rec ElField ss),+ RPureConstrained (FieldOffset ElField ss) rs,+ RPureConstrained (FieldOffset ElField rs) rs,+ RFoldMap rs, RMap rs, RApply rs)+ => RecSubset SRec rs ss is where+ type RecSubsetFCtx SRec f = f ~ ElField+ rsubsetC f (SRecNT s) = SRecNT <$> rsubsetC (fmap getSRecNT . f . SRecNT) s+ {-# INLINE rsubsetC #-}
+ Data/Vinyl/Syntax.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP, FlexibleInstances, InstanceSigs,+ MultiParamTypeClasses, ScopedTypeVariables,+ TypeApplications, TypeFamilies, TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Concise vinyl record field lens syntax. This module exports an+-- orphan instance to make working with labels a bit more powerful. It+-- will conflict with other libraries that provide special syntax for+-- labels (i.e. placing a label in function application position, as+-- in @#age 23@, or using a label as a lens).+--+-- Example:+-- @fieldRec (#x =: True, #y =: 'b') :: FieldRec '[ '("x", Bool), '("y", Char) ]@+-- @fieldRec (#x =: True, #y =: 'b') & #x %~ not@+module Data.Vinyl.Syntax where+import Data.Vinyl.Derived (HasField, (:::), rfield)+import Data.Vinyl.Functor (ElField)+import Data.Vinyl.Lens (RecElemFCtx, rlens')+import GHC.OverloadedLabels (IsLabel(..))+-- import GHC.TypeLits (KnownSymbol)++-- | Concise record construction syntax. Example: @record (#name "Joe", #age 23)@.+-- instance forall s a b. (KnownSymbol s, b ~ ElField '(s,a))+-- => IsLabel s (a -> b) where+-- #if __GLASGOW_HASKELL__ < 802+-- fromLabel _ = Field @s @a+-- #else+-- fromLabel = Field @s @a+-- #endif++-- | Concise 'ElField' lenses. Example @myRec & #name %~ map+-- toUpper@.+--+-- Credit to Tikhon Jelvis who shared this technique on the+-- Haskell-Cafe mailing list on December 23, 2017.+instance forall s t t' ts ts' f record a' b'.+ (HasField record s ts ts' t t', Functor f, RecElemFCtx record ElField,+ a' ~ (t -> f t'), b' ~ (record ElField ts -> f (record ElField ts')))+ => IsLabel s (a' -> b') where+#if __GLASGOW_HASKELL__ < 802+ fromLabel _ = rlens' @(s ::: t) . rfield+#else+ fromLabel :: (t -> f t') -> (record ElField ts -> f (record ElField ts'))+ fromLabel = rlens' @(s ::: t) . rfield+#endif
Data/Vinyl/Tutorial/Overview.hs view
@@ -10,6 +10,7 @@ >>> :set -XDataKinds >>> :set -XPolyKinds+>>> :set -XTypeApplications >>> :set -XTypeOperators >>> :set -XTypeFamilies >>> :set -XFlexibleContexts@@ -120,20 +121,20 @@ >>> let tucker' = wakeUp tucker >>> let jon' = wakeUp jon ->>> tucker' ^. rlens SSleeping+>>> tucker' ^. rlens @Sleeping sleeping: False ->>> tucker ^. rlens SSleeping+>>> tucker ^. rlens @Sleeping sleeping: True ->>> jon' ^. rlens SSleeping+>>> jon' ^. rlens @Sleeping sleeping: False We can also access the entire lens for a field using the rLens function; since lenses are composable, it’s super easy to do deep update on a record: ->>> let masterSleeping = rlens SMaster . unAttr . rlens SSleeping+>>> let masterSleeping = rlens @Master . unAttr . rlens @Sleeping >>> let tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker' >>> tucker'' ^. masterSleeping@@ -210,8 +211,8 @@ validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person) validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge where- vName = validateName $ p ^. rlens SName . unAttr- vAge = validateAge $ p ^. rlens SAge . unAttr+ vName = validateName $ p ^. rlens @Name . unAttr+ vAge = validateAge $ p ^. rlens @Age . unAttr validateName str | all isAlpha str = Just str validateName _ = Nothing validateAge i | i >= 0 = Just i@@ -258,16 +259,16 @@ >>> let goodPersonResult = vperson <<*>> goodPerson >>> let badPersonResult = vperson <<*>> badPerson ->>> isJust . getCompose $ goodPersonResult ^. rlens SName+>>> isJust . getCompose $ goodPersonResult ^. rlens @Name True ->>> isJust . getCompose $ goodPersonResult ^. rlens SAge+>>> isJust . getCompose $ goodPersonResult ^. rlens @Age True ->>> isJust . getCompose $ badPersonResult ^. rlens SName+>>> isJust . getCompose $ badPersonResult ^. rlens @Name False ->>> isJust . getCompose $ badPersonResult ^. rlens SAge+>>> isJust . getCompose $ badPersonResult ^. rlens @Age True So now we have a partial record, and we can still do stuff with its contents.
Data/Vinyl/TypeLevel.hs view
@@ -82,7 +82,7 @@ -- | Constraint that all types in a type-level list satisfy a -- constraint.-type family AllConstrained c ts :: Constraint where+type family AllConstrained (c :: u -> Constraint) (ts :: [u]) :: Constraint where AllConstrained c '[] = () AllConstrained c (t ': ts) = (c t, AllConstrained c ts)
+ Data/Vinyl/XRec.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | A variant of 'Rec' whose values have eliminated common syntactic+-- clutter due to 'Identity', 'Compose', and 'ElField' type+-- constructors.+--+-- A common pain point with using 'Rec' is the mandatory /context/ of+-- each value. A basic record might look like this, @Identity "joe" :&+-- Identity 23 :& RNil :: Rec Identity '[String, Int]@. The 'Identity'+-- constructors are a nuisance, so we offer a way of avoiding them:+-- @"joe" ::& 23 ::& XRNil :: XRec Identity '[String,Int]@. Facilities+-- are provided for converting between 'XRec' and 'Rec' so that the+-- 'Rec' API is available even if you choose to use 'XRec' for+-- construction or pattern matching.+module Data.Vinyl.XRec where+import Data.Vinyl.Core (Rec(..))+import Data.Vinyl.Functor+import Data.Monoid+import GHC.TypeLits (KnownSymbol)++type XRec f = Rec (XData f)+pattern (::&) :: HKD f r -> XRec f rs -> XRec f (r ': rs)+pattern x ::& xs = XData x :& xs+{-# COMPLETE (::&) #-}++infixr 7 ::&++pattern XRNil :: XRec f '[]+pattern XRNil = RNil+{-# COMPLETE XRNil #-}++-- | Like 'rmap', but the supplied function is written against the+-- 'HKD'-simplified types. This is 'xrmap' sandwiched in between+-- 'fromXRec' and 'toXRec'.+rmapX :: forall f g rs. (XRMap f g rs, IsoXRec f rs, IsoXRec g rs)+ => (forall a. HKD f a -> HKD g a) -> Rec f rs -> Rec g rs+rmapX f = fromXRec . xrmapAux aux . toXRec+ where aux :: forall a. XData f a -> XData g a+ aux = XData . f @a . unX++-- | This is 'rmapX' specialized to a type at which it does not change+-- interpretation functor. This can help with type inference.+rmapXEndo :: forall f rs. (XRMap f f rs, IsoXRec f rs)+ => (forall a. HKD f a -> HKD f a) -> Rec f rs -> Rec f rs+rmapXEndo f = fromXRec . xrmapAux aux . toXRec+ where aux :: forall a. XData f a -> XData f a+ aux = XData . f @a . unX++-- | This is 'rmap' for 'XRec'. We apply a natural transformation+-- between interpretation functors to transport a record value between+-- interpretations.+xrmap :: forall f g rs. XRMap f g rs+ => (forall a. HKD f a -> HKD g a) -> XRec f rs -> XRec g rs+xrmap f = xrmapAux aux+ where aux :: forall a. XData f a -> XData g a+ aux = XData . f @a . unX++-- | A wrapper for an 'HKD'-simplified value. That is, noisy value+-- constructors like 'Identity' and 'Compose' are ellided. This is+-- used in the 'xrmapAux' type class method, but may be ignored by+-- users whose needs are met by 'xrmap' and 'rmapX'.+newtype XData t a = XData { unX :: HKD t a }++-- | The implementation of 'xrmap' is broken into a type class to+-- permit unrolling of the recursion across a record. The function+-- mapped across the vector hides the 'HKD' type family under a newtype+-- constructor to help the type checker.+class XRMap (f :: u -> *) (g :: u -> *) (rs :: [u]) where+ xrmapAux :: (forall (a :: u) . XData f a -> XData g a) -> XRec f rs -> XRec g rs++instance XRMap f g '[] where+ xrmapAux _ RNil = RNil++instance forall f g r rs. (XRMap f g rs, IsoHKD f r, IsoHKD g r)+ => XRMap f g (r ': rs) where+ xrmapAux f (x :& xs) = f x :& xrmapAux f xs++-- | Like 'rapply': record of components @f r -> g r@ may be applied+-- to a record of @f@ to get a record of @g@.+class XRApply f g rs where+ xrapply :: XRec (Lift (->) f g) rs -> XRec f rs -> XRec g rs++instance XRApply f g '[] where+ xrapply RNil RNil = RNil++instance XRApply f g rs => XRApply f g (r ': rs) where+ xrapply (XData f :& fs) (XData x :& xs) = XData (f x) :& xrapply fs xs++-- | Conversion between 'XRec' and 'Rec'. It is convenient to build+-- and consume 'XRec' values to reduce syntactic noise, but 'Rec' has+-- a richer API that is difficult to build around the 'HKD' type+-- family.+class IsoXRec f ts where+ fromXRec :: XRec f ts -> Rec f ts+ toXRec :: Rec f ts -> XRec f ts++instance IsoXRec f '[] where+ fromXRec RNil = RNil+ toXRec RNil = XRNil++instance (IsoXRec f ts, IsoHKD f t) => IsoXRec f (t ': ts) where+ fromXRec (x ::& xs) = unHKD x :& fromXRec xs+ toXRec (x :& xs) = toHKD x ::& toXRec xs++-- | Isomorphism between a syntactically noisy value and a concise+-- one. For types like, 'Identity', we prefer to work with values of+-- the underlying type without writing out the 'Identity'+-- constructor. For @'Compose' f g a@, aka @(f :. g) a@, we prefer to+-- work directly with values of type @f (g a)@.+--+-- This involves the so-called /higher-kinded data/ type family. See+-- <http://reasonablypolymorphic.com/blog/higher-kinded-data> for more+-- discussion.+class IsoHKD (f :: u -> *) (a :: u) where+ type HKD f a+ type HKD f a = f a+ unHKD :: HKD f a -> f a+ default unHKD :: HKD f a ~ f a => HKD f a -> f a+ unHKD = id+ toHKD :: f a -> HKD f a+ default toHKD :: (HKD f a ~ f a) => f a -> HKD f a+ toHKD = id++-- | Work with values of type 'Identity' @a@ as if they were simple of+-- type @a@.+instance IsoHKD Identity a where+ type HKD Identity a = a+ unHKD = Identity+ toHKD (Identity x) = x++-- | Work with values of type 'ElField' @'(s,a)@ as if they were of+-- type @a@.+instance KnownSymbol s => IsoHKD ElField '(s,a) where+ type HKD ElField '(s,a) = a+ unHKD = Field+ toHKD (Field x) = x++-- | Work with values of type 'Compose' @f g a@ as if they were of+-- type @f (g a)@.+instance (IsoHKD f (HKD g a), IsoHKD g a, Functor f) => IsoHKD (Compose f g) a where+ type HKD (Compose f g) a = HKD f (HKD g a)+ unHKD x = Compose (unHKD <$> unHKD x)+ toHKD (Compose fgx) = toHKD (toHKD <$> fgx)++-- | Work with values of type 'Lift' @(->) f g a@ as if they were of+-- type @f a -> g a@.+instance (IsoHKD f a, IsoHKD g a) => IsoHKD (Lift (->) f g) a where+ type HKD (Lift (->) f g) a = HKD f a -> HKD g a+ unHKD x = Lift (unHKD . x . toHKD)+ toHKD (Lift x) = toHKD . x . unHKD++instance IsoHKD IO a where+instance IsoHKD (Either a) b where+instance IsoHKD Maybe a where+instance IsoHKD First a where+instance IsoHKD Last a where++-- | Work with values of type 'Sum' @a@ as if they were of type @a@.+instance IsoHKD Sum a where+ type HKD Sum a = a+ unHKD = Sum+ toHKD (Sum x) = x++-- | Work with values of type 'Product' @a@ as if they were of type @a@.+instance IsoHKD Product a where+ type HKD Product a = a+ unHKD = Product+ toHKD (Product x) = x
benchmarks/AccessorsBench.hs view
@@ -1,35 +1,148 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} import Control.Monad (unless) import Criterion.Main+import Data.Monoid (Endo(..)) import Data.Vinyl+import Data.Vinyl.Syntax ()+import Lens.Micro ((%~), (&)) 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 )- ]+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 +data HaskRec = HaskRec {+ 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 } deriving Show++haskRec :: HaskRec+haskRec = HaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++data StrictHaskRec = StrictHaskRec {+ sa0 :: !Int,+ sa1 :: !Int,+ sa2 :: !Int,+ sa3 :: !Int,+ sa4 :: !Int,+ sa5 :: !Int,+ sa6 :: !Int,+ sa7 :: !Int,+ sa8 :: !Int,+ sa9 :: !Int,+ sa10 :: !Int,+ sa11 :: !Int,+ sa12 :: !Int,+ sa13 :: !Int,+ sa14 :: !Int,+ sa15 :: !Int }++shaskRec :: StrictHaskRec+shaskRec = StrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++data UStrictHaskRec = UStrictHaskRec {+ usa0 :: {-# UNPACK #-} !Int,+ usa1 :: {-# UNPACK #-} !Int,+ usa2 :: {-# UNPACK #-} !Int,+ usa3 :: {-# UNPACK #-} !Int,+ usa4 :: {-# UNPACK #-} !Int,+ usa5 :: {-# UNPACK #-} !Int,+ usa6 :: {-# UNPACK #-} !Int,+ usa7 :: {-# UNPACK #-} !Int,+ usa8 :: {-# UNPACK #-} !Int,+ usa9 :: {-# UNPACK #-} !Int,+ usa10 :: {-# UNPACK #-} !Int,+ usa11 :: {-# UNPACK #-} !Int,+ usa12 :: {-# UNPACK #-} !Int,+ usa13 :: {-# UNPACK #-} !Int,+ usa14 :: {-# UNPACK #-} !Int,+ usa15 :: {-# UNPACK #-} !Int }++ushaskRec :: UStrictHaskRec+ushaskRec = UStrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++type SubFields = '[ '("a0", Int), '("a8", Int), '("a15", Int)]++-- updateSRec :: forall record. RecordSubset record ElField SubFields Fields+-- => record ElField Fields -> record ElField Fields+updateSRec :: SRec ElField Fields -> SRec ElField Fields+updateSRec = rsubset %~ appEndo aux+ where aux :: Endo (SRec ElField SubFields)+ aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++updateARec :: ARec ElField Fields -> ARec ElField Fields+updateARec = rsubset %~ appEndo aux+ where aux :: Endo (ARec ElField SubFields)+ aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++updateRec :: Rec ElField Fields -> Rec ElField Fields+updateRec = rsubset %~ appEndo aux+ where aux :: Endo (Rec ElField SubFields)+ aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++data SubRec = SubRec { suba0 :: Int, suba8 :: Int, suba15 :: Int }++updateHaskRec :: HaskRec -> HaskRec+updateHaskRec r = r { a0 = suba0 s, a8 = suba8 s, a15 = suba15 s }+ where s = aux (SubRec (a0 r) (a8 r) (a15 r))+ aux r' = r' { suba0 = suba0 r' + 4, suba8 = suba8 r' + 3, suba15 = suba15 r' + 2 }+ main :: IO () main = do let arec = toARec newF+ srec = toSRec newF unless (rvalf #a15 arec == rvalf #a15 newF) (do putStrLn "AFieldRec accessor disagrees with rvalf" exitFailure)+ unless (rvalf #a15 srec == rvalf #a15 newF)+ (do putStrLn "SFieldRec accessor disagrees with rvalf"+ exitFailure)+ let srec' = updateSRec srec+ haskRec' = updateHaskRec haskRec+ arec' = updateARec arec+ unless (rvalf #a0 srec' == a0 haskRec' && a0 haskRec' == 4 &&+ rvalf #a8 srec' == a8 haskRec' && a8 haskRec' == 3 &&+ rvalf #a15 srec' == a15 haskRec' && a15 haskRec' == 101)+ (do putStrLn "SRec and Haskell Record updates disagree"+ exitFailure)+ unless (rvalf #a0 arec' == 4 && rvalf #a8 arec' == 3 &&+ rvalf #a15 arec' == 101)+ (do putStrLn "ARec record updates are inconsistent"+ exitFailure) defaultMain- [ bgroup "FieldRec"+ [ bgroup "Update"+ [ bench "Haskell Record" $ nf (a15 . updateHaskRec) haskRec+ , bench "Rec" $ nf (rvalf #a15 . updateRec) newF+ , bench "ARec" $ nf (rvalf #a15 . updateARec) arec+ , bench "SRec" $ nf (rvalf #a15 . updateSRec) srec+ ]+ , bgroup "FieldRec" [ bench "a0" $ nf (rvalf #a0) newF , bench "a4" $ nf (rvalf #a4) newF , bench "a8" $ nf (rvalf #a8) newF@@ -38,9 +151,37 @@ ] , 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 "a4" $ nf (rvalf #a4) arec+ -- , bench "a8" $ nf (rvalf #a8) arec+ -- , bench "a12" $ nf (rvalf #a12) arec , bench "a15" $ nf (rvalf #a15) arec+ ]+ , bgroup "SFieldRec"+ [ bench "a0" $ nf (rvalf #a0) srec+ -- , bench "a4" $ nf (rvalf #a4) srec+ -- , bench "a8" $ nf (rvalf #a8) srec+ -- , bench "a12" $ nf (rvalf #a12) srec+ , bench "a15" $ nf (rvalf #a15) srec+ ]+ , bgroup "Haskell Record"+ [ bench "a0" $ nf a0 haskRec+ -- , bench "a4" $ nf a4 haskRec+ -- , bench "a8" $ nf a8 haskRec+ -- , bench "a12" $ nf a12 haskRec+ , bench "a15" $ nf a15 haskRec+ ]+ , bgroup "Strict Haskell Record"+ [ bench "a0" $ nf sa0 shaskRec+ -- , bench "a4" $ nf sa4 shaskRec+ -- , bench "a8" $ nf sa8 shaskRec+ -- , bench "a12" $ nf sa12 shaskRec+ , bench "a15" $ nf sa15 shaskRec+ ]+ , bgroup "Unpacked Strict Haskell Record"+ [ bench "a0" $ nf usa0 ushaskRec+ -- , bench "a4" $ nf usa4 ushaskRec+ -- , bench "a8" $ nf usa8 ushaskRec+ -- , bench "a12" $ nf usa12 ushaskRec+ , bench "a15" $ nf usa15 ushaskRec ] ]
benchmarks/StorableBench.hs view
@@ -12,7 +12,6 @@ import Lens.Micro.Extras (view) import Control.Monad (when) import qualified Data.Foldable as F-import Data.Proxy import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Data.Vinyl@@ -29,9 +28,6 @@ randVecStd :: (Storable a, Variate a) => Int -> IO (V.Vector a) randVecStd = withSystemRandom . randVec -vNorm :: Proxy '("normal", V3 a)-vNorm = Proxy- type MyFields a = [ '("pos", V3 a), '("tex", V2 a), '("normal", V3 a) ] type MyVertex a = FieldRec (MyFields a) @@ -40,16 +36,13 @@ 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))+vinylNormSumLens = 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))+doubleNormYLens = V.map (rlensf #normal . _y *~ (2::Float)) doubleNormY :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float) doubleNormY = V.map (\(p :& t :& Field n :& RNil) ->@@ -66,11 +59,9 @@ 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- , vinylLabAns, vinylLabLans ])+ when (any (/= vinylAns) [ vinylLans, flatAns, reasAns, vinylLabAns ]) (error "Not all versions compute the same answer") defaultMain [ bench "flat" $ whnf (flatNormSum . doubleNormFlat) flatVerts@@ -80,8 +71,6 @@ 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/CoRecSpec.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DataKinds, FlexibleContexts,- ScopedTypeVariables, TypeOperators #-}+ ScopedTypeVariables, TypeApplications, TypeOperators #-} {-# OPTIONS_GHC -fdefer-type-errors #-} module CoRecSpec (spec) where import Control.Monad ((>=>))@@ -31,9 +31,9 @@ describe "CoRecs" $ do let x = CoRec (pure True) :: Field '[Int,Bool,()] it "Can be cast successfully" $- asA (Proxy :: Proxy Bool) x `shouldBe` Just True+ asA @Bool x `shouldBe` Just True it "Can fail to cast" $- asA (Proxy :: Proxy Int) x `shouldBe` Nothing+ asA @Int x `shouldBe` Nothing it "Can be handled all at once" $ match x (H (\y -> "Int") :& H (\y -> "Bool")
tests/Intro.lhs view
@@ -20,11 +20,10 @@ > {-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} > {-# LANGUAGE FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction #-} > {-# LANGUAGE GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}+> {-# LANGUAGE TypeApplications #-} > import Data.Vinyl > import Data.Vinyl.Functor-> import Control.Applicative > import Control.Lens hiding (Identity)-> import Control.Lens.TH > import Data.Char > import Test.DocTest > import Data.Singletons.TH (genSingletons)@@ -120,20 +119,21 @@ > jon' = wakeUp jon > -- |-> -- >>> tucker' ^. rlens SSleeping+> -- >>> :set -XTypeApplications -XDataKinds+> -- >>> tucker' ^. rlens @Sleeping > -- sleeping: False > ---> -- >>> tucker ^. rlens SSleeping+> -- >>> tucker ^. rlens @Sleeping > -- sleeping: True > ---> -- >>> jon' ^. rlens SSleeping+> -- >>> jon' ^. rlens @Sleeping > -- sleeping: False We can also access the entire lens for a field using the rLens function; since lenses are composable, it’s super easy to do deep update on a record: -> masterSleeping = rlens SMaster . unAttr . rlens SSleeping+> masterSleeping = rlens @Master . unAttr . rlens @Sleeping > tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker' > -- | >>> tucker'' ^. masterSleeping@@ -205,8 +205,8 @@ > validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person) > validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge where-> vName = validateName $ p ^. rlens SName . unAttr-> vAge = validateAge $ p ^. rlens SAge . unAttr+> vName = validateName $ p ^. rlens @'Name . unAttr+> vAge = validateAge $ p ^. rlens @'Age . unAttr > > validateName str | all isAlpha str = Just str > validateName _ = Nothing@@ -255,13 +255,14 @@ > badPersonResult = vperson <<*>> badPerson > -- |-> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SName+> -- >>> :set -XTypeApplications -XDataKinds+> -- >>> isJust . getCompose $ goodPersonResult ^. rlens @Name > -- True-> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SAge+> -- >>> isJust . getCompose $ goodPersonResult ^. rlens @Age > -- True-> -- >>> isJust . getCompose $ badPersonResult ^. rlens SName+> -- >>> isJust . getCompose $ badPersonResult ^. rlens @Name > -- False-> -- >>> isJust . getCompose $ badPersonResult ^. rlens SAge+> -- >>> isJust . getCompose $ badPersonResult ^. rlens @Age > -- True
tests/Spec.hs view
@@ -1,14 +1,12 @@-{-# LANGUAGE CPP, DataKinds, FlexibleContexts, GADTs, ScopedTypeVariables,- TypeOperators #-}-#if __GLASGOW_HASKELL__ > 800-{-# LANGUAGE OverloadedLabels #-}-#endif--{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs,+ NoMonomorphismRestriction, OverloadedLabels,+ ScopedTypeVariables, TypeApplications, TypeOperators #-}+{-# OPTIONS_GHC -Wall -Wno-type-defaults #-} import Data.Vinyl import Data.Vinyl.Functor (Lift(..), Const(..), Compose(..), (:.)) import Lens.Micro import Test.Hspec+import Data.Vinyl.Syntax () import qualified CoRecSpec as C @@ -34,7 +32,6 @@ 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"@@ -43,7 +40,32 @@ 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))))+ rvalf #y (toARec (#y %~ (show . length) $+ fromARec (rputf #x 7 (toARec d3)))) `shouldBe` "2"-#endif+ describe "Converting between Rec and SRec" $ do+ it "Can go back and forth" $+ let d4 = #x =:= 5 <+> #y =:= 4 :: FieldRec '[ '("x",Int), '("y",Int)]+ isqrt = floor . (sqrt :: Double -> Double) . fromIntegral :: Int -> Int+ in rvalf #y (toSRec (#y %~ isqrt $+ fromSRec (rputf #x 7 (toSRec d4))))+ `shouldBe` 2++ describe "Produces field lenses from overloaded labels" $ do+ it "Can invert a boolean field" $ do+ (fieldRec (#x =: True, #y =: 'b') & #x %~ not)+ `shouldBe` fieldRec (#x =: False, #y =: 'b')+ describe "Supports tuple construction" $ do+ it "Can build ElField records from tuples" $+ fieldRec (#x =: 5, #y =: "Hi") `shouldBe` d3+ it "Can build Recs of Maybe values" $+ record @Maybe (Just True, Just 'a') `shouldBe` Just True :& Just 'a' :& RNil+ it "Can build Recs of Const values" $+ record @(Const String) ( Const "howdy" :: Const String Int+ , Const "folks" :: Const String Double)+ `shouldBe` Const "howdy" :& Const "folks" :& RNil+ describe "Can change the types of individual fields" $ do+ it "Can set a field with a different type" $+ (#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)
vinyl.cabal view
@@ -1,5 +1,5 @@ name: vinyl-version: 0.8.1.1+version: 0.9.0 synopsis: Extensible Records -- description: license: MIT@@ -27,17 +27,22 @@ , Data.Vinyl.Core , Data.Vinyl.CoRec , Data.Vinyl.Curry+ , Data.Vinyl.FromTuple , Data.Vinyl.Lens , Data.Vinyl.Derived , Data.Vinyl.TypeLevel , Data.Vinyl.Functor , Data.Vinyl.Notation+ , Data.Vinyl.SRec+ , Data.Vinyl.Syntax , Data.Vinyl.Tutorial.Overview+ , Data.Vinyl.XRec build-depends: base >=4.7 && <= 5, 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+ ghc-options: -Wall+ other-extensions: TypeApplications benchmark storable type: exitcode-stdio-1.0@@ -67,7 +72,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: AccessorsBench.hs- build-depends: base >= 4.7 && <= 5, criterion, tagged, vinyl+ build-depends: base >= 4.7 && <= 5, criterion, tagged, vinyl, microlens ghc-options: -O2 default-language: Haskell2010