packages feed

vinyl 0.1.3 → 0.2

raw patch · 11 files changed

+158/−114 lines, 11 filesdep +transformersdep −mtldep ~basedep ~lens

Dependencies added: transformers

Dependencies removed: mtl

Dependency ranges changed: base, lens

Files

Data/Vinyl.hs view
@@ -4,7 +4,7 @@   , module Data.Vinyl.Field   , module Data.Vinyl.Rec   , module Data.Vinyl.Relation-  , module Data.Vinyl.Classes,+  , module Data.Vinyl.Classes   ) where  import           Data.Vinyl.Classes
Data/Vinyl/Classes.hs view
@@ -1,22 +1,25 @@ {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE Safe                  #-} {-# LANGUAGE TypeOperators         #-}  module Data.Vinyl.Classes where  import           Control.Applicative-import           Control.Monad.Identity+import           Data.Functor.Identity  -- | This class is a generalized, but non-pointed version of 'Applicative'. This -- is useful for types which range over functors rather than sets. class Apply (arr :: k -> k -> k) (f :: k -> *) where   (<<*>>) :: f (arr a b) -> f a -> f b --- | To accumulate effects distributed over a data type, you 'run' it.-class Run t where-  run :: Applicative f => t f -> f (t Identity)+-- | To accumulate effects distributed over a data type, you 'dist' it.+class Dist t where+  dist :: Applicative f => t f -> f (t Identity)++-- | If a record is homogenous, you can fold over it.+class FoldRec r a where+  foldRec :: (a -> b -> b) -> b -> r -> b  -- | '(~>)' is a morphism between functors. newtype (f ~> g) x = NT { runNT :: f x -> g x }
Data/Vinyl/Field.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE KindSignatures      #-}@@ -7,11 +8,19 @@  module Data.Vinyl.Field where +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+import           Data.Proxy+#endif import           GHC.TypeLits  -- | A field contains a key and a type. data (:::) :: Symbol -> * -> * where   Field :: sy ::: t +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+instance KnownSymbol sy => Show (sy ::: t) where+  show Field = symbolVal (Proxy :: Proxy sy)+#else instance SingI sy => Show (sy ::: t) where   show Field = fromSing (sing :: Sing sy)+#endif
Data/Vinyl/Lens.hs view
@@ -1,84 +1,80 @@-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Data.Vinyl.Lens-  ( module Control.Lens-  , RLens-  , rLens-  , rGet-  , rPut-  , rMod-  , RLens'-  , rLens'-  ) where--import           Data.Vinyl.Field-import           Data.Vinyl.Rec-import           Data.Vinyl.Witnesses--import           Control.Lens-import           Control.Monad.Identity--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 . lens runIdentity (const Identity)-{-# INLINE rLens #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+-- | A small, /en passant/ lens implementation to provide accessors+-- for record fields. Lenses produced with 'rLens' are fully+-- compatible with the @lens@ package.+module Data.Vinyl.Lens where+import Control.Applicative+import Data.Functor.Identity+import Data.Vinyl.Field+import Data.Vinyl.Rec+import Data.Vinyl.Witnesses --- | Generates a lens of a record in an arbitrary functor.-rLens' :: (sy ::: t) -> RLens' f sy t-rLens' f = rLensAux f implicitly-{-# INLINE rLens' #-}+-- | Project a field from a 'Rec'.+rGet' :: IElem (sy ::: t) rs => (sy ::: t) -> Rec rs f -> f t+rGet' r = getConst . rLens' r Const+{-# INLINE rGet' #-} -rGet = view . rLens+-- | Project a field from a 'PlainRec'.+rGet :: IElem (sy ::: t) rs => (sy ::: t) -> PlainRec rs -> t+rGet = (runIdentity .) . rGet' {-# INLINE rGet #-} -rPut = set . rLens+-- | Set a field in a 'Rec' over an arbitrary functor.+rPut' :: IElem (sy ::: t) rs => (sy ::: t) -> f t -> Rec rs f -> Rec rs f+rPut' r x = runIdentity . rLens' r (Identity . const x)+{-# INLINE rPut' #-}++-- | Set a field in a 'PlainRec'.+rPut :: IElem (sy:::t) rs => (sy:::t) -> t -> PlainRec rs -> PlainRec rs+rPut r x = rPut' r (Identity x) {-# INLINE rPut #-} -rMod = over . rLens+-- | Modify a field.+rMod :: (IElem (sy:::t) rs, Functor f)+     => (sy:::t) -> (t -> t) -> Rec rs f -> Rec rs f+rMod r f = runIdentity . rLens' r (Identity . fmap f) {-# INLINE rMod #-} --- We manually unroll several levels of record traversal via 'Elem'--- values to help GHC eliminate the 'Implicit' dictionaries at--- runtime.--{-# 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"+-- We manually unroll several levels of 'Elem' value traversal to help+-- GHC statically index into small records. -        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+-- | Provide a lens to a record field. Note that this implementation+-- does not support polymorphic update. In the parlance of the @lens@+-- package,+--+-- > rLens' :: IElem (sy:::t) rs => (sy:::t) -> Lens' (Rec rs f) (f t)+rLens' :: forall r rs sy t f g. (r ~ (sy:::t), IElem r rs, Functor g)+       => r -> (f t -> g (f t)) -> Rec rs f -> g (Rec rs f)+rLens' _ f = go implicitly+  where go :: Elem r rr -> Rec rr f -> g (Rec rr f)+        go Here (x :& xs) = fmap (:& xs) (f x)+        go (There Here) (a :& x :& xs) = fmap ((a :&) . (:& xs)) (f x)+        go (There (There Here)) (a :& b :& x :& xs) =+          fmap (\x' -> a :& b :& x' :& xs) (f x)+        go (There (There (There Here))) (a :& b :& c :& x :& xs) =+          fmap (\x' -> a :& b :& c :& x' :& xs) (f x)+        go (There (There (There (There Here)))) (a :& b :& c :& d :& x :& xs) =+          fmap (\x' -> a :& b :& c :& d :& x' :& xs) (f x)+        go (There (There (There (There p)))) (a :& b :& c :& d :& xs) =+          fmap (\xs' -> a :& b :& c :& d :& xs') (go' p xs)         {-# INLINE go #-} -        go' :: Elem r rs' -> Lens' (Rec rs' f) (f t)-        go' Here = goHere Here-        go' (There p) = rLensPrepend $ go p+        go' :: Elem r rr -> Rec rr f -> g (Rec rr f)+        go' Here (x :& xs) = fmap (:& xs) (f x)+        go' (There p) (x :& xs) = fmap (x :&) (go p xs)         {-# 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+{-# INLINE rLens' #-} +-- | A lens into a 'PlainRec' that smoothly interoperates with lenses+-- from the @lens@ package. Note that polymorphic update is not+-- supported. In the parlance of the @lens@ package,+-- +-- > rLens :: IElem (sy:::t) rs => (sy:::t) -> Lens' (PlainRec rs) t+rLens :: forall r rs sy t g. (r ~ (sy:::t), IElem r rs, Functor g)+      => r -> (t -> g t) -> PlainRec rs -> g (PlainRec rs)+rLens r = rLens' r . lenser runIdentity (const Identity)+  where lenser sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE rLens #-}
Data/Vinyl/Rec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE FlexibleContexts          #-}@@ -19,16 +20,18 @@   , PlainRec   , (=:)   , (<+>)+  , type (++)   , fixRecord   ) where  import           Data.Vinyl.Classes import           Control.Applicative-import           Control.Monad.Identity+import           Data.Functor.Identity import           Data.Vinyl.Field import           Foreign.Ptr (castPtr, plusPtr) import           Foreign.Storable (Storable(..)) import           GHC.TypeLits+import           Data.Monoid  -- | A record is parameterized by a list of fields and a functor -- to be applied to each of those fields.@@ -63,7 +66,13 @@  instance Show (Rec '[] f) where   show RNil = "{}"-instance (SingI sy, Show (g t), Show (Rec fs g)) => Show (Rec ((sy ::: t) ': fs) g) where+instance (+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+    KnownSymbol sy,+#else+    SingI sy,+#endif+    Show (g t), Show (Rec fs g)) => Show (Rec ((sy ::: t) ': fs) g) where   show (x :& xs) = show (Field :: sy ::: t) ++ " :=: " ++ show x ++ ", " ++ show xs  @@ -72,15 +81,34 @@ instance (Eq (g t), Eq (Rec fs g)) => Eq (Rec ((s ::: t) ': fs) g) where   (x :& xs) == (y :& ys) = (x == y) && (xs == ys) ++instance Monoid (Rec '[] f) where+  mempty = RNil+  RNil `mappend` RNil = RNil+instance (Monoid t, Monoid (Rec fs g), Applicative g) => Monoid (Rec ((s ::: t) ': fs) g) where+  mempty = pure mempty :& mempty+  (x :& xs) `mappend` (y :& ys) = liftA2 mappend x y :& (xs `mappend` ys)++ -- | Records can be applied to each other. instance Apply (~>) (Rec rs) where   RNil <<*>> RNil = RNil   (f :& fs) <<*>> (x :& xs) = runNT f x :& (fs <<*>> xs) --- | Records may be 'run' to accumulate the effects of their fields.-instance Run (Rec rs) where-  run RNil      = pure RNil-  run (x :& xs) = (:&) <$> (pure <$> x) <*> run xs+-- | Records may be distributed to accumulate the effects of their fields.+instance Dist (Rec rs) where+  dist RNil      = pure RNil+  dist (x :& xs) = (:&) <$> (pure <$> x) <*> dist xs++instance FoldRec (Rec '[] f) a where+  foldRec _ z RNil = z++instance FoldRec (Rec fs g) (g t) => FoldRec (Rec ((s ::: t) ': fs) g) (g t) where+  foldRec f z (x :& xs) = f x (foldRec f z xs)++-- | Accumulates a homogenous record into a list+recToList :: FoldRec (Rec fs g) (g t) => Rec fs g -> [g t]+recToList = foldRec (\e a -> [e] ++ a) []  -- | We provide a 'Show' instance for 'Identity'. instance Show a => Show (Identity a) where
Data/Vinyl/Relation.hs view
@@ -14,14 +14,13 @@   ( (<:)(..)   , (:~:)   , (~=)-  , rIso+  -- , rIso   ) where  import           Data.Vinyl.Field import           Data.Vinyl.Lens import           Data.Vinyl.Rec import           Data.Vinyl.Witnesses-import           Control.Monad.Identity  import           GHC.Prim             (Constraint) @@ -45,14 +44,14 @@ instance Rec xs f <: Rec '[] f where   cast _ = RNil -instance (y ~ (sy ::: t), IElem y xs, PlainRec xs <: PlainRec ys) => PlainRec xs <: PlainRec (y ': ys) where-  cast r = Identity (rGet field r) :& cast r+instance (y ~ (sy ::: t), IElem y xs, Rec xs f <: Rec ys f) => Rec xs f <: Rec (y ': ys) f where+  cast r = rGet' field r :& cast r     where field = lookupField (implicitly :: Elem y xs) r  lookupField :: Elem x xs -> Rec xs f -> x lookupField Here      (_ :& _)  = Field lookupField (There p) (_ :& xs) = lookupField p xs -rIso :: (r1 :~: r2) => Iso' r1 r2-rIso = iso cast cast+-- rIso :: (r1 :~: r2) => Iso' r1 r2+-- rIso = iso cast cast
Data/Vinyl/Validation.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE Safe         #-} {-# LANGUAGE TypeOperators #-}  module Data.Vinyl.Validation where  import           Control.Applicative-import           Control.Monad.Identity+import           Data.Functor.Identity import           Data.Monoid import           Data.Vinyl.Classes
Data/Vinyl/Witnesses.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE Safe                  #-} {-# LANGUAGE TypeOperators         #-}  module Data.Vinyl.Witnesses where
benchmarks/StorableBench.hs view
@@ -8,6 +8,8 @@ -- 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 import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM@@ -31,24 +33,32 @@ type MyFields a = [ "pos" ::: V3 a, "tex" ::: V2 a, "normal" ::: V3 a ] type MyVertex a = PlainRec (MyFields a) +doubleNviL :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)+doubleNviL = V.map (rLens vNorm . _y *~ (2::Float))++vinylNSumL :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNSumL = V.sum . V.map (F.sum . view (rLens vNorm))+ doubleNvi :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)-doubleNvi = V.map (rLens vNorm . _y *~ (2::Float))+doubleNvi = V.map (rMod vNorm (_y *~ (2::Float)))  vinylNSum :: (Num a, Storable a) => V.Vector (MyVertex a) -> a-vinylNSum = V.sum . V.map (F.sum . view (rLens vNorm))+vinylNSum = V.sum . V.map (F.sum . rGet 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)+              vinylAns = vinylNSum $ doubleNvi vinylVerts+              vinylLans = vinylNSumL $ doubleNviL vinylVerts+              flatAns = flatNSum $ doubleNfl flatVerts+              reasAns = reasNSum $ doubleNre 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                       , bench "reasonable" $                         whnf (reasNSum . doubleNre) reasVerts ]   where n = 1000
tests/Intro.lhs view
@@ -24,7 +24,8 @@ > import Data.Vinyl.Unicode > import Data.Vinyl.Validation > import Control.Applicative-> import Control.Monad.Identity+> import Control.Lens+> import Data.Functor.Identity > import Data.Char > import Test.DocTest @@ -78,7 +79,7 @@ > -- | > -- >>> tucker' ^. rLens sleeping > -- False-> -- +> -- > -- >>> tucker ^. rLens sleeping > -- True > --@@ -163,7 +164,7 @@ > 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@@ -229,18 +230,18 @@ 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:+(PlainRec Person)`) using `dist`: -> runGoodPerson = run goodPersonResult-> runBadPerson  = run badPersonResult+> distGoodPerson = dist goodPersonResult+> distBadPerson  = dist badPersonResult -`runGoodPerson === Success name :=: "Jon", age :=: 20, {}`-`runBadPerson  === Failure ["name must be alphabetic"]``+`distGoodPerson === Success name :=: "Jon", age :=: 20, {}`+`distBadPerson  === Failure ["name must be alphabetic"]``  > -- |-> -- >>> isSuccess runGoodPerson+> -- >>> isSuccess distGoodPerson > -- True-> -- >>> isSuccess runBadPerson+> -- >>> isSuccess distBadPerson > -- False  Fixing a polymorphic record into the Identity Functor
vinyl.cabal view
@@ -1,5 +1,5 @@ name:                vinyl-version:             0.1.3+version:             0.2 synopsis:            Extensible Records -- description: license:             MIT@@ -23,20 +23,20 @@                        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+  build-depends:       base >=4.6 && <= 5, ghc-prim, transformers   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+  build-depends:    base >= 4.6 && <= 5, vector, criterion, vinyl, mwc-random, lens, linear   ghc-options:      -O2 -fllvm-  default-language: Haskell2010                            +  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+  build-depends:    base >= 4.6 && <= 5, lens, transformers, vinyl, doctest >= 0.8   default-language: Haskell2010