packages feed

vinyl 0.10.0 → 0.10.0.1

raw patch · 13 files changed

+234/−27 lines, 13 filesdep ~hspec

Dependency ranges changed: hspec

Files

Data/Vinyl.hs view
@@ -14,6 +14,7 @@ import Data.Vinyl.Core import Data.Vinyl.Class.Method (RecMapMethod(..), RecPointed(..)) import Data.Vinyl.Class.Method (rmapMethodF, mapFields)+import Data.Vinyl.Class.Method (rtraverseInMethod, rsequenceInFields) import Data.Vinyl.ARec (ARec, toARec, fromARec) import Data.Vinyl.Derived import Data.Vinyl.FromTuple (record, fieldRec, ruple, xrec, xrecX, xrecTuple)
Data/Vinyl/Class/Method.hs view
@@ -31,6 +31,8 @@   , mapFields   , RecMapMethod1(..)   , RecPointed(..)+  , rtraverseInMethod+  , rsequenceInFields     -- * Support for 'RecMapMethod'   , FieldTyper, ApplyFieldTyper, PayloadType     -- * Eq Functions@@ -54,10 +56,10 @@     -- * Example     -- $example   ) where-+import Data.Functor.Product (Product(Pair)) import Data.Vinyl.Core-import Data.Vinyl.Derived (FieldRec)-import Data.Vinyl.Functor ((:.), ElField(..))+import Data.Vinyl.Derived (KnownField, AllFields, FieldRec, traverseField)+import Data.Vinyl.Functor ((:.), getCompose, ElField(..)) import Data.Vinyl.TypeLevel #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -218,6 +220,28 @@   where g :: c (PayloadType ElField t) => ElField t -> ElField t         g (Field x) = Field (f x) {-# INLINE mapFields #-}++-- | Like 'rtraverseIn', but the function between functors may be+-- constrained.+rtraverseInMethod :: forall c h f g rs.+                     (RMap rs, RPureConstrained c rs, RApply rs)+                  => (forall a. c a => f a -> g (ApplyToField h a))+                  -> Rec f rs+                  -> Rec g (MapTyCon h rs)+rtraverseInMethod f = rtraverseIn @h (withPairedDict @c f)+                    . rzipWith Pair (rpureConstrained @c aux)+  where aux :: c b => DictOnly c b+        aux = DictOnly++-- Note: rtraverseInMethod is written with that `aux` helper in order+-- to work around compatibility with GHC < 8.4. Write it more+-- naturally as `DictOnly @c` does not work with older compilers.++-- | Push an outer layer of interpretation functor into each named field.+rsequenceInFields :: forall f rs. (Functor f, AllFields rs, RMap rs)+                  => Rec (f :. ElField) rs -> Rec ElField (MapTyCon f rs)+rsequenceInFields = rtraverseInMethod @KnownField (traverseField id . getCompose)+  {- $example     This module provides variants of typeclass methods that have
Data/Vinyl/CoRec.hs view
@@ -40,7 +40,7 @@   show x = "(Col " ++ onField @Show show x++")"  instance forall ts. (RecApplicative ts, RecordToList ts,-                     RZipWith ts, ReifyConstraint Eq Maybe ts, RMap ts)+                     RApply ts, ReifyConstraint Eq Maybe ts, RMap ts)   => Eq (CoRec Identity ts) where   crA == crB = and . recordToList              $ rzipWith f (toRec crA) (coRecToRec' crB)@@ -76,10 +76,6 @@ -- | 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)---- | Capture a type class instance dictionary-data DictOnly c a where-  DictOnly :: c a => DictOnly c a  -- | Get a 'DictOnly' from an 'RPureConstrained' instance. getDict :: forall c ts a proxy. (a ∈ ts, RPureConstrained c ts)
Data/Vinyl/Core.hs view
@@ -33,16 +33,18 @@  import Data.Monoid (Monoid) #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup+import Data.Semigroup (Semigroup(..)) #endif import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..))-import Data.Vinyl.Functor+import Data.Functor.Product (Product(Pair)) import Data.List (intercalate)+import Data.Vinyl.Functor import Data.Vinyl.TypeLevel import Data.Type.Equality (TestEquality (..), (:~:) (..)) import Data.Type.Coercion (TestCoercion (..), Coercion (..)) import GHC.Generics+import GHC.Types (Constraint, Type)  -- | A record is parameterized by a universe @u@, an interpretation @f@ and a -- list of rows @rs@.  The labels or indices of the record are given by@@ -88,6 +90,23 @@   -> Rec f (as ++ bs) (<+>) = rappend +-- | Combine two records by combining their fields using the given+-- function. The first argument is a binary operation for combining+-- two values (e.g. '(<>)'), the second argument takes a record field+-- into the type equipped with the desired operation, the third+-- argument takes the combined value back to a result type.+rcombine :: (RMap rs, RApply rs)+         => (forall a. m a -> m a -> m a)+         -> (forall a. f a -> m a)+         -> (forall a. m a -> g a)+         -> Rec f rs+         -> Rec f rs+         -> Rec g rs+rcombine smash toM fromM x y =+  rmap fromM (rapply (rmap (Lift . smash) x') y')+  where x' = rmap toM x+        y' = rmap toM y+ -- | '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@.@@ -169,21 +188,34 @@ rtraverse f (x :& xs) = (:&) <$> f x <*> rtraverse f xs {-# INLINABLE rtraverse #-} +-- | While 'rtraverse' pulls the interpretation functor out of the+-- record, 'rtraverseIn' pushes the interpretation functor in to each+-- field type. This is particularly useful when you wish to discharge+-- that interpretation on a per-field basis. For instance, rather than+-- a @Rec IO '[a,b]@, you may wish to have a @Rec Identity '[IO a, IO+-- b]@ so that you can evaluate a single field to obtain a value of+-- type @Rec Identity '[a, IO b]@.+rtraverseIn :: forall h f g rs.+               (forall a. f a -> g (ApplyToField h a))+            -> Rec f rs+            -> Rec g (MapTyCon h rs)+rtraverseIn _ RNil = RNil+rtraverseIn f (x :& xs) = f x :& rtraverseIn f xs+{-# INLINABLE rtraverseIn #-}++-- | Push an outer layer of interpretation functor into each field.+rsequenceIn :: forall f g (rs :: [Type]). (Traversable f, Applicative g)+            => Rec (f :. g) rs -> Rec g (MapTyCon f rs)+rsequenceIn = rtraverseIn @f (sequenceA . getCompose)+{-# INLINABLE rsequenceIn #-}+ -- | 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.-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 #-}+rzipWith :: (RMap xs, RApply xs)+         => (forall x. f x -> g x -> h x) -> Rec f xs -> Rec g xs -> Rec h xs+rzipWith f = rapply . rmap (Lift . f)  -- | Map each element of a record to a monoid and combine the results. class RFoldMap rs where@@ -252,6 +284,18 @@ instance RPureConstrained c '[] where   rpureConstrained _ = RNil   {-# INLINE rpureConstrained #-}++-- | Capture a type class instance dictionary. See+-- 'Data.Vinyl.Lens.getDict' for a way to obtain a 'DictOnly' value+-- from an 'RPureConstrained' constraint.+data DictOnly (c :: k -> Constraint) a where+  DictOnly :: forall c a. c a => DictOnly c a++-- | A useful technique is to use 'rmap (Pair (DictOnly @MyClass))' on+-- a 'Rec' to pair each field with a type class dictionary for+-- @MyClass@. This helper can then be used to eliminate the original.+withPairedDict :: (c a => f a -> r) -> Product (DictOnly c) f a -> r+withPairedDict f (Pair DictOnly x) = f x  instance (c x, RPureConstrained c xs) => RPureConstrained c (x ': xs) where   rpureConstrained f = f :& rpureConstrained @c @xs f
Data/Vinyl/Derived.hs view
@@ -55,6 +55,12 @@ fieldMap f (Field x) = Field (f x) {-# INLINE fieldMap #-} +-- | Something in the spirit of 'traverse' for 'ElField' whose kind+-- fights the standard library.+traverseField :: (KnownSymbol s, Functor f)+              => (a -> b) -> f (ElField '(s,a)) -> ElField '(s, f b)+traverseField f t = Field (fmap (f . getField)  t)+ -- | Lens for an 'ElField''s data payload. rfield :: Functor f => (a -> f b) -> ElField '(s,a) -> f (ElField '(s,b)) rfield f (Field x) = fmap Field (f x)
Data/Vinyl/FromTuple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}@@ -13,8 +14,14 @@ -- 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.Monoid (First(..))+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup(..))+#endif+import Data.Vinyl.Core (RApply, RMap, RecApplicative, rcombine, rmap, rtraverse, Rec(..))+import Data.Vinyl.Functor (onCompose, Compose(..), getCompose, ElField)+import Data.Vinyl.Lens (RecSubset, RecSubsetFCtx, rcast, rdowncast, type (⊆))+import Data.Vinyl.TypeLevel (RImage, Snd) import Data.Vinyl.XRec (XRec, pattern (::&), pattern XRNil, IsoXRec(..), HKD) import GHC.TypeLits (TypeError, ErrorMessage(Text)) @@ -31,6 +38,7 @@   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])+  TupleToRecArgs f () = '(f , '[])  -- | Apply the 'Rec' type constructor to a type-level tuple of its -- arguments.@@ -83,6 +91,7 @@   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 '[] = HKD f ()   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)@@ -110,6 +119,9 @@ class TupleRec f t where   record :: t -> UncurriedRec (TupleToRecArgs f t) +instance TupleRec f () where+  record () = RNil+ instance TupleRec f (f a, f b) where   record (a,b) = a :& b :& RNil @@ -134,3 +146,26 @@ -- | Build a 'FieldRec' from a tuple of 'ElField' values. fieldRec :: TupleRec ElField t => t -> UncurriedRec (TupleToRecArgs ElField t) fieldRec = record @ElField++-- | Build a 'FieldRec' from a tuple and 'rcast' it to another record+-- type that is a subset of the constructed record. This is useful for+-- re-ordering fields. For example, @namedArgs (#name =: "joe", #age+-- =: 23)@ can supply arguments for a function expecting a record of+-- arguments with its fields in the opposite order.+namedArgs :: (TupleRec ElField t,+              ss ~ Snd (TupleToRecArgs ElField t),+              RecSubset Rec rs (Snd (TupleToRecArgs ElField t)) (RImage rs ss),+              UncurriedRec (TupleToRecArgs ElField t) ~ Rec ElField ss,+              RecSubsetFCtx Rec ElField)+          => t -> Rec ElField rs+namedArgs = rcast . fieldRec++-- | Override a record with fields from a possibly narrower record. A+-- typical use is to supply default values as the first argument, and+-- overrides for those defaults as the second.+withDefaults :: (RMap rs, RApply rs, ss ⊆ rs, RMap ss, RecApplicative rs)+             => Rec f rs -> Rec f ss -> Rec f rs+withDefaults defs = fin . rtraverse getCompose . flip rfirst defs' . rdowncast+  where fin = maybe (error "Impossible: withDefaults failed") id+        defs' = rmap (Compose . Just) defs+        rfirst = rcombine (<>) (onCompose First) (onCompose getFirst)
Data/Vinyl/Functor.hs view
@@ -21,7 +21,7 @@   , Thunk(..)   , Lift(..)   , ElField(..)-  , Compose(..)+  , Compose(..), onCompose   , (:.)   , Const(..)     -- * Discussion@@ -78,6 +78,19 @@ newtype Compose (f :: l -> *) (g :: k -> l) (x :: k)   = Compose { getCompose :: f (g x) }     deriving (Storable, Generic)++instance Semigroup (f (g a)) => Semigroup (Compose f g a) where+  Compose x <> Compose y = Compose (x <> y)++instance Monoid (f (g a)) => Monoid (Compose f g a) where+  mempty = Compose mempty+  mappend (Compose x) (Compose y) = Compose (mappend x y)++-- | Apply a function to a value whose type is the application of the+-- 'Compose' type constructor. This works under the 'Compose' newtype+-- wrapper.+onCompose :: (f (g a) -> h (k a)) -> (f :. g) a -> (h :. k) a+onCompose f = Compose . f . getCompose  type f :. g = Compose f g infixr 9 :.
Data/Vinyl/Lens.hs view
@@ -18,6 +18,7 @@   , RElem   , RecSubset(..)   , rsubset, rcast, rreplace+  , rdowncast   , RSubset   , REquivalent   , type (∈)@@ -198,6 +199,13 @@             (RecSubset record rs ss is, RecSubsetFCtx record f)          => record f rs -> record f ss -> record f ss rreplace = rreplaceC++-- | Takes a smaller record to a larger one, a /downcast/, by layering a+-- 'Maybe' interpretation that lets us use 'Nothing' for the fields+-- not present in the smaller record.+rdowncast :: (RecApplicative ss, RMap rs, rs ⊆ ss)+              => Rec f rs -> Rec (Maybe :. f) ss+rdowncast = flip rreplace (rpure (Compose Nothing)) . rmap (Compose . Just)  type RSubset = RecSubset Rec
Data/Vinyl/TypeLevel.hs view
@@ -9,11 +9,13 @@ {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators         #-}  module Data.Vinyl.TypeLevel where  import GHC.Exts+import GHC.Types (Type)  -- | A mere approximation of the natural numbers. And their image as lifted by -- @-XDataKinds@ corresponds to the actual natural numbers.@@ -100,3 +102,16 @@ type family AllAllSat cs ts :: Constraint where   AllAllSat cs '[] = ()   AllAllSat cs (t ': ts) = (AllSatisfied cs t, AllAllSat cs ts)++-- | Apply a type constructor to a record index. Record indexes are+-- either 'Type' or @('Symbol', 'Type')@. In the latter case, the type+-- constructor is applied to the second component of the tuple.+type family ApplyToField (t :: Type -> Type) (a :: k1) = (r :: k1) | r -> t a where+  ApplyToField t '(s,x) = '(s, t x)+  ApplyToField t x = t x++-- | Apply a type constructor to each element of a type level list+-- using 'ApplyOn'.+type family MapTyCon t xs = r | r -> xs where+  MapTyCon t '[] = '[]+  MapTyCon t (x ': xs) = ApplyToField t x ': MapTyCon t xs
Data/Vinyl/XRec.hs view
@@ -29,6 +29,8 @@ module Data.Vinyl.XRec where import Data.Vinyl.Core (Rec(..)) import Data.Vinyl.Functor+import Data.Vinyl.Lens (RecElem, RecElemFCtx, rgetC)+import Data.Vinyl.TypeLevel (RIndex) import Data.Monoid import GHC.TypeLits (KnownSymbol) @@ -181,3 +183,19 @@   type HKD Product a = a   unHKD = Product   toHKD (Product x) = x++-- | Record field getter that pipes the field value through 'HKD' to+-- eliminate redundant newtype wrappings. Usage will typically involve+-- a visible type application to the field type. The definition is+-- similar to, @getHKD = toHKD . rget@.+rgetX :: forall a record f rs.+         (RecElem record a a rs rs (RIndex a rs),+          RecElemFCtx record f,+          IsoHKD f a)+      => record f rs -> HKD f a+rgetX = toHKD . rgetAux @a+  where rgetAux :: forall r.+                   (RecElem record r r rs rs (RIndex r rs),+                    RecElemFCtx record f)+                => record f rs -> f r+        rgetAux = rgetC
tests/Spec.hs view
@@ -9,6 +9,7 @@ import Data.Vinyl.Syntax ()  import qualified CoRecSpec as C+import qualified XRecSpec as X  -- d1 :: FieldRec '[ '("X",String), '("Y", String) ] -- d1 = Field @"X" "5" :& Field @"Y" "Hi" :& RNil@@ -30,6 +31,7 @@ main :: IO () main = hspec $ do   C.spec+  X.spec   describe "Rec is like an Applicative" $ do     it "Can apply parsing functions" $ d3 `shouldBe` Field 5 :& Field "Hi" :& RNil   describe "Fields may be accessed by overloaded labels" $ do
+ tests/XRecSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedLabels,+             TypeApplications, TypeOperators, ViewPatterns #-}+module XRecSpec (spec) where+import Data.Vinyl+import Data.Vinyl.FromTuple (namedArgs, ruple, xrec, fieldRec, withDefaults)+import Data.Vinyl.Functor ((:.))+import Data.Vinyl.XRec (rgetX)+import Test.Hspec (SpecWith, describe, it, shouldBe)++-- | A function that takes named parameters.+foo :: FieldRec '["name" ::: String, "age" ::: Int] -> Int+foo (ruple -> (name, age)) = length name + age++-- | Like 'foo', but has default values for each parameter.+foo' :: (RMap ss, ss ⊆ '["name" ::: String, "age" ::: Int])+     => Rec ElField ss -> Int+foo' = foo . withDefaults defs+  where defs = fieldRec (#name =: "roberta", #age =: (48 :: Int))++spec :: SpecWith ()+spec = do+  describe "Named Arguments" $ do+    it "Can re-order arguments" $+      foo (namedArgs (#age =: (23 :: Int), #name =: "Joe")) `shouldBe` 26+    it "Can pass too many arguments" $+      foo (namedArgs ( #age =: (23 :: Int)+                     , #isAwesome =: True+                     , #name =: "Cheryl"))+      `shouldBe` 29++  describe "Default arguments" $ do+    it "Can take zero arguments" $+      foo' (fieldRec ()) `shouldBe` 55+    it "Can take a subset of named arguments (1)" $+      foo' (#age =:= (39::Int)) `shouldBe` 46+    it "Can take a subset of named arguments (2)" $+      foo' (#name =:= "Jerome") `shouldBe` 54+    it "Can take all arguments" $+      foo' (fieldRec (#age =: (36::Int), #name =: "Jerome")) `shouldBe` 42++  describe "Can get fields through HKD" $ do+    let myRec :: Rec (Maybe :. ElField) ["name" ::: String, "age" ::: Int]+        myRec = xrec (Just "joe", Just 23)+    it "Can eliminate Compose newtype wrappers" $ do+      rgetX @("age" ::: Int) myRec `shouldBe` Just 23
vinyl.cabal view
@@ -1,5 +1,5 @@ name:                vinyl-version:             0.10.0+version:             0.10.0.1 synopsis:            Extensible Records -- description: license:             MIT@@ -105,11 +105,11 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      tests   main-is:             Spec.hs-  other-modules:       CoRecSpec+  other-modules:       CoRecSpec XRecSpec   build-depends:       base                      , vinyl                      , microlens-                     , hspec >= 2.2.4 && < 2.6+                     , hspec >= 2.2.4 && < 2.7                      , should-not-typecheck >= 2.0 && < 2.2   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010