vinyl 0.1.1.2 → 0.1.3

raw patch · 9 files changed

+485/−20 lines, 9 filesdep +criteriondep +doctestdep +lineardep ~basedep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, doctest, linear, mwc-random, vector, vinyl

Dependency ranges changed: base, lens

API changes (from Hackage documentation)

Files

• Data/Vinyl/Classes.hs +1/−0
• Data/Vinyl/Lens.hs +52/−8
• Data/Vinyl/Rec.hs +22/−1
• Data/Vinyl/Relation.hs +1/−1
• Data/Vinyl/Validation.hs +1/−0
• Data/Vinyl/Witnesses.hs +1/−0
• benchmarks/StorableBench.hs +117/−0
• tests/Intro.lhs +267/−0
• vinyl.cabal +23/−10

@@ -1,6 +1,7 @@ {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE Safe                  #-} {-# LANGUAGE TypeOperators         #-}  module Data.Vinyl.Classes where

@@ -4,6 +4,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE ScopedTypeVariables       #-}  module Data.Vinyl.Lens   ( module Control.Lens@@ -12,6 +13,8 @@   , rGet   , rPut   , rMod+  , RLens'+  , rLens'   ) where  import           Data.Vinyl.Field@@ -21,20 +24,61 @@ import           Control.Lens import           Control.Monad.Identity -type RLens sy t = IElem (sy ::: t) rs => SimpleLens (PlainRec rs) t+type RLens sy t = IElem (sy ::: t) rs => Lens' (PlainRec rs) t+type RLens' f sy t = IElem (sy ::: t) rs => Lens' (Rec rs f) (f t) +-- | Generates a lens for a record in the 'Identity' functor. rLens :: (sy ::: t) -> RLens sy t-rLens f = rLens' f implicitly+rLens f = rLens' f . lens runIdentity (const Identity)+{-# INLINE rLens #-} +-- | Generates a lens of a record in an arbitrary functor.+rLens' :: (sy ::: t) -> RLens' f sy t+rLens' f = rLensAux f implicitly+{-# INLINE rLens' #-}+ rGet = view . rLens+{-# INLINE rGet #-}  rPut = set . rLens+{-# INLINE rPut #-}+ rMod = over . rLens+{-# INLINE rMod #-} --- Records have lenses-rLens' :: (r ~ (sy ::: t)) => r -> Elem r rs -> SimpleLens (PlainRec rs) t-rLens' _ Here = lens (\(x :& xs) -> runIdentity x) (\(_ :& xs) x -> Identity x :& xs)-rLens' f (There p) = rLensPrepend $ rLens' f p+-- We manually unroll several levels of record traversal via 'Elem'+-- values to help GHC eliminate the 'Implicit' dictionaries at+-- runtime. -rLensPrepend :: SimpleLens (PlainRec rs) t -> SimpleLens (PlainRec (l ': rs)) t-rLensPrepend l = lens (\(x :& xs) -> view l xs) (\(a :& xs) x -> a :& (set l x xs))+{-# INLINE rLensAux #-}+rLensAux :: forall f r sy t rs. (r ~ (sy ::: t))+         => r -> Elem r rs -> Lens' (Rec rs f) (f t)+rLensAux _ = go+  where goHere :: Elem r rs' -> Lens' (Rec rs' f) (f t)+        goHere Here = lens (\(x :& _) -> x) (\(_ :& xs) x -> x :& xs)+        goHere _ = error "Unintended base case invocation"++        go :: Elem r rs' -> Lens' (Rec rs' f) (f t)+        go Here = goHere Here+        go (There Here) = rLensPrepend $ goHere Here+        go (There (There Here)) = rLensPrepend $ rLensPrepend $ goHere Here+        go (There (There (There Here))) =+          rLensPrepend $ rLensPrepend $ rLensPrepend $ goHere Here+        go (There (There (There (There Here)))) =+          rLensPrepend $ rLensPrepend $ rLensPrepend $ rLensPrepend $ goHere Here+        go (There (There (There (There p)))) =+          rLensPrepend $ rLensPrepend $ rLensPrepend $ rLensPrepend $ go' p+        {-# INLINE go #-}++        go' :: Elem r rs' -> Lens' (Rec rs' f) (f t)+        go' Here = goHere Here+        go' (There p) = rLensPrepend $ go p+        {-# INLINABLE go' #-}++rLensPrepend :: Lens' (Rec rs f) (f t) -> Lens' (Rec (l ': rs) f) (f t)+rLensPrepend l = lens (\(_ :& xs) -> view l xs) (\(a :& xs) x -> a :& (set l x xs))+{-# INLINE rLensPrepend #-}++-- rLens' _ Here = lens (\(x :& xs) -> runIdentity x) (\(_ :& xs) x -> Identity x :& xs)+-- rLens' f (There p) = rLensPrepend $ rLens' f p+

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns              #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE FlexibleContexts          #-}@@ -24,8 +25,9 @@ import           Data.Vinyl.Classes import           Control.Applicative import           Control.Monad.Identity-import           Data.Monoid import           Data.Vinyl.Field+import           Foreign.Ptr (castPtr, plusPtr)+import           Foreign.Storable (Storable(..)) import           GHC.TypeLits  -- | A record is parameterized by a list of fields and a functor@@ -83,3 +85,22 @@ -- | We provide a 'Show' instance for 'Identity'. instance Show a => Show (Identity a) where   show (Identity x) = show x++instance Storable (PlainRec '[]) where+  sizeOf _    = 0+  alignment _ = 0+  peek _      = return RNil+  poke _ RNil = return ()++instance (Storable t, Storable (PlainRec rs)) => Storable (PlainRec ((sy:::t) ': rs)) where+  sizeOf _ = sizeOf (undefined :: t) + sizeOf (undefined :: PlainRec rs)+  {-# INLINABLE sizeOf #-}+  alignment _ =  alignment (undefined :: t)+  {-# INLINABLE alignment #-}+  peek ptr = do !x <- peek (castPtr ptr)+                !xs <- peek (ptr `plusPtr` sizeOf (undefined :: t))+                return $ Identity x :& xs+  {-# INLINABLE peek #-}+  poke ptr (Identity !x :& xs) = poke (castPtr ptr) x >>+                                 poke (ptr `plusPtr` sizeOf (undefined :: t)) xs+  {-# INLINEABLE poke #-}

@@ -53,6 +53,6 @@ lookupField Here      (_ :& _)  = Field lookupField (There p) (_ :& xs) = lookupField p xs -rIso :: (r1 :~: r2) => SimpleIso r1 r2+rIso :: (r1 :~: r2) => Iso' r1 r2 rIso = iso cast cast 

@@ -1,3 +1,4 @@+{-# LANGUAGE Safe         #-} {-# LANGUAGE TypeOperators #-}  module Data.Vinyl.Validation where

@@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE Safe                  #-} {-# LANGUAGE TypeOperators         #-}  module Data.Vinyl.Witnesses where

@@ -0,0 +1,117 @@+{-# LANGUAGE DataKinds, 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+-- coordinate of each point's normal vector by 2, then sum all normal+-- vector coordinates over all vertices. This calculation is performed+-- 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 qualified Data.Foldable as F+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as VM+import Data.Vinyl+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import Linear (V2, V3, _y)+import System.Random.MWC (withSystemRandom, Variate(..), GenIO)+import Criterion.Main++randVec :: (Storable a, Variate a) => Int -> GenIO -> IO (V.Vector a)+randVec n g = VM.replicateM n (uniform g) >>=+              V.unsafeFreeze++randVecStd :: (Storable a, Variate a) => Int -> IO (V.Vector a)+randVecStd = withSystemRandom . randVec++vNorm :: "normal" ::: V3 a+vNorm = Field++type MyFields a = [ "pos" ::: V3 a, "tex" ::: V2 a, "normal" ::: V3 a ]+type MyVertex a = PlainRec (MyFields a)++doubleNvi :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)+doubleNvi = V.map (rLens vNorm . _y *~ (2::Float))++vinylNSum :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNSum = V.sum . V.map (F.sum . view (rLens vNorm))++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+          putStrLn $ "Sanity: " ++ show (vinylNSum $ doubleNvi vinylVerts)+                     ++ " ==? " +++                     show (flatNSum $ doubleNfl flatVerts)+                     ++ " ==? " +++                     show (reasNSum $ doubleNre reasVerts)+          defaultMain [ bench "flat" $ whnf (flatNSum . doubleNfl) flatVerts+                      , bench "vinyl" $ whnf (vinylNSum . doubleNvi) vinylVerts+                      , bench "reasonable" $+                        whnf (reasNSum . doubleNre) reasVerts ]+  where n = 1000++--------------------------------------------------------------------------------+-- Baseline data structures for comparison++-- Don't trust data structures at all? Use a flat record where only+-- the field prefixes denote their roles.+data TotallyFlat a = Flat { px :: !a+                          , py :: !a+                          , pz :: !a+                          , tu :: !a+                          , tv :: !a+                          , nx :: !a+                          , ny :: !a+                          , nz :: !a }++instance Storable a => Storable (TotallyFlat a) where+  sizeOf _ = sizeOf (undefined::a) * 8+  alignment _ = alignment (undefined::a)+  peek ptr = Flat <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2+                  <*> peekElemOff ptr' 3 <*> peekElemOff ptr' 4+                  <*> peekElemOff ptr' 5 <*> peekElemOff ptr' 6+                  <*> peekElemOff ptr' 7+    where ptr' = castPtr ptr+  poke ptr (Flat px' py' pz' tu' tv' nx' ny' nz') = do poke ptr' px'+                                                       pokeElemOff ptr' 1 py'+                                                       pokeElemOff ptr' 2 pz'+                                                       pokeElemOff ptr' 3 tu'+                                                       pokeElemOff ptr' 4 tv'+                                                       pokeElemOff ptr' 5 nx'+                                                       pokeElemOff ptr' 6 ny'+                                                       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)++doubleNfl :: V.Vector (TotallyFlat Float) -> V.Vector (TotallyFlat Float)+doubleNfl = V.map (\v -> v { ny = ny v * 2 })++-- A more reasonable approach to a vertex record.+data Reasonable a = Reasonable { rPos  :: V3 a+                               , rTex  :: V2 a+                               , rNorm :: V3 a }++instance Storable a => Storable (Reasonable a) where+  sizeOf _ = sizeOf (undefined::V3 a)*2 + sizeOf (undefined::V2 a)+  alignment _ = alignment (undefined::V3 a)+  peek ptr = Reasonable <$> peek (castPtr ptr)+                        <*> peekByteOff (castPtr ptr) szx+                        <*> peekByteOff (castPtr ptr) (szx + szy)+    where szx = sizeOf (undefined::V3 a)+          szy = sizeOf (undefined::V2 a)+  poke ptr (Reasonable p t n) = do poke (castPtr ptr) p+                                   pokeByteOff (castPtr ptr) szx t+                                   pokeByteOff (castPtr ptr) (szx + szy) n+    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)++doubleNre :: V.Vector (Reasonable Float) -> V.Vector (Reasonable Float)+doubleNre = V.map (\v -> v { rNorm = (_y *~ 2) $ rNorm v })

@@ -0,0 +1,267 @@+This introduction was originally published at+<http://www.jonmsterling.com/posts/2013-04-06-vinyl-modern-records-for-haskell.html>++Vinyl: Modern Records for Haskell+=================================++Vinyl is a general solution to the records problem in Haskell using+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.++First, install Vinyl from Hackage:++< cabal update+< cabal install vinyl++Let’s work through a quick example. We’ll need to enable some language+extensions first:++> {-# LANGUAGE DataKinds, TypeOperators #-}+> {-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+> {-# LANGUAGE GADTs #-}+> import Data.Vinyl+> import Data.Vinyl.Unicode+> import Data.Vinyl.Validation+> import Control.Applicative+> import Control.Monad.Identity+> import Data.Char+> import Test.DocTest++Let’s define the fields we want to use:++> name     = Field :: "name"     ::: String+> age      = Field :: "age"      ::: Int+> sleeping = Field :: "sleeping" ::: Bool++Now, let’s try to make an entity that represents a man:++> jon = name =: "jon"+>    <+> age =: 20+>    <+> sleeping =: False++We could make an alias for the sort of entity that jon is:++> type LifeForm = ["name" ::: String, "age" ::: Int, "sleeping" ::: Bool]+> jon :: PlainRec LifeForm++The types are inferred, though, so this is unnecessary unless you’d+like to reuse the type later. Now, make a dog! Dogs are life-forms,+but unlike men, they have masters. So, let’s build my dog:++> master = Field :: "master" ::: PlainRec LifeForm+> tucker = name =: "tucker"+>       <+> age =: 7+>       <+> sleeping =: True+>       <+> master =: jon++Using Lenses+------------++Now, if we want to wake entities up, we don’t want to have to write a+separate wake-up function for both dogs and men (even though they are+of different type). Luckily, we can use the built-in lenses to focus+on a particular field in the record for access and update, without+losing additional information:++> wakeUp :: (("sleeping" ::: Bool) ∈ fields) => PlainRec fields -> PlainRec fields+> wakeUp = sleeping `rPut` False++Now, the type annotation on wakeUp was not necessary; I just wanted to+show how intuitive the type is. Basically, it takes as an input any+record that has a `Bool` field labelled `sleeping`, and modifies that+specific field in the record accordingly.++> tucker' = wakeUp tucker+> jon' = wakeUp jon++> -- |+> -- >>> tucker' ^. rLens sleeping+> -- False+> -- +> -- >>> tucker ^. rLens sleeping+> -- True+> --+> -- >>> jon' ^. rLens 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 :: (("master" ::: PlainRec LifeForm) ∈ fields) => Lens' (PlainRec fields) Bool+> masterSleeping = rLens master . rLens sleeping+> tucker'' = masterSleeping .~ True $ tucker'++> -- | >>> tucker'' ^. rLens master . rLens sleeping+> -- True++Again, the type annotation is unnecessary. In fact, the seperate+definition is also unnecessary, and we could just define:++> tucker''' = rLens master . rLens sleeping .~ True $ tucker'++> -- | >>> tucker''' ^. rLens master . rLens sleeping+> -- True++Subtyping Relation and Coercion+-------------------------------++A record `PlainRec xs` is a subtype of a record `PlainRec ys` if `ys ⊆ xs`;+that is to say, if one record can do everything that another record+can, the former is a subtype of the latter. As such, we should be able+to provide an upcast operator which “forgets” whatever makes one+record different from another (whether it be extra data, or different+order).++Therefore, the following works:++> upcastedTucker :: PlainRec LifeForm+> upcastedTucker = cast (fixRecord tucker)++The reason for using `fixRecord` will become clear a bit later.++The subtyping relationship between record types is expressed with the+`(<:)` constraint; so, cast is of the following type:++< cast :: r1 <: r2 => r1 -> r2++Also provided is a `(≅)` constraint which indicates record congruence+(that is, two record types differ only in the order of their fields).++Records are polymorphic over functors+-------------------------------------++So far, we’ve been working with the PlainRec type; but below that,+there is something a bit more advanced called Rec, which looks like+this:++< data Rec :: [*] -> (* -> *) -> * where+<   RNil :: Rec '[] f+<   (:&) :: (r ~ (sy ::: t)) => f t -> Rec rs f -> Rec (r ': rs) f++The second parameter is a functor, in which every element of the+record will be placed. In `PlainRec`, the functor is just set to+`Identity`. Let’s try and motivate this stuff with an example.++Let’s imagine that we want to do validation on a record that+represents a name and an age:++> type Person = ["name" ::: String, "age" ::: Int]++We’ve decided that names must be alphabetic, and ages must be+positive. For validation, we’ll use a type that’s included here called+`Result e a`, which is similar to `Either`, except that its+`Applicative` instance accumulates monoidal errors on the left.++> goodPerson :: PlainRec Person+> goodPerson = name =: "Jon"+>          <+> age =: 20+> badPerson = name =: "J#@#$on"+>          <+> age =: 20+> validatePerson :: PlainRec Person -> Result [String] (PlainRec Person)+> validatePerson p = (\n a -> name =: n <+> age =: a) <$> vName <*> vAge where+>   vName = validateName (rGet name p)+>   vAge  = validateAge  (rGet age p)+> +>   validateName str | all isAlpha str = Success str+>   validateName _ = Failure [ "name must be alphabetic" ]+>   validateAge i | i >= 0 = Success i+>   validateAge _ = Failure [ "age must be positive" ]++> -- $setup+> -- >>> let isSuccess (Success _) = True; isSuccess _ = False++> -- |+> -- >>> isSuccess $ validatePerson goodPerson+> -- True+> --+> -- >>> isSuccess $ validatePerson badPerson+> -- False++The results are as expected (`Success` for `goodPerson`, and a+`Failure` with one error for `badPerson`); but this was not very fun+to build.++Further, it would be nice to have some notion of a partial record;+that is, if part of it can’t be validated, it would still be nice to+be able to access the rest. What if we could make a version of this+record where the elements themselves were validation functions, and+then that record could be applied to a plain one, to get a record of+validated fields? That’s what we’re going to do.++Vinyl provides a type of validators, which is basically a natural+transformation from the `Identity` functor to the `Result` functor, which+we just used above.++< type Validator e = Identity ~> Result e++Let’s parameterize a record by it: when we do, then an element of type+`a` should be a function `Identity a -> Result e a`:++> vperson :: Rec Person (Validator [String])+> vperson = NT validateName :& NT validateAge :& RNil where+>    validateName (Identity str) | all isAlpha str = Success str+>    validateName _ = Failure [ "name must be alphabetic" ]+>    validateAge (Identity i) | i >= 0 = Success i+>    validateAge _ = Failure [ "age must be positive" ]++And we can use the special application operator `<<*>>` (which is+analogous to `<*>`, but generalized a bit) to use this to validate a+record:++> goodPersonResult = vperson <<*>> goodPerson+> badPersonResult  = vperson <<*>> badPerson++goodPersonResult === name :=: Success "Jon", age :=: Success 20, {}+badPersonResult  === name :=: Failure ["name must be alphabetic"], age :=: Success 20, {}++> -- |+> -- >>> isSuccess $ goodPersonResult ^. rLens' name+> -- True+> -- >>> isSuccess $ goodPersonResult ^. rLens' age+> -- True+> -- >>> isSuccess $ badPersonResult ^. rLens' name+> -- False+> -- >>> isSuccess $ badPersonResult ^. rLens' age+> -- True++So now we have a partial record, and we can still do stuff with its+contents. Next, we can even recover the original behavior of the+validator (that is, to give us a value of type `Result [String]+(PlainRec Person)`) using run:++> runGoodPerson = run goodPersonResult+> runBadPerson  = run badPersonResult++`runGoodPerson === Success name :=: "Jon", age :=: 20, {}`+`runBadPerson  === Failure ["name must be alphabetic"]``++> -- |+> -- >>> isSuccess runGoodPerson+> -- True+> -- >>> isSuccess runBadPerson+> -- False++Fixing a polymorphic record into the Identity Functor+-----------------------------------------------------++If you produced a record using `(=:)` and `(<+>)` without providing a+type annotation, then its type is something like this:++< record :: Applicative f => Record [ <bunch of stuff> ] f++The problem is then we can’t do anything with the record that requires+us to know what its functor is. For instance, `cast` will fail. So, we+might try to provide a type annotation, but that can be a bit brittle+and frustrating to have to do. To alleviate this problem, `fixRecord` is+provided:++< fixRecord :: (forall f. Applicative f => Rec rs f) -> PlainRec rs++---++(We must define a main value for doctest to run.)++> main :: IO ()+> main = doctest ["tests/Intro.lhs"]

@@ -1,8 +1,5 @@--- Initial vinyl.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/- name:                vinyl-version:             0.1.1.2+version:             0.1.3 synopsis:            Extensible Records -- description: license:             MIT@@ -13,17 +10,33 @@ category:            Records stability:           Experimental build-type:          Simple-cabal-version:       >=1.8+cabal-version:       >=1.10  description: Extensible records for Haskell with lenses using modern GHC features. - source-repository head   type:     git   location: https://github.com/jonsterling/Vinyl/ - library-  exposed-modules:     Data.Vinyl, Data.Vinyl.Field, Data.Vinyl.Lens, Data.Vinyl.Witnesses, Data.Vinyl.Rec, Data.Vinyl.Relation, Data.Vinyl.Unicode, Data.Vinyl.Classes, Data.Vinyl.Validation-  -- other-modules:-  build-depends:       base ==4.6.*, lens >=3.0, ghc-prim, mtl+  exposed-modules:     Data.Vinyl, Data.Vinyl.Field, Data.Vinyl.Lens,+                       Data.Vinyl.Witnesses, Data.Vinyl.Rec,+                       Data.Vinyl.Relation, Data.Vinyl.Unicode,+                       Data.Vinyl.Classes, Data.Vinyl.Validation+  build-depends:       base ==4.6.*, lens >=3.8, ghc-prim, mtl+  default-language:    Haskell2010++benchmark bench-builder-all+  type:             exitcode-stdio-1.0+  hs-source-dirs:   benchmarks+  main-is:          StorableBench.hs+  build-depends:    base, vector, criterion, vinyl, mwc-random, linear+  ghc-options:      -O2 -fllvm+  default-language: Haskell2010                            ++test-suite doctests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   tests+  main-is:          Intro.lhs+  build-depends:    base, mtl, vinyl, doctest >= 0.8+  default-language: Haskell2010