diff --git a/Data/Vinyl/Classes.hs b/Data/Vinyl/Classes.hs --- a/Data/Vinyl/Classes.hs +++ b/Data/Vinyl/Classes.hs @@ -1,6 +1,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} module Data.Vinyl.Classes where diff --git a/Data/Vinyl/Lens.hs b/Data/Vinyl/Lens.hs --- a/Data/Vinyl/Lens.hs +++ b/Data/Vinyl/Lens.hs @@ -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 + diff --git a/Data/Vinyl/Rec.hs b/Data/Vinyl/Rec.hs --- a/Data/Vinyl/Rec.hs +++ b/Data/Vinyl/Rec.hs @@ -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 #-} diff --git a/Data/Vinyl/Relation.hs b/Data/Vinyl/Relation.hs --- a/Data/Vinyl/Relation.hs +++ b/Data/Vinyl/Relation.hs @@ -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 diff --git a/Data/Vinyl/Validation.hs b/Data/Vinyl/Validation.hs --- a/Data/Vinyl/Validation.hs +++ b/Data/Vinyl/Validation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} module Data.Vinyl.Validation where diff --git a/Data/Vinyl/Witnesses.hs b/Data/Vinyl/Witnesses.hs --- a/Data/Vinyl/Witnesses.hs +++ b/Data/Vinyl/Witnesses.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} module Data.Vinyl.Witnesses where diff --git a/benchmarks/StorableBench.hs b/benchmarks/StorableBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/StorableBench.hs @@ -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 }) diff --git a/tests/Intro.lhs b/tests/Intro.lhs new file mode 100644 --- /dev/null +++ b/tests/Intro.lhs @@ -0,0 +1,267 @@ +This introduction was originally published at + + +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 [ ] 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"] diff --git a/vinyl.cabal b/vinyl.cabal --- a/vinyl.cabal +++ b/vinyl.cabal @@ -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