vinyl 0.5.3 → 0.6.0

raw patch · 10 files changed

+464/−51 lines, 10 filesdep +hspecdep +primitivedep +should-not-typecheckdep ~basedep ~vinylPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, primitive, should-not-typecheck

Dependency ranges changed: base, vinyl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• Data/Vinyl/CoRec.hs +227/−0
• Data/Vinyl/Core.hs +49/−4
• Data/Vinyl/Lens.hs +10/−4
• Data/Vinyl/Tutorial/Overview.hs +4/−6
• Data/Vinyl/TypeLevel.hs +28/−2
• benchmarks/StorableBench.hs +29/−26
• tests/CoRecSpec.hs +50/−0
• tests/Spec.hs +31/−0
• vinyl.cabal +32/−9

@@ -1,3 +1,7 @@+# 0.6.0++Added a `CoRec` (co-record) type constructed in the same style as the existing `Rec` type for records. A `CoRec` is an open sum type: a value of `CoRec [a,b,c]` is either an `a`, a `b`, *or* a `c`. In contrast a `Rec [a,b,c]` includes an `a`, a `b`, *and*, a `c`.+ # 0.5.3  Added a concise `Show` instance for `Const`.

@@ -0,0 +1,227 @@+{-# LANGUAGE BangPatterns, CPP, ConstraintKinds, DataKinds, EmptyCase,+             FlexibleContexts, FlexibleInstances, GADTs,+             KindSignatures, MultiParamTypeClasses, PolyKinds,+             RankNTypes, ScopedTypeVariables, TypeOperators,+             UndecidableInstances #-}+-- | Co-records: open sum types.+--+-- Consider a record with three fields @A@, @B@, and @C@. A record is+-- a product of its fields; that is, it contains all of them: @A@,+-- @B@, /and/ @C@. If we want to talk about a value whose type is one+-- of those three types, it is /any one/ of type @A@, @B@, /or/+-- @C@. The type @CoRec '[A,B,C]@ corresponds to this sum type.+module Data.Vinyl.CoRec where+import Data.Maybe(fromJust)+import Data.Proxy+import Data.Vinyl+import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..))+import Data.Vinyl.TypeLevel+#if __GLASGOW_HASKELL__ < 800+import GHC.Prim (Constraint)+#else+import Data.Kind (Constraint)+#endif++-- | Generalize algebraic sum types.+data CoRec :: (k -> *) -> [k] -> * where+  CoRec :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts++-- | Apply a function to a 'CoRec' value. The function must accept+-- /any/ variant.+foldCoRec :: (forall a. RElem a ts (RIndex a ts) => f a -> b) -> CoRec f ts -> b+foldCoRec f (CoRec x) = f x++-- | A Field of a 'Rec' 'Identity' is a 'CoRec' 'Identity'.+type Field = CoRec Identity++-- | A function type constructor that takes its arguments in the+-- reverse order.+newtype Op b a = Op { runOp :: a -> b }++instance forall ts. (AllConstrained 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)++instance forall ts. (RecAll Maybe ts Eq, RecApplicative 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'++-- | 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))++-- | Shorthand for applying 'coRecToRec' with common functors.+coRecToRec' :: RecApplicative ts => CoRec Identity ts -> Rec Maybe ts+coRecToRec' = rmap (fmap getIdentity . getCompose) . coRecToRec++-- | Fold a field selection function over a 'Rec'.+class FoldRec ss ts where+  foldRec :: (CoRec f ss -> CoRec f ss -> CoRec f ss)+          -> CoRec f ss+          -> Rec f ts+          -> CoRec f ss++instance FoldRec ss '[] where foldRec _ z _ = z++instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where+  foldRec f z (x :& xs) = foldRec f (f z (CoRec x)) xs++-- | Apply a natural transformation to a variant.+coRecMap :: (forall x. f x -> g x) -> CoRec f ts -> CoRec g ts+coRecMap nt (CoRec x) = CoRec (nt x)++-- | This can be used to pull effects out of a 'CoRec'.+coRecTraverse :: Functor h+              => (forall x. f x -> h (g x)) -> CoRec f ts -> h (CoRec g ts)+coRecTraverse f (CoRec x) = fmap CoRec (f x)++-- | Fold a field selection function over a non-empty 'Rec'.+foldRec1 :: FoldRec (t ': ts) ts+         => (CoRec f (t ': ts) -> CoRec f (t ': ts) -> CoRec f (t ': ts))+         -> Rec f (t ': ts)+         -> CoRec f (t ': ts)+foldRec1 f (x :& xs) = foldRec f (CoRec x) xs++-- | Similar to 'Data.Monoid.First': find the first field that is not+-- 'Nothing'.+firstField :: FoldRec ts ts+           => Rec (Maybe :. f) ts -> Maybe (CoRec f ts)+firstField RNil = Nothing+firstField v@(x :& _) = coRecTraverse getCompose $ foldRec aux (CoRec x) v+  where aux :: CoRec (Maybe :. f) (t ': ts)+            -> CoRec (Maybe :. f) (t ': ts)+            -> CoRec (Maybe :. f) (t ': ts)+        aux c@(CoRec (Compose (Just _))) _ =  c+        aux _ c = c++-- | Similar to 'Data.Monoid.Last': find the last field that is not+-- 'Nothing'.+lastField :: FoldRec ts ts+          => Rec (Maybe :. f) ts -> Maybe (CoRec f ts)+lastField RNil = Nothing+lastField v@(x :& _) = coRecTraverse getCompose $ foldRec aux (CoRec x) v+  where aux :: CoRec (Maybe :. f) (t ': ts)+            -> CoRec (Maybe :. f) (t ': ts)+            -> CoRec (Maybe :. f) (t ': ts)+        aux _ c@(CoRec (Compose (Just _))) = c+        aux c _ = c++-- | Apply a type class method on a 'CoRec'. The first argument is a+-- 'Proxy' value for a /list/ of 'Constraint' constructors. For+-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint+-- is needed, use the @pr1@ quasiquoter.+onCoRec :: forall (cs :: [* -> Constraint]) f ts b.+           (AllAllSat cs ts, Functor f, RecApplicative ts)+        => Proxy cs+        -> (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)++-- | Apply a type class method on a 'Field'. The first argument is a+-- 'Proxy' value for a /list/ of 'Constraint' constructors. For+-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint+-- is needed, use the @pr1@ quasiquoter.+onField :: forall cs ts b.+           (AllAllSat cs ts, RecApplicative ts)+        => Proxy cs+        -> (forall a. AllSatisfied cs a => a -> b)+        -> Field ts -> b+onField p f x = getIdentity (onCoRec p f x)++-- | Build a record whose elements are derived solely from a+-- list of constraint constructors satisfied by each.+reifyDicts :: forall cs f proxy (ts :: [*]). (AllAllSat cs ts, RecApplicative ts)+           => proxy cs -> (forall a. AllSatisfied cs a => f a) -> Rec f ts+reifyDicts _ f = go (rpure Nothing)+  where go :: AllAllSat cs ts' => Rec Maybe ts' -> Rec f ts'+        go RNil = RNil+        go (_ :& xs) = f :& go xs++-- * 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++-- | Pattern match on a CoRec by specifying handlers for each case. If the+-- CoRec is non-empty this function is total. Note that the order of the+-- Handlers has to match the type level list (t:ts).+--+-- >>> :{+-- let testCoRec = Col (Identity False) :: CoRec Identity [Int, String, Bool] in+-- match testCoRec $+--       (H $ \i -> "my Int is the successor of " ++ show (i - 1))+--    :& (H $ \s -> "my String is: " ++ s)+--    :& (H $ \b -> "my Bool is not: " ++ show (not b) ++ " thus it is " ++ show b)+--    :& RNil+-- :}+-- "my Bool is not: True thus it is False"+match      :: RecApplicative (t ': ts)+           => CoRec Identity (t ': ts) -> Handlers (t ': ts) b -> b+match c hs = fromJust $ match' c hs+           -- Since we require 'ts' both for the Handlers and the CoRec, Handlers+           -- effectively defines a total function. Hence, we can safely use fromJust++-- | Pattern match on a CoRec by specifying handlers for each case. The only case+-- in which this can produce a Nothing is if the list ts is empty.+match'      :: RecApplicative ts => CoRec Identity ts -> Handlers ts b -> Maybe b+match' c hs = match'' hs $ coRecToRec' c+  where+    match''                             :: Handlers ts b -> Rec Maybe ts -> Maybe b+    match'' RNil        RNil            = Nothing+    match'' (H f :& _)  (Just x  :& _)  = Just $ f x+    match'' (H _ :& fs) (Nothing :& c') = match'' fs c'++-- | 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+-- reflect the fact that the variant is /not/ compatible with the type+-- of the would-be handler.+class RIndex t ts ~ i => Match1 t ts i where+  match1' :: Handler r t -> Rec Maybe ts -> Either r (Rec Maybe (RDelete t ts))++instance Match1 t (t ': ts) 'Z where+  match1' _ (Nothing :& xs) = Right xs+  match1' (H h) (Just x :& _) = Left (h x)++instance (Match1 t ts i, RIndex t (s ': ts) ~ 'S i,+          RDelete t (s ': ts) ~ (s ': RDelete t ts))+         => Match1 t (s ': ts) ('S i) where+  match1' h (x :& xs) = (x :&) <$> match1' h xs++-- | Handle a single variant of a 'CoRec': either the function is+-- applied to the variant or the type of the 'CoRec' is refined to+-- reflect the fact that the variant is /not/ compatible with the type+-- of the would-be handler+match1 :: (Match1 t ts (RIndex t ts),+           RecApplicative ts,+           FoldRec (RDelete t ts) (RDelete t ts))+       => Handler r t+       -> CoRec Identity ts+       -> Either r (CoRec Identity (RDelete t ts))+match1 h = fmap (fromJust . firstField . rmap (Compose . fmap Identity))+         . match1' h+         . coRecToRec'++matchNil :: CoRec f '[] -> r+matchNil (CoRec x) = case x of++-- | Newtype around functions for a to b+newtype Handler b a = H (a -> b)++-- | 'Handlers ts b', is essentially a list of functions, one for each type in+-- 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

@@ -142,6 +142,32 @@ rtraverse f (x :& xs) = (:&) <$> f x <*> rtraverse f xs {-# INLINABLE rtraverse #-} +-- | Given a natural transformation from the product of @f@ and @g@ to @h@, we+-- 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++-- | 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 #-}+{-# INLINE rfoldMap #-}+ -- | A record with uniform fields may be turned into a list. recordToList   :: Rec (Const a) rs@@ -171,6 +197,25 @@     RNil -> RNil     (x :& xs) -> Compose (Dict x) :& reifyConstraint prx xs +-- | Build a record whose elements are derived solely from a+-- constraint satisfied by each.+rpureConstrained :: forall c (f :: * -> *) proxy ts.+                    (AllConstrained c ts, RecApplicative ts)+                 => proxy c -> (forall a. c a => f a) -> Rec f ts+rpureConstrained _ f = go (rpure Nothing)+  where go :: AllConstrained c ts' => Rec Maybe ts' -> Rec f ts'+        go RNil = RNil+        go (_ :& xs) = f :& go xs++-- | 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+ -- | 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@@ -207,12 +252,12 @@  instance (Storable (f r), Storable (Rec f rs)) => Storable (Rec f (r ': rs)) where   sizeOf _ = sizeOf (undefined :: f r) + sizeOf (undefined :: Rec f rs)-  {-# INLINABLE sizeOf #-}+  {-# INLINE sizeOf #-}   alignment _ =  alignment (undefined :: f r)-  {-# INLINABLE alignment #-}+  {-# INLINE alignment #-}   peek ptr = do !x <- peek (castPtr ptr)                 !xs <- peek (ptr `plusPtr` sizeOf (undefined :: f r))                 return $ x :& xs-  {-# INLINABLE peek #-}+  {-# INLINE peek #-}   poke ptr (!x :& xs) = poke (castPtr ptr) x >> poke (ptr `plusPtr` sizeOf (undefined :: f r)) xs-  {-# INLINEABLE poke #-}+  {-# INLINE poke #-}

@@ -48,7 +48,6 @@     :: sing r     -> Rec f rs     -> f r-  rget k = getConst . rlens k Const    -- | 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,@@ -57,7 +56,6 @@     :: f r     -> Rec f rs     -> Rec f rs-  rput y = getIdentity . rlens Proxy (\_ -> Identity y)  -- This is an internal convenience stolen from the @lens@ library. lens@@ -70,13 +68,21 @@ lens sa sbt afb s = fmap (sbt s) $ afb (sa s) {-# INLINE lens #-} -instance RElem r (r ': rs) Z where+instance RElem 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 (RIndex r (s ': rs) ~ S i, RElem r rs i) => RElem r (s ': rs) (S i) where+instance (RIndex r (s ': rs) ~ 'S i, RElem r rs i) => RElem 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 #-}  -- | 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

@@ -4,7 +4,7 @@     type level strings and other modern GHC features, featuring static     structural typing (with a subtyping relation), and automatic     row-polymorphic lenses. All this is possible without Template Haskell.-    +     Let's work through a quick example. We'll need to enable some language     extensions first: @@ -93,7 +93,7 @@ are life-forms, but unlike humans, they have masters. So, let’s build my dog: ->>> :{ +>>> :{ let tucker = (SName =:: "tucker")           :& (SAge =:: 9)           :& (SSleeping =:: True)@@ -206,7 +206,7 @@ We\'ll give validation a (rather poor) shot.  >>> :{-let +let     validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person)     validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge       where@@ -288,11 +288,9 @@ False  -}-+{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Data.Vinyl.Tutorial.Overview where  import Data.Vinyl.Core import Data.Vinyl.Functor import Data.Vinyl.Lens--

@@ -19,14 +19,19 @@  -- | A partial relation that gives the index of a value in a list. type family RIndex (r :: k) (rs :: [k]) :: Nat where-  RIndex r (r ': rs) = Z-  RIndex r (s ': rs) = S (RIndex r rs)+  RIndex r (r ': rs) = 'Z+  RIndex r (s ': rs) = 'S (RIndex r rs)  -- | A partial relation that gives the indices of a sublist in a larger list. type family RImage (rs :: [k]) (ss :: [k]) :: [Nat] where   RImage '[] ss = '[]   RImage (r ': rs) ss = RIndex r ss ': RImage rs ss +-- | Remove the first occurence of a type from a type-level list.+type family RDelete r rs where+  RDelete r (r ': rs) = rs+  RDelete r (s ': rs) = s ': RDelete r rs+ -- | A constraint-former which applies to every field in a record. type family RecAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where   RecAll f '[] c = ()@@ -37,3 +42,24 @@   '[] ++ bs = bs   (a ': as) ++ bs = a ': (as ++ bs) +-- | Constraint that all types in a type-level list satisfy a+-- constraint.+type family AllConstrained c ts :: Constraint where+  AllConstrained c '[] = ()+  AllConstrained c (t ': ts) = (c t, AllConstrained c ts)++-- | Constraint that each Constraint in a type-level list is satisfied+-- by a particular type.+type family AllSatisfied cs t :: Constraint where+  AllSatisfied '[] t = ()+  AllSatisfied (c ': cs) t = (c t, AllSatisfied cs t)++-- | Constraint that all types in a type-level list satisfy each+-- constraint from a list of constraints.+--+-- @AllAllSat cs ts@ should be equivalent to @AllConstrained+-- (AllSatisfied cs) ts@ if partial application of type families were+-- legal.+type family AllAllSat cs ts :: Constraint where+  AllAllSat cs '[] = ()+  AllAllSat cs (t ': ts) = (AllSatisfied cs t, AllAllSat cs ts)

@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}+{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-} -- A benchmark where we initialize a 'V.Vector' of random vertices, -- each carrying 3D position, 2D texture coordinates, and a 3D normal -- vector. A calculation is carried out where we multiply the y@@ -7,7 +7,6 @@ -- by interfacing the vertex data as a flat record, a traditional -- record of "Linear" finite dimensional vector types, and a vinyl -- record of linear fields.-import Control.Applicative import Control.Lens import Control.Monad (when) import qualified Data.Foldable as F@@ -34,34 +33,38 @@ type MyFields a = [ '("pos", V3 a), '("tex", V2 a), '("normal", V3 a) ] type MyVertex a = FieldRec (MyFields a) -doubleNviL :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)-doubleNviL = V.map (rlens vNorm . rfield . _y *~ (2::Float))+vinylNormSumLens :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSumLens = V.sum . V.map (F.sum . view (rlens vNorm . rfield)) -vinylNSumL :: (Num a, Storable a) => V.Vector (MyVertex a) -> a-vinylNSumL = V.sum . V.map (F.sum . view (rlens vNorm . rfield))+doubleNormYLens :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)+doubleNormYLens = V.map (rlens vNorm . rfield . _y *~ (2::Float)) -doubleNvi :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)-doubleNvi = V.map (rlens vNorm . rfield . _y *~ (2::Float))+doubleNormY :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)+doubleNormY = V.map (\(p :& t :& Field n :& RNil) ->+                       p :& t :& Field (_y *~ (2::Float) $ n) :& RNil) -vinylNSum :: (Num a, Storable a) => V.Vector (MyVertex a) -> a-vinylNSum = V.sum . V.map (F.sum . view rfield . rget vNorm)+vinylNormSum :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSum = V.sum . V.map (F.sum . (\(_ :& _ :& Field vn :& RNil) -> vn))  main :: IO () main = do vals <- randVecStd $ n * 8 :: IO (V.Vector Float)           let vinylVerts = V.unsafeCast vals :: V.Vector (MyVertex Float)               flatVerts = V.unsafeCast vals               reasVerts = V.unsafeCast vals-              vinylAns = vinylNSum $ doubleNvi vinylVerts-              vinylLans = vinylNSumL $ doubleNviL vinylVerts-              flatAns = flatNSum $ doubleNfl flatVerts-              reasAns = reasNSum $ doubleNre reasVerts+              vinylAns = vinylNormSum $ doubleNormY vinylVerts+              vinylLans = vinylNormSumLens $ doubleNormYLens vinylVerts+              flatAns = flatNormSum $ doubleNormFlat flatVerts+              reasAns = reasNormSum $ doubleNormReas reasVerts           when (any (/= vinylAns) [vinylLans, flatAns, reasAns])                (error "Not all versions compute the same answer")-          defaultMain [ bench "flat" $ whnf (flatNSum . doubleNfl) flatVerts-                      , bench "vinyl" $ whnf (vinylNSum . doubleNvi) vinylVerts-                      , bench "vinyl-lens" $ whnf (vinylNSumL . doubleNviL) vinylVerts+          defaultMain [ bench "flat" $+                        whnf (flatNormSum . doubleNormFlat) flatVerts+                      , bench "vinyl" $+                        whnf (vinylNormSum . doubleNormY) vinylVerts+                      , bench "vinyl-lens" $+                        whnf (vinylNormSumLens . doubleNormYLens) vinylVerts                       , bench "reasonable" $-                        whnf (reasNSum . doubleNre) reasVerts ]+                        whnf (reasNormSum . doubleNormReas) reasVerts ]   where n = 1000  --------------------------------------------------------------------------------@@ -96,11 +99,11 @@                                                        pokeElemOff ptr' 7 nz'     where ptr' = castPtr ptr -flatNSum :: (Num a, Storable a) => V.Vector (TotallyFlat a) -> a-flatNSum = V.sum . V.map (\v -> nx v + ny v + nz v)+flatNormSum :: (Num a, Storable a) => V.Vector (TotallyFlat a) -> a+flatNormSum = V.sum . V.map (\v -> nx v + ny v + nz v) -doubleNfl :: V.Vector (TotallyFlat Float) -> V.Vector (TotallyFlat Float)-doubleNfl = V.map (\v -> v { ny = ny v * 2 })+doubleNormFlat :: V.Vector (TotallyFlat Float) -> V.Vector (TotallyFlat Float)+doubleNormFlat = V.map (\v -> v { ny = ny v * 2 })  -- A more reasonable approach to a vertex record. data Reasonable a = Reasonable { rPos  :: V3 a@@ -121,8 +124,8 @@     where szx = sizeOf (undefined::V3 a)           szy = sizeOf (undefined::V2 a) -reasNSum :: (Num a, Storable a) => V.Vector (Reasonable a) -> a-reasNSum = V.sum . V.map (F.sum . rNorm)+reasNormSum :: (Num a, Storable a) => V.Vector (Reasonable a) -> a+reasNormSum = V.sum . V.map (F.sum . rNorm) -doubleNre :: V.Vector (Reasonable Float) -> V.Vector (Reasonable Float)-doubleNre = V.map (\v -> v { rNorm = (_y *~ 2) $ rNorm v })+doubleNormReas :: V.Vector (Reasonable Float) -> V.Vector (Reasonable Float)+doubleNormReas = V.map (\v -> v { rNorm = (_y *~ 2) $ rNorm v })

@@ -0,0 +1,50 @@+{-# LANGUAGE CPP, DataKinds, FlexibleContexts,+             ScopedTypeVariables, TypeOperators #-}+{-# OPTIONS_GHC -fdefer-type-errors #-}+module CoRecSpec (spec) where+import Control.Monad ((>=>))+import Data.Proxy+import Data.Vinyl+import Data.Vinyl.CoRec+import Data.Vinyl.Functor (Identity(..))++import Test.Hspec+import Test.ShouldNotTypecheck++-- Custom error types+data TooBig = TooBig+data Even = Even+data Not7 = Not7++-- Functions that might return an error value+fun1 :: (TooBig ∈ rs) => Int -> Either (CoRec Identity rs) ()+fun1 x = if x < 10 then Right () else Left (CoRec (pure TooBig))++fun2 :: (Even ∈ rs) => Int -> Either (CoRec Identity rs) ()+fun2 x = if odd x then Right () else Left (CoRec (pure Even))++fun3 :: (Not7 ∈ rs) => Int -> Either (CoRec Identity rs) ()+fun3 x = if x == 7 then Right () else Left (CoRec (pure Not7))++spec :: SpecWith ()+spec = do+  describe "CoRecs" $ do+    let x = CoRec (pure True) :: Field '[Int,Bool,()]+    it "Can be cast successfully" $+      asA (Proxy :: Proxy Bool) x `shouldBe` Just True+    it "Can fail to cast" $+      asA (Proxy :: Proxy Int) x `shouldBe` Nothing+    it "Can be handled all at once" $+      match x (H (\y -> "Int")+               :& H (\y -> "Bool")+               :& H (\y -> "Unit")+               :& RNil) `shouldBe` "Bool"+    it "Can be handled piece by piece, out of order" $+      let handlers = match1 (H (\(u :: ()) -> "unit"))+                     >=> match1 (H (\(b :: Bool) -> "bool "++show b))+                     >=> match1 (H (\(i :: Int) ->  "int "++show i))+      in either id matchNil (handlers x) `shouldBe` "bool True"+    it "Can detect partial pattern matches" $+      let handlers = match1 (H (\(u :: ()) -> "unit"))+                     >=> match1 (H (\(b :: Bool) -> "bool "++show b))+      in shouldNotTypecheck (either id matchNil (handlers x))

@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs, ScopedTypeVariables,+             TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}+import Data.Vinyl+import Data.Vinyl.Functor (Lift(..), Const(..), Compose(..), (:.))+import Test.Hspec++import qualified CoRecSpec as C++-- d1 :: FieldRec '[ '("X",String), '("Y", String) ]+-- d1 = Field @"X" "5" :& Field @"Y" "Hi" :& RNil++-- d2 :: FieldRec '[ '("X", String -> Int), '("Y", String -> String) ]+-- d2 = Field @"X" (read :: String -> Int)+--      :& Field @"Y" (id :: String -> String)+--      :& RNil++d1' :: Rec (Const String) '[ '("X", Int), '("Y", String) ]+d1' = Const "5" :& Const "Hi" :& RNil++d2' :: Rec ((->) String :. ElField) '[ '("X", Int), '("Y", String) ]+d2' = Compose (Field . read) :& Compose (Field . id) :& RNil++d3 :: Rec ElField '[ '("X", Int), '("Y", String) ]+d3 = rmap (\(Compose f) -> Lift (f . getConst)) d2' <<*>> d1'++main :: IO ()+main = hspec $ do+  C.spec+  describe "Rec is like an Applicative" $ do+    it "Can apply parsing functions" $ d3 `shouldBe` Field 5 :& Field "Hi" :& RNil

@@ -1,5 +1,5 @@ name:                vinyl-version:             0.5.3+version:             0.6.0 synopsis:            Extensible Records -- description: license:             MIT@@ -12,8 +12,9 @@ build-type:          Simple cabal-version:       >=1.10 extra-source-files:  CHANGELOG.md+tested-with:         GHC == 7.10.3, GHC == 8.0.2 -description: Extensible records for Haskell with lenses using modern GHC features.+description: Extensible records for Haskell with lenses.  source-repository head   type:     git@@ -23,35 +24,57 @@   exposed-modules:     Data.Vinyl                      , Data.Vinyl.Class.Method                      , Data.Vinyl.Core+                     , Data.Vinyl.CoRec                      , Data.Vinyl.Lens                      , Data.Vinyl.Derived                      , Data.Vinyl.TypeLevel                      , Data.Vinyl.Functor                      , Data.Vinyl.Notation                      , Data.Vinyl.Tutorial.Overview-  build-depends:       base >=4.7 && <= 5, ghc-prim+  build-depends:       base >=4.7 && <= 5,+                       ghc-prim   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 -benchmark bench-builder-all+benchmark storable   type:             exitcode-stdio-1.0   hs-source-dirs:   benchmarks   main-is:          StorableBench.hs-  build-depends:    base >= 4.7 && <= 5, vector, criterion, vinyl >= 0.5.1, mwc-random, lens, linear-  ghc-options:      -O2 -fllvm+  build-depends:    base >= 4.7 && <= 5,+                    vector,+                    criterion,+                    vinyl,+                    mwc-random,+                    lens,+                    linear,+                    primitive+  ghc-options:      -O2+-- -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques   default-language: Haskell2010  benchmark equality   type:             exitcode-stdio-1.0   hs-source-dirs:   benchmarks   main-is:          EqualityBench.hs-  build-depends:    base >= 4.7 && <= 5, criterion, vinyl >= 0.5.1-  ghc-options:      -O2 -fllvm+  build-depends:    base >= 4.7 && <= 5, criterion, vinyl+  ghc-options:      -O2   default-language: Haskell2010  test-suite doctests   type:             exitcode-stdio-1.0   hs-source-dirs:   tests   main-is:          Intro.lhs-  build-depends:    base >= 4.7 && <= 5, lens, vinyl >= 0.5, doctest >= 0.8, singletons >= 0.10+  build-depends:    base >= 4.7 && <= 5, lens, vinyl, doctest >= 0.8, singletons >= 0.10   default-language: Haskell2010++test-suite spec+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Spec.hs+  other-modules:       CoRecSpec+  build-depends:       base+                     , vinyl+                     , hspec >= 2.2.4 && < 2.5+                     , should-not-typecheck >= 2.0 && < 2.2+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010