packages feed

vinyl 0.5.1 → 0.14.3

raw patch · 33 files changed

Files

CHANGELOG.md view
@@ -1,10 +1,104 @@-0.5.1----------+# 0.14.3+- Compatibility with `lens-aeson` > 1.2 +# 0.14.2+- Export the `ToARec` class++# 0.14.1+- Compatibility with `aeson` > 2.0++# 0.14.0+- `ARec` efficiency improvements (@Philonous)+- Make `ElField` a newtype (@Philonous)++The `ElField` change brings more opportunities for the optimizer, but can result in longer compile times.++# 0.13.3+- Fixed CHANGELOG entry for 0.13.2: it referred to version 0.14.0+- Relax bounds on `hspec`++# 0.13.2+- Removed aput and alens from Data.Vinyl.ARec. They were used internally, but their type is unsound.++# 0.13.1+- GHC 9.0.1 support++# 0.13.0+- GHC 8.10.1 support fix. A fix for the previous attempt at 8.10 support involves a backwards incompatible change.++# 0.12.2++- GHC 8.10.1 support++# 0.12.0++- GHC 8.8.1 support. Class type signatures were changed to remove explicit kind variables. This is to simplify the use of `TypeApplications` which changed with GHC 8.8.1 to require explicit application to those kind variables. Leaving them out of the class definitions preserves existing usage of `TypeApplications`. Thanks to Justin Le (@mstksg).++# 0.11.0++- Changed the `Show` instance of `CoRec`+- Added the `corec` helper that specifically helps type inference when+  constructing `CoRec ElField` values.++# 0.10.0++- Changed the types of `Data.Vinyl.CoRec.onCoRec` and `Data.Vinyl.CoRec.onField`. This was pushing through the changes to drop the use of `Proxy` arguments, relying instead on `TypeApplications`. Also added `onCoRec1` and `onField` to work with functions relying on a single type class.++- Faster `asA` and `asA'`. These implementations utilize `unsafeCoerce` in their implementations after we have performed a runtime check that proves (to us) that the types match up. The old implementations are still available as `asASafe` and `asA'Safe`. While both implementations can run in constant time if the compiler optimizes everything successfully, the faster variants are a bit more than 3x faster in a trivial benchmark.++- Add a `Generic` instance for `Rec` and common functors.++- Add a variety of `ToJSON` implementations as a test case. One or all of these should probably exist as a separate package to avoid `vinyl` depending on `aeson`, but their content may be of interest.++# 0.9.2++- Add `runcurryX` for applying an uncurried function to a `Rec` passing through the `XRec` machinery to strip out syntactic noise.++# 0.9.0++- A new `SRec` type for constant time field access for records with densely packed `Storable` fields. Conversion from `Rec` is accomplished with `toSRec`, while `fromSRec` takes you back to `Rec`. Record updates are fairly slow compared to native Haskell records and even `Rec`, but reading a field is as fast as anything.++- Concise record construction syntax from tuples. Construct a `FieldRec` with `fieldRec (#x =: True, #y =: 'b')` and have the type inferred as `Rec ElField '[ '("x", Bool), '("y", Char) ]`. Or use `record` to build records of any functor. Thanks to @heptahedron on GitHub for prompting this feature, and @sboosali for thinking through various approaches.++- Optional concise record field lens syntax. This uses an orphan `IsLabel` instance for all function types, so will conflict with any other library that does the same. Thus it is entirely opt-in: to enable this syntax, you must explicitly `import Data.Vinyl.Syntax`. This enables the use of labels as lenses. For example, `myRec & #name %~ map toUpper` to apply `map toUpper` to the `#name` field of the record value `myRec`. This technique is thanks to Tikhon Jelvis who shared it on the Haskell-Cafe mailing list.++- Field lenses can now change the type of a record. Thanks to @heptahedron on GitHub for exploring this feature. Using the above-mentioned features, one might now write something like `myRec & #name %~ length` to produce a record whose `#name` field is the length of the`String` `#name` field of some record value, `myRec`.++- Changed the type of `=:=` again to work directly with `Label`s as this is the most convenient usage.++- Definitions in `Data.Vinyl.Core` are now consistently in terms of type classes. This permits inlining and specialization to a user's record types. In the case where the record type is known, call sites do not change. But for functions polymorphic in the record's fields, a constraint will be required. If those constraints are a nuisance, or compile times increase beyond comfort, users should use definitions from the `Data.Vinyl.Recursive` that are written in a recursive style (as in previous versions of the `vinyl` package), treating the record as a list of fields.++- Added `restrictCoRec` and `weakenCoRec` suggested by @ElvishJerricco++# 0.8.0++- Overhaul of `FieldRec`: records with named fields. We now take advantage of the `-XOverloadedLabels` extension to support referring to record fields by names such a `#myField`.++- A new `ARec` type for constant-time field access. You can convert a classic, HList-like `Rec` into an `ARec` with `toARec`, or back the other way with `fromARec`. An `ARec` uses an `Array` to store record fields, so the usual trade-offs between lists and arrays apply: lists are cheap to construct by adding an element to the head, but slow to access; it is expensive to modify the shape of an array, but element lookup is constant-time.++**Compatibility Break**: The operator `=:` for constructing a record with a single field has changed. That operation is now known as `=:=`, while `=:` is now used to construct an `ElField`. It was decided that single-field record construction was not a common use-case, so the shorter name could be used for the more common operation. Apologies for making the upgrade a bit bumpy.++# 0.7.0+- Simplified `match`+- Added `Data.Vinyl.Curry`++# 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.5.2++Ported the tutorial to haddocks (andrewthad)++# 0.5.1+ Added utilities for working with the `FieldRec` type. -Vinyl 0.5-=========+# 0.5  Vinyl 0.5 combines the generality of Vinyl 0.4 with the ease-of-use of previous versions by eschewing the defunctionalized type families and just using plain@@ -14,8 +108,7 @@ Also new in 0.5 is a unified lens-based approach to subtyping, coercion and projection. -Vinyl 0.4-=========+# 0.4  Vinyl 0.4 is a big departure from previous versions, in that it introduces a universe encoding as a means to generalize the space of keys from strings to
Data/Vinyl.hs view
@@ -1,10 +1,25 @@+{-# LANGUAGE PatternSynonyms #-} module Data.Vinyl   ( module Data.Vinyl.Core+  , module Data.Vinyl.Class.Method+  , module Data.Vinyl.ARec   , module Data.Vinyl.Derived+  , module Data.Vinyl.FromTuple+  , module Data.Vinyl.Functor   , module Data.Vinyl.Lens+  , module Data.Vinyl.SRec+  , module Data.Vinyl.XRec   ) where  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)+import Data.Vinyl.Functor (ElField(..)) import Data.Vinyl.Lens-+import Data.Vinyl.SRec (SRec, toSRec, fromSRec)+import Data.Vinyl.XRec (XRec, pattern (::&), pattern XRNil, IsoXRec(..))+import Data.Vinyl.XRec (xrmap, xrapply, rmapX, XRMap, XRApply)
+ Data/Vinyl/ARec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Trustworthy #-}++-- | Constant-time field accessors for extensible records. The+-- trade-off is the usual lists vs arrays one: it is fast to add an+-- element to the head of a list, but element access is linear time;+-- array access time is uniform, but extending the array is more+-- slower.+module Data.Vinyl.ARec+  ( ARec -- Exported abstractly+  , IndexableField+  , ToARec+  , toARec+  , fromARec+  , aget+  , arecGetSubset+  , arecSetSubset+  , arecRepsMatchCoercion+  , arecConsMatchCoercion+  ) where+import Data.Vinyl.ARec.Internal
+ Data/Vinyl/ARec/Internal.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+#endif+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Constant-time field accessors for extensible records. The+-- trade-off is the usual lists vs arrays one: it is fast to add an+-- element to the head of a list, but element access is linear time;+-- array access time is uniform, but extending the array is more+-- slower.+--+-- Tradeoffs:+--+-- * No sharing of the spine (i.e. when you change elements in the front of the+--   record the tail can't be re-used)+-- * ARec requires (4 + n) words + size of the fields+--   * 1 for the ARec constructor+--   * 1 for the pointer to the SmallArray#+--   * The SmallArray# has 2 words as header (1 for GC, 1 for number of elements)+--   * 1 pointer per element to the actual data+-- * Rec requires (2n) words + size of Fields+--   * 1 word per (:&) constructor+--   * 1 word for the pointer to the element+module Data.Vinyl.ARec.Internal+  ( ARec (..)+  , ToARec+  , IndexableField+  , arec+  , ARecBuilder (..)+  , arcons+  , arnil+  , toARec+  , fromARec+  , aget+  , unsafeAput+  , unsafeAlens+  , arecGetSubset+  , arecSetSubset+  , arecRepsMatchCoercion+  , arecConsMatchCoercion+  ) where+import Data.Vinyl.Core+import Data.Vinyl.Lens (RecElem(..), RecSubset(..))+import Data.Vinyl.TypeLevel+import Data.Vinyl.ARec.Internal.SmallArray+import Control.Monad.ST++import Unsafe.Coerce+#if __GLASGOW_HASKELL__ < 806+import Data.Constraint.Forall (Forall)+#endif+import Data.Type.Coercion     (Coercion (..))+import GHC.Types++-- | An array-backed extensible record with constant-time field+-- access.+newtype ARec (f :: k -> *) (ts :: [k]) = ARec SmallArray+type role ARec representational nominal++-- | Get the ith element from the ARec+unsafeIxARec+  :: forall a k (f :: k -> *) (ts :: [k]).+     ARec f ts+  -> Int+  -> a+unsafeIxARec (ARec ar) ix = indexSmallArray ar ix+{-# INLINE unsafeIxARec #-}++-- | Given that @xs@ and @ys@ have the same length, and mapping+-- @f@ over @xs@ and @g@ over @ys@ produces lists whose elements+-- are pairwise 'Coercible', @ARec f xs@ and @ARec g ys@ are+-- 'Coercible'.+arecRepsMatchCoercion :: AllRepsMatch f xs g ys => Coercion (ARec f xs) (ARec g ys)+arecRepsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ())++-- | Given that @forall x. Coercible (f x) (g x)@, produce a coercion from+-- @ARec f xs@ to @ARec g xs@. While the constraint looks a lot like+-- @Coercible f g@, it is actually weaker.++#if __GLASGOW_HASKELL__ >= 806+arecConsMatchCoercion ::+  (forall (x :: k). Coercible (f x) (g x)) => Coercion (ARec f xs) (ARec g xs)+arecConsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ())+#else+arecConsMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).+  Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs)+-- Why do we need this? No idea, really. I guess some change in+-- newtype handling for Coercible in 8.6?+arecConsMatchCoercion = unsafeCoerce (Coercion :: Coercion (Rec f xs) (Rec f xs))+#endif++-- Using a class instead of a recursive function allows aRecValues to be+-- completely inlined+class ToARec (us :: [k]) where+  aRecValues :: Rec f us -> ARecBuilder f us++instance ToARec '[] where+  aRecValues RNil = arnil+  {-# INLINE aRecValues #-}++instance ToARec us => ToARec (u ': us) where+  aRecValues (x :& xs) = x `arcons` aRecValues xs+  {-# INLINE aRecValues #-}++-- | Convert a 'Rec' into an 'ARec' for constant-time field access.+toARec+  :: forall f ts.+     (NatToInt (RLength ts), ToARec ts)+  => Rec f ts+  -> ARec f ts+toARec rs = arec (aRecValues rs)+{-# INLINE toARec #-}++{-+-- This is sensible, but the ergonomics are likely quite bad thanks to the+-- interaction between Coercible resolution and resolution in the presence of+-- quantified constraints. Is there a good way to do this?++arecConsMatchCoercible :: forall k f g rep (r :: TYPE rep).+     (forall (x :: k). Coercible (f x) (g x))+  => ((forall (xs :: [k]). Coercible (ARec f xs) (ARec g xs)) => r) -> r+arecConsMatchCoercible f = f+-}++-- | An efficient builder for ARec values+--+-- Use the pseudo-constructors 'arcons' and 'arnil' to construct an+-- 'ARecBuilder' and then turn it into an 'ARec' with 'arec'+--+-- Example: (requires -XOverloadedLabels and )+--+-- > user :: ARec ElField '[ "name"   ::: String+-- >                       , "age"    ::: Int+-- >                       , "active" ::: Bool]+-- > user = arec (  #name   =: "Peter"+-- >             `arcons` #age    =: 4+-- >             `arcons` #active =: True+-- >             `arcons` arnil+-- >             )+newtype ARecBuilder f us =+  -- A function that writes values to the correct position in the underlying array+  -- Takes the current index+  ARecBuilder ( forall s.+                Int -- Index to write to+              -> SmallMutableArray s -- Arrray to write to+              -> ST s ()+              )++infixr 1 `arcons`+-- | Pseudo-constructor for an ARecBuilder+--+-- "Cons" a field to an ARec under construction+--+-- See 'ARecBuilder'+arcons :: f u -> ARecBuilder f us -> ARecBuilder f (u ': us)+arcons !v (ARecBuilder fvs) = ARecBuilder $ \i mArr -> do+    writeSmallArray mArr i v+    fvs (i+1) mArr+{-# INLINE arcons #-}++-- | Pseudo-constructor for 'ARecBuilder'+--+-- Build an ARec without fields+--+-- See 'ARecBuilder'+arnil :: ARecBuilder f '[]+arnil = ARecBuilder $ \_i _arr -> return ()+{-# INLINE arnil #-}++-- | Turn an ARecBuilder into an ARec+--+-- See 'ARecBuilder'+arec+  :: forall k (us :: [k] ) f+  . (NatToInt (RLength us)) =>+      ARecBuilder f us+  -> ARec f us+arec (ARecBuilder fillArray) = ARec $+  runST $ withNewSmallArray (natToInt @(RLength us))+          $ fillArray 0+{-# INLINE arec #-}++-- | Defines a constraint that lets us index into an 'ARec' in order+-- to produce a 'Rec' using 'fromARec'.+class (NatToInt (RIndex t ts)) => IndexableField ts t where+instance (NatToInt (RIndex t ts)) => IndexableField ts t where++-- | Convert an 'ARec' into a 'Rec'.+fromARec :: forall f ts.+            (RecApplicative ts, RPureConstrained (IndexableField ts) ts)+         => ARec f ts -> Rec f ts+fromARec ar = rpureConstrained @(IndexableField ts) aux+  where aux :: forall t. NatToInt (RIndex t ts) => f t+        aux = unsafeIxARec ar (natToInt @(RIndex t ts))+{-# INLINE fromARec #-}++-- | Get a field from an 'ARec'.+aget :: forall t f ts. (NatToInt (RIndex t ts)) => ARec f ts -> f t+aget ar = unsafeIxARec ar (natToInt @(RIndex t ts))+{-# INLINE aget #-}++-- | Set a field in an 'ARec'.+unsafeAput :: forall t t' f ts ts'. (NatToInt (RIndex t ts))+      => f t' -> ARec f ts -> ARec f ts'+unsafeAput x (ARec arr) = ARec $ runST $+  withThawedSmallArray arr $ \mArr ->+    writeSmallArray mArr (natToInt @(RIndex t ts)) x+{-# INLINE unsafeAput #-}++-- | Define a lens for a field of an 'ARec'.+unsafeAlens :: forall f g t t' ts ts'. (Functor g, NatToInt (RIndex t ts))+      => (f t -> g (f t')) -> ARec f ts -> g (ARec f ts')+unsafeAlens f ar = fmap (flip (unsafeAput @t) ar) (f (aget ar))+{-# INLINE unsafeAlens #-}++-- instance (i ~ RIndex t ts, i ~ RIndex t' ts', NatToInt (RIndex t ts)) => RecElem ARec t t' ts ts' i where+--   rlens = alens+--   rget = aget+--   rput = aput++instance RecElem ARec t t' (t ': ts) (t' ': ts) 'Z where+  rlensC = unsafeAlens+  {-# INLINE rlensC #-}+  rgetC = aget+  {-# INLINE rgetC #-}+  rputC = unsafeAput @t+  {-# INLINE rputC #-}++instance (RIndex t (s ': ts) ~ 'S i, NatToInt i,  RecElem ARec t t' ts ts' i)+  => RecElem ARec t t' (s ': ts) (s ': ts') ('S i) where+  rlensC = unsafeAlens+  {-# INLINE rlensC #-}+  rgetC = aget+  {-# INLINE rgetC #-}+  rputC = unsafeAput @t+  {-# INLINE rputC #-}++-- | Get a subset of a record's fields.+arecGetSubset :: forall rs ss f.+                 (IndexWitnesses (RImage rs ss), NatToInt (RLength rs))+              => ARec f ss -> ARec f rs+arecGetSubset (ARec arr) =+  ARec $ runST $+    withNewSmallArray (natToInt @(RLength rs)) $ \mArr ->+      go mArr 0 (indexWitnesses @(RImage rs ss))+  where+    go :: SmallMutableArray s -> Int -> [Int] -> ST s ()+    go _mArr _to [] = return ()+    go mArr to (from : froms) = do+      writeSmallArray mArr to (indexSmallArray arr from :: Any)+      go mArr (to + 1) froms+{-# INLINE arecGetSubset #-}++-- | Set a subset of a larger record's fields to all of the fields of+-- a smaller record.+arecSetSubset :: forall rs ss f. (IndexWitnesses (RImage rs ss))+              => ARec f ss -> ARec f rs -> ARec f ss+arecSetSubset (ARec arrBig) (ARec arrSmall) = ARec $ runST $+  withThawedSmallArray arrBig $ \mArr -> do+    go mArr 0 (indexWitnesses @(RImage rs ss))+  where+    go :: SmallMutableArray s -> Int -> [Int] -> ST s ()+    go _mArr _ [] = return ()+    go mArr from (to : tos) = do+      writeSmallArray mArr to (indexSmallArray arrSmall from)+      go mArr (from + 1) tos+{-# INLINE arecSetSubset #-}++instance (is ~ RImage rs ss, IndexWitnesses is, NatToInt (RLength rs))+         => RecSubset ARec rs ss is where+  rsubsetC f big = fmap (arecSetSubset big) (f (arecGetSubset big))+  {-# INLINE rsubsetC #-}++instance (RPureConstrained (IndexableField rs) rs,+          RecApplicative rs,+          Show (Rec f rs)) => Show (ARec f rs) where+  show = show . fromARec++instance (RPureConstrained (IndexableField rs) rs,+          RecApplicative rs,+          Eq (Rec f rs)) => Eq (ARec f rs) where+  x == y = fromARec x == fromARec y++instance (RPureConstrained (IndexableField rs) rs,+          RecApplicative rs,+          Ord (Rec f rs)) => Ord (ARec f rs) where+  compare x y = compare (fromARec x) (fromARec y)
+ Data/Vinyl/ARec/Internal/SmallArray.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}++-- | Helper functions for SmallArray#+--+-- This module exposes _unsafe_ functions to work with SmallArrays.  That means+-- that specifically neither index bounds nor element types are checked So this+-- functionality should only be used in a context that enforces them by some+-- other means, e.g. ARec's type index++module Data.Vinyl.ARec.Internal.SmallArray where++import GHC.Prim+import GHC.Types+import Unsafe.Coerce+import GHC.ST++data SmallArray = SmallArray !(SmallArray# Any)+data SmallMutableArray s = SmallMutableArray !(SmallMutableArray# s Any)++indexSmallArray :: SmallArray -> Int -> a+indexSmallArray (SmallArray arr) (I# ix) =+  case indexSmallArray# arr ix of+    (# v #) -> unsafeCoerce v+{-# INLINE indexSmallArray #-}++withNewSmallArray :: Int -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray+withNewSmallArray (I# len#) f =+  ST $ \s0 ->  case newSmallArray# len# (error "withNewSmallArray exploded") s0 of+       (# s1, mArr #) ->+         case f (SmallMutableArray mArr) of+           ST st -> case st s1 of+             (# s2, () #) -> case unsafeFreezeSmallArray# mArr s2 of+               (# s3, ar #) -> (# s3, SmallArray ar #)+{-# INLINE withNewSmallArray #-}++writeSmallArray :: SmallMutableArray s -> Int -> a -> ST s ()+writeSmallArray (SmallMutableArray mArr) (I# n#) x = ST $ \s ->+  case writeSmallArray# mArr n# (unsafeCoerce x) s of+    s' -> (# s', () #)+{-# INLINE writeSmallArray #-}++withThawedSmallArray :: SmallArray+               -> (SmallMutableArray s -> ST s ())+               -> ST s SmallArray+withThawedSmallArray (SmallArray arr) f = ST $ \s0 ->+  let !(I# z#) = 0+  in case thawSmallArray# arr z# (sizeofSmallArray# arr) s0 of+       (# s1, mArr #) ->+         case f (SmallMutableArray mArr) of+           ST st -> case st s1 of+             (# s2, () #) -> case unsafeFreezeSmallArray# mArr s2 of+               (# s3, ar #) -> (# s3, SmallArray ar #)+{-# INLINE withThawedSmallArray #-}
+ Data/Vinyl/Class/Method.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-| This module uses 'RecAll' to extend common typeclass methods to records.+    Generally, it is preferable to use the original typeclass methods to these+    variants. For example, in most places where 'recCompare' could be used,+    you could use 'compare' instead. They are useful in scenarios+    that involve working on unknown subsets of a record's fields+    because 'RecAll' constraints can easily be weakened. An example of this+    is given at the bottom of this page.+-}++module Data.Vinyl.Class.Method+  ( -- * Mapping methods over records+    RecMapMethod(..)+  , rmapMethodF+  , mapFields+  , RecMapMethod1(..)+  , RecPointed(..)+  , rtraverseInMethod+  , rsequenceInFields+    -- * Support for 'RecMapMethod'+  , FieldTyper, ApplyFieldTyper, PayloadType+    -- * Eq Functions+  ,  recEq+     -- * Ord Functions+  , recCompare+    -- * Monoid Functions+  , recMempty+  , recMappend+  , recMconcat+    -- * Num Functions+  , recAdd+  , recSubtract+  , recMultiply+  , recAbs+  , recSignum+  , recNegate+    -- * Bounded Functions+  , recMinBound+  , recMaxBound+    -- * Example+    -- $example+  ) where+import Data.Functor.Product (Product(Pair))+import Data.Vinyl.Core+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+#endif++recEq :: RecAll f rs Eq => Rec f rs -> Rec f rs -> Bool+recEq RNil RNil = True+recEq (a :& as) (b :& bs) = a == b && recEq as bs++recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering+recCompare RNil RNil = EQ+recCompare (a :& as) (b :& bs) = compare a b <> recCompare as bs++-- | This function differs from the original 'mempty' in that+--   it takes an argument. In some cases, you will already+--   have a record of the type you are interested in, and+--   that can be passed an the argument. In other situations+--   where this is not the case, you may need the+--   interpretation function of the argument record to be+--   @Const ()@ or @Proxy@ so the you can generate the+--   argument with 'rpure'.+recMempty :: RecAll f rs Monoid => Rec proxy rs -> Rec f rs+recMempty RNil = RNil+recMempty (_ :& rs) = mempty :& recMempty rs++recMappend :: RecAll f rs Monoid => Rec f rs -> Rec f rs -> Rec f rs+recMappend RNil RNil = RNil+recMappend (a :& as) (b :& bs) = mappend a b :& recMappend as bs++-- | This function differs from the original 'mconcat'.+--   See 'recMempty'.+recMconcat :: RecAll f rs Monoid => Rec proxy rs -> [Rec f rs] -> Rec f rs+recMconcat p [] = recMempty p+recMconcat p (rec : recs) = recMappend rec (recMconcat p recs)++recAdd :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs+recAdd RNil RNil = RNil+recAdd (a :& as) (b :& bs) = (a + b) :& recAdd as bs++recSubtract :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs+recSubtract RNil RNil = RNil+recSubtract (a :& as) (b :& bs) = (a - b) :& recSubtract as bs++recMultiply :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs+recMultiply RNil RNil = RNil+recMultiply (a :& as) (b :& bs) = (a * b) :& recSubtract as bs++recAbs :: RecAll f rs Num => Rec f rs -> Rec f rs+recAbs RNil = RNil+recAbs (a :& as) = abs a :& recAbs as++recSignum :: RecAll f rs Num => Rec f rs -> Rec f rs+recSignum RNil = RNil+recSignum (a :& as) = signum a :& recAbs as++recNegate :: RecAll f rs Num => Rec f rs -> Rec f rs+recNegate RNil = RNil+recNegate (a :& as) = negate a :& recAbs as++-- | This function differs from the original 'minBound'.+--   See 'recMempty'.+recMinBound :: RecAll f rs Bounded => Rec proxy rs -> Rec f rs+recMinBound RNil = RNil+recMinBound (_ :& rs) = minBound :& recMinBound rs++-- | This function differs from the original 'maxBound'.+--   See 'recMempty'.+recMaxBound :: RecAll f rs Bounded => Rec proxy rs -> Rec f rs+recMaxBound RNil = RNil+recMaxBound (_ :& rs) = maxBound :& recMaxBound rs++-- | When we wish to apply a typeclass method to each field of a+-- 'Rec', we typically care about typeclass instances of the record+-- field types irrespective of the record's functor context. To expose+-- the field types themselves, we utilize a constraint built from a+-- defunctionalized type family in the 'rmapMethod' method. The+-- symbols of the function space are defined by this data type.+data FieldTyper = FieldId | FieldSnd++-- | The interpretation function of the 'FieldTyper' symbols.+type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where+  ApplyFieldTyper 'FieldId a = a+  ApplyFieldTyper 'FieldSnd a = Snd a++-- | A mapping of record contexts into the 'FieldTyper' function+-- space. We explicitly match on 'ElField' to pick out the payload+-- type, and 'Compose' to pick out the inner-most context. All other+-- type constructor contexts are understood to not perform any+-- computation on their arguments.+type family FieldPayload (f :: u -> *) :: FieldTyper where+  FieldPayload ElField = 'FieldSnd+  FieldPayload (f :. g) = FieldPayload g+  FieldPayload f = 'FieldId++-- | Shorthand for combining 'ApplyFieldTyper' and 'FieldPayload'.+type family PayloadType f (a :: u) :: * where+  PayloadType f a = ApplyFieldTyper (FieldPayload f) a++-- | Generate a record from fields derived from type class+-- instances.+class RecPointed c f ts where+  rpointMethod :: (forall a. c (f a) => f a) -> Rec f ts++instance RecPointed c f '[] where+  rpointMethod _ = RNil+  {-# INLINE rpointMethod #-}++instance (c (f t), RecPointed c f ts)+  => RecPointed c f (t ': ts) where+  rpointMethod f = f :& rpointMethod @c f+  {-# INLINE rpointMethod #-}++-- | Apply a typeclass method to each field of a 'Rec' where the class+-- constrains the index of the field, but not its interpretation+-- functor.+class RecMapMethod c f ts where+  rmapMethod :: (forall a. c (PayloadType f a) => f a -> g a)+             -> Rec f ts -> Rec g ts++-- | Apply a typeclass method to each field of a 'Rec' where the class+-- constrains the field when considered as a value interpreted by the+-- record's interpretation functor.+class RecMapMethod1 c f ts where+  rmapMethod1 :: (forall a. c (f a) => f a -> g a)+              -> Rec f ts -> Rec g ts++instance RecMapMethod c f '[] where+  rmapMethod _ RNil = RNil+  {-# INLINE rmapMethod #-}++instance RecMapMethod1 c f '[] where+  rmapMethod1 _ RNil = RNil+  {-# INLINE rmapMethod1 #-}++instance (c (PayloadType f t), RecMapMethod c f ts)+  => RecMapMethod c f (t ': ts) where+  rmapMethod f (x :& xs) = f x :& rmapMethod @c f xs+  {-# INLINE rmapMethod #-}++instance (c (f t), RecMapMethod1 c f ts) => RecMapMethod1 c f (t ': ts) where+  rmapMethod1 f (x :& xs) = f x :& rmapMethod1 @c f xs+  {-# INLINE rmapMethod1 #-}++-- | Apply a typeclass method to each field of a @Rec f ts@ using the+-- 'Functor' instance for @f@ to lift the function into the+-- functor. This is a commonly-used specialization of 'rmapMethod'+-- composed with 'fmap'.+rmapMethodF :: forall c f ts. (Functor f, FieldPayload f ~ 'FieldId, RecMapMethod c f ts)+            => (forall a. c a => a -> a) -> Rec f ts -> Rec f ts+rmapMethodF f = rmapMethod @c (fmap f)+{-# INLINE rmapMethodF #-}++-- | Apply a typeclass method to each field of a 'FieldRec'. This is a+-- specialization of 'rmapMethod'.+mapFields :: forall c ts. RecMapMethod c ElField ts+           => (forall a. c a => a -> a) -> FieldRec ts -> FieldRec ts+mapFields f = rmapMethod @c g+  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+    a 'RecAll' constraint instead of the normal typeclass+    constraint. For example, a type-specialized 'compare' would+    look like this:++> compare :: Ord (Rec f rs) => Rec f rs -> Rec f rs -> Ordering++    The 'recCompare' function looks like this:++> recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering++    The only difference is the constraint. Let's look at a potential+    use case for these functions.++    Let's write a function that projects out a subrecord from two records and+    then compares those for equality. We can write this with+    the '<:' operator from @Data.Vinyl.Lens@ and the normal 'compare'+    function. We don't need 'recCompare':++> -- This needs ScopedTypeVariables+> projectAndCompare :: forall super sub f. (super <: sub, Ord (Rec f sub))+>                   => Proxy sub -> Rec f super -> Rec f super -> Ordering+> projectAndCompare _ a b = compare (rcast a :: Rec f sub) (rcast b :: Rec f sub)++    That works fine for the majority of use cases, and it is probably how you should+    write the function if it does everything you need. However, let's consider+    a somewhat more complicated case.++    What if the exact subrecord we were projecting couldn't be+    known at compile time? Assume that the end user was allowd to+    choose the fields on which he or she wanted to compare records.+    The @projectAndCompare@ function cannot handle this because of the+    @Ord (Rec f sub)@ constraint. Even if we amend the constraint to+    read @Ord (Rec f super)@ instead, we cannot use this information+    to recover the @Ord (Rec f sub)@ constraint that we need. Let's+    try another approach.++    We can use the following GADT to prove subsethood:++> data Sublist (super :: [k]) (sub :: [k]) where+>   SublistNil   :: Sublist '[]+>   SublistSuper :: Proxy r -> Sublist super sub -> Sublist (r ': super) sub+>   SublistBoth  :: Proxy r -> Sublist super sub -> Sublist (r ': super) (r ': sub)+>+> projectRec :: Sublist super sub -> Rec f super -> Rec f sub+> projectRec s r = case s of+>   SublistNil -> RNil+>   SublistBoth n snext -> case r of+>     rhead :& rtail -> rhead :& projectRec snext rtail+>   SublistSuper n snext -> case r of+>     rhead :& rtail -> projectRec snext rtail++    It is also possible to write a typeclass to generate @Sublist@s+    implicitly, but that is beyond the scope of this example. Let's+    now write a function to use @Sublist@ to weaken a 'RecAll'+    constraint:++> import Data.Vinyl.Core hiding (Dict)+> import Data.Constraint+>+> weakenRecAll :: Proxy f -> Proxy c -> Sublist super sub -> RecAll f super c :- RecAll f sub c+> weakenRecAll f c s = case s of+>   SublistNil -> Sub Dict+>   SublistSuper _ snext -> Sub $ case weakenRecAll f c snext of+>     Sub Dict -> Dict+>   SublistBoth _ snext -> Sub $ case weakenRecAll f c snext of+>     Sub Dict -> Dict++    Now we can write a different version of our original function:++> -- This needs ScopedTypeVariables+> projectAndCompare2 :: forall super sub f. (RecAll f super Ord)+>                    => Sublist super sub -> Rec f super -> Rec f super -> Ordering+> projectAndCompare2 s a b = case weakenRecAll (Proxy :: Proxy f) (Proxy :: Proxy Ord) s of+>   Sub Dict -> recCompare (projectRec s a) (projectRec s b)++    Notice that in this case, the 'Ord' constraint applies to the full set of fields+    and is then weakened to target a subset of them instead.+-}
+ Data/Vinyl/CoRec.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE AllowAmbiguousTypes, BangPatterns, CPP, ConstraintKinds,+             DataKinds, EmptyCase, FlexibleContexts,+             FlexibleInstances, GADTs, KindSignatures,+             MultiParamTypeClasses, PolyKinds, RankNTypes,+             ScopedTypeVariables, TypeApplications, 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.Vinyl.Core+import Data.Vinyl.Lens (RElem, rget, rput, type (∈))+import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..))+import Data.Vinyl.TypeLevel+import Data.Vinyl.Derived (FieldType, (:::))+import GHC.TypeLits (Symbol, KnownSymbol)+import GHC.Types (type Type)++import Unsafe.Coerce (unsafeCoerce)++-- | Generalize algebraic sum types.+data CoRec :: (k -> *) -> [k] -> * where+  CoRec :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts++-- | A 'CoRec' constructor with better inference. If you have a label+-- that should pick out a type from the list of types that index a+-- 'CoRec', this function will help you more so than the raw 'CoRec'+-- data constructor.+corec :: forall (l :: Symbol)+                (ts :: [(Symbol,Type)])+                (f :: (Symbol,Type) -> Type).+         (KnownSymbol l, (l ::: FieldType l ts) ∈ ts)+      => f (l ::: FieldType l ts) -> CoRec f ts+corec x = CoRec x++-- | 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 }++-- | Helper for writing a 'Show' instance for 'CoRec'. This lets us+-- ask for a 'Show' constraint on the type formed by applying a type+-- constructor to a type index.+class ShowF f a where+  showf :: f a -> String++instance Show (f a) => ShowF f a where+  showf = show++instance forall f ts. RPureConstrained (ShowF f) ts => Show (CoRec f ts) where+  show x = "{|" ++ onCoRec @(ShowF f) showf x ++ "|}"++instance forall ts. (RecApplicative ts, RecordToList ts,+                     RApply ts, ReifyConstraint Eq Maybe ts, RMap 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 @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 :: forall f ts. 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, RMap 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)++-- | Get a 'DictOnly' from an 'RPureConstrained' instance.+getDict :: forall c ts a proxy. (a ∈ ts, RPureConstrained c ts)+        => proxy a -> DictOnly c a+getDict _ = rget @a (rpureConstrained @c @ts DictOnly)++-- | Like 'coRecMap', but the function mapped over the 'CoRec' can+-- have a constraint.+coRecMapC :: forall c ts f g.+             (RPureConstrained c ts)+          => (forall x. (x ∈ ts, c x) => f x -> g x)+          -> CoRec f ts+          -> CoRec g ts+coRecMapC nt (CoRec x) = case getDict @c @ts x of+                           DictOnly -> 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 methods from a type class to a 'CoRec'. Intended for use+-- with @TypeApplications@, e.g. @onCoRec \@Show show r@+onCoRec :: forall c f ts b g. (RPureConstrained c ts)+        => (forall a. (a ∈ ts, c a) => f a -> g b)+        -> CoRec f ts -> g b+onCoRec f (CoRec x) = case getDict @c @ts x of+                        DictOnly -> f x+{-# INLINE onCoRec #-}++-- | Apply a type class method to a 'Field'. Intended for use with+-- @TypeApplications@, e.g. @onField \@Show show r@.+onField :: forall c ts b. (RPureConstrained c ts)+        => (forall a. (a ∈ ts, c a) => a -> b)+        -> Field ts -> b+onField f x = getIdentity (onCoRec @c (fmap f) x)+{-# INLINE onField #-}++-- * Extracting values from a CoRec/Pattern matching on a CoRec++-- | Compute a runtime 'Int' index identifying the position of the+-- variant held by a @CoRec f ts@ in the type-level list @ts@.+variantIndexOf :: forall f ts. CoRec f ts -> Int+variantIndexOf (CoRec x) = aux x+  where aux :: forall a. NatToInt (RIndex a ts) => f a -> Int+        aux _ = natToInt @(RIndex a ts)+{-# INLINE variantIndexOf #-}++-- [NOTE: asA] We want to say that if @NatToInt (RIndex a ts) ~+-- NatToInt (RIndex b ts)@ then @a ~ b@ by relying on an injectivity+-- property of 'RIndex'. However, we are checking the variant index of+-- the argument at runtime, so we do not statically know that+-- extracting the variant at a particular type is safe at compile+-- time.++-- | If a 'CoRec' is a variant of the requested type, return 'Just'+-- that value; otherwise return 'Nothing'.+asA :: NatToInt (RIndex t ts) => CoRec Identity ts -> Maybe t+asA = fmap getIdentity . asA'+{-# INLINE asA #-}++-- | Like 'asA', but for any interpretation functor.+asA' :: forall t ts f. (NatToInt (RIndex t ts))+     => CoRec f ts -> Maybe (f t)+asA' f@(CoRec x)+  | variantIndexOf f == natToInt @(RIndex t ts) = Just (unsafeCoerce x)+  | otherwise = Nothing+{-# INLINE asA' #-}++-- | Pattern match on a CoRec by specifying handlers for each case. 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 :: forall ts b. CoRec Identity ts -> Handlers ts b -> b+match (CoRec (Identity t)) hs = aux t+  where aux :: forall a. RElem a ts (RIndex a ts) => a -> b+        aux x = case rget @a hs of+                  H f -> f x++-- | 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,+           RMap ts, RMap (RDelete t 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 _ -> error "matchNil: impossible"++-- | 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++-- | A 'CoRec' is either the first possible variant indicated by its+-- type, or a 'CoRec' that must be one of the remaining types.+restrictCoRec :: forall t ts f. (RecApplicative ts, FoldRec ts ts)+              => CoRec f (t ': ts) -> Either (f t) (CoRec f ts)+restrictCoRec r = maybe (Right (unsafeCoerce r)) Left (asA' @t r)+{-# INLINE restrictCoRec #-}++-- | A 'CoRec' whose possible types are @ts@ may be used at a type of+-- 'CoRec' whose possible types are @t:ts@.+weakenCoRec :: (RecApplicative ts, FoldRec (t ': ts) (t ': ts))+            => CoRec f ts -> CoRec f (t ': ts)+weakenCoRec = fromJust . firstField . (Compose Nothing :&) . coRecToRec++-- * Safe Variants++-- | A 'CoRec' is either the first possible variant indicated by its+-- type, or a 'CoRec' that must be one of the remaining types. The+-- safety is related to that of 'asASafe'.+restrictCoRecSafe :: forall t ts f. (RecApplicative ts, FoldRec ts ts)+                  => CoRec f (t ': ts) -> Either (f t) (CoRec f ts)+restrictCoRecSafe = go . coRecToRec+  where go :: Rec (Maybe :. f) (t ': ts) -> Either (f t) (CoRec f ts)+        go (Compose Nothing :& xs) = Right (fromJust (firstField xs))+        go (Compose (Just x) :& _) = Left x++-- | Like 'asA', but implemented more safely and typically slower.+asASafe :: (t ∈ ts, RecApplicative ts, RMap ts)+        => CoRec Identity ts -> Maybe t+asASafe c@(CoRec _) = rget $ coRecToRec' c++-- | Like 'asASafe', but for any interpretation functor.+asA'Safe :: (t ∈ ts, RecApplicative ts, RMap ts)+         => CoRec f ts -> (Maybe :. f) t+asA'Safe c@(CoRec _) = rget $ coRecToRec c
Data/Vinyl/Core.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -8,20 +10,52 @@ {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE Trustworthy           #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints #-}+#endif {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} +-- | Core vinyl definitions. The 'Rec' data type is defined here, but+-- also of interest are definitions commonly used functions like+-- 'rmap', 'rapply', and 'rtraverse'.+--+-- The definitions in this module are written in terms of type classes+-- so that the definitions may be specialized to each record type at+-- which they are used. This usually helps with runtime performance,+-- but can slow down compilation time. If you are experiencing poor+-- compile times, you may wish to try the semantically equivalent+-- definitions in the "Data.Vinyl.Recursive" module: they should+-- produce the same results given the same inputs as functions defined+-- in this module, but they will not be specialized to your record+-- type. Instead, they treat the record as a list of fields, so will+-- have performance linear in the size of the record. module Data.Vinyl.Core where--import Data.Monoid+import Data.Coerce (Coercible)+#if __GLASGOW_HASKELL__ < 808+import Data.Monoid (Monoid)+#endif+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup(..))+#endif import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..))-import Data.Vinyl.Functor-import Control.Applicative hiding (Const(..))-import Data.Typeable (Proxy(..))+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)+import Unsafe.Coerce (unsafeCoerce)+import Control.DeepSeq (NFData, rnf)+#if __GLASGOW_HASKELL__ < 806+import Data.Constraint.Forall (Forall)+#endif  -- | 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@@ -31,11 +65,27 @@   RNil :: Rec f '[]   (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) -infixr :&+infixr 7 :& infixr 5  <+> infixl 8 <<$>> infixl 8 <<*>> +instance TestEquality f => TestEquality (Rec f) where+  testEquality RNil RNil = Just Refl+  testEquality (x :& xs) (y :& ys) = do+    Refl <- testEquality x y+    Refl <- testEquality xs ys+    Just Refl+  testEquality _ _ = Nothing++instance TestCoercion f => TestCoercion (Rec f) where+  testCoercion RNil RNil = Just Coercion+  testCoercion (x :& xs) (y :& ys) = do+    Coercion <- testCoercion x y+    Coercion <- testCoercion xs ys+    Just Coercion+  testCoercion _ _ = Nothing+ -- | Two records may be pasted together. rappend   :: Rec f as@@ -51,20 +101,41 @@   -> 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@.-rmap-  :: (forall x. f x -> g x)-  -> Rec f rs-  -> Rec g rs-rmap _ RNil = RNil-rmap η (x :& xs) = η x :& (η `rmap` xs)-{-# INLINE rmap #-}+class RMap rs where+  rmap :: (forall x. f x -> g x) -> Rec f rs -> Rec g rs +instance RMap '[] where+  rmap _ RNil = RNil+  {-# INLINE rmap #-}++instance RMap xs => RMap (x ': xs) where+  rmap f (x :& xs) = f x :& rmap f xs+  {-# INLINE rmap #-}+ -- | A shorthand for 'rmap'. (<<$>>)-  :: (forall x. f x -> g x)+  :: RMap rs+  => (forall x. f x -> g x)   -> Rec f rs   -> Rec g rs (<<$>>) = rmap@@ -72,7 +143,8 @@  -- | An inverted shorthand for 'rmap'. (<<&>>)-  :: Rec f rs+  :: RMap rs+  => Rec f rs   -> (forall x. f x -> g x)   -> Rec g rs xs <<&>> f = rmap f xs@@ -80,17 +152,23 @@  -- | A record of components @f r -> g r@ may be applied to a record of @f@ to -- get a record of @g@.-rapply-  :: Rec (Lift (->) f g) rs-  -> Rec f rs-  -> Rec g rs-rapply RNil RNil = RNil-rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs)-{-# INLINE rapply #-}+class RApply rs where+  rapply :: Rec (Lift (->) f g) rs+         -> Rec f rs+         -> Rec g rs +instance RApply '[] where+  rapply _ RNil = RNil+  {-# INLINE rapply #-}++instance RApply xs => RApply (x ': xs) where+  rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs)+  {-# INLINE rapply #-}+ -- | A shorthand for 'rapply'. (<<*>>)-  :: Rec (Lift (->) f g) rs+  :: RApply rs+  => Rec (Lift (->) f g) rs   -> Rec f rs   -> Rec g rs (<<*>>) = rapply@@ -121,13 +199,68 @@ 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.+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+  rfoldMapAux :: Monoid m+              => (forall x. f x -> m)+              -> m+              -> Rec f rs+              -> m++instance RFoldMap '[] where+  rfoldMapAux _ m RNil = m+  {-# INLINE rfoldMapAux #-}++instance RFoldMap xs => RFoldMap (x ': xs) where+  rfoldMapAux f m (r :& rs) = rfoldMapAux f (mappend m (f r)) rs+  {-# INLINE rfoldMapAux #-}++rfoldMap :: forall rs m f. (Monoid m, RFoldMap rs)+         => (forall x. f x -> m) -> Rec f rs -> m+rfoldMap f = rfoldMapAux f mempty+{-# INLINE rfoldMap #-}+ -- | A record with uniform fields may be turned into a list.-recordToList-  :: Rec (Const a) rs-  -> [a]-recordToList RNil = []-recordToList (x :& xs) = getConst x : recordToList xs+class RecordToList rs where+  recordToList :: Rec (Const a) rs -> [a] +instance RecordToList '[] where+  recordToList RNil = []+  {-# INLINE recordToList #-}++instance RecordToList xs => RecordToList (x ': xs) where+  recordToList (x :& xs) = getConst x : recordToList xs+  {-# INLINE recordToList #-}+ -- | Wrap up a value with a capability given by its type data Dict c a where   Dict@@ -140,53 +273,231 @@ -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly, -- the constraint solver is not quite smart enough to realize this and we must -- make it patently obvious by reifying the constraint pointwise with proof.-reifyConstraint-  :: RecAll f rs c-  => proxy c-  -> Rec f rs-  -> Rec (Dict c :. f) rs-reifyConstraint prx rec =-  case rec of-    RNil -> RNil-    (x :& xs) -> Compose (Dict x) :& reifyConstraint prx xs+class ReifyConstraint c f rs where+  reifyConstraint+    :: Rec f rs+    -> Rec (Dict c :. f) rs +instance ReifyConstraint c f '[] where+  reifyConstraint RNil = RNil+  {-# INLINE reifyConstraint #-}++instance (c (f x), ReifyConstraint c f xs)+  => ReifyConstraint c f (x ': xs) where+  reifyConstraint (x :& xs) = Compose (Dict x) :& reifyConstraint xs+  {-# INLINE reifyConstraint #-}++-- | Build a record whose elements are derived solely from a+-- constraint satisfied by each.+class RPureConstrained c ts where+  rpureConstrained :: (forall a. c a => f a) -> Rec f ts++instance RPureConstrained c '[] where+  rpureConstrained _ = RNil+  {-# INLINE rpureConstrained #-}++instance (c x, RPureConstrained c xs) => RPureConstrained c (x ': xs) where+  rpureConstrained f = f :& rpureConstrained @c @xs f+  {-# 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++-- | Build a record whose elements are derived solely from a+-- list of constraint constructors satisfied by each.+class RPureConstraints cs ts where+  rpureConstraints :: (forall a. AllSatisfied cs a => f a) -> Rec f ts++instance RPureConstraints cs '[] where+  rpureConstraints _ = RNil+  {-# INLINE rpureConstraints #-}++instance (AllSatisfied cs t, RPureConstraints cs ts)+  => RPureConstraints cs (t ': ts) where+  rpureConstraints f = f :& rpureConstraints @cs @ts f+  {-# INLINE rpureConstraints #-}+ -- | 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+instance (RMap rs, ReifyConstraint Show f rs, RecordToList rs)+  => Show (Rec f rs) where   show xs =     (\str -> "{" <> str <> "}")       . intercalate ", "       . recordToList       . rmap (\(Compose (Dict x)) -> Const $ show x)-      $ reifyConstraint (Proxy :: Proxy Show) xs+      $ reifyConstraint @Show xs +instance Semigroup (Rec f '[]) where+  RNil <> RNil = RNil++instance (Semigroup (f r), Semigroup (Rec f rs))+  => Semigroup (Rec f (r ': rs)) where+  (x :& xs) <> (y :& ys) = (x <> y) :& (xs <> ys)+ instance Monoid (Rec f '[]) where   mempty = RNil   RNil `mappend` RNil = RNil  instance (Monoid (f r), Monoid (Rec f rs)) => Monoid (Rec f (r ': rs)) where   mempty = mempty :& mempty-  (x :& xs) `mappend` (y :& ys) = (x <> y) :& (xs <> ys)+  (x :& xs) `mappend` (y :& ys) = (mappend x y) :& (mappend xs ys)  instance Eq (Rec f '[]) where   _ == _ = True instance (Eq (f r), Eq (Rec f rs)) => Eq (Rec f (r ': rs)) where   (x :& xs) == (y :& ys) = (x == y) && (xs == ys) +instance Ord (Rec f '[]) where+  compare _ _ = EQ+instance (Ord (f r), Ord (Rec f rs)) => Ord (Rec f (r ': rs)) where+  compare (x :& xs) (y :& ys) = mappend (compare x y) (compare xs ys)+ instance Storable (Rec f '[]) where   sizeOf _    = 0   alignment _ = 0   peek _      = return RNil   poke _ RNil = return () -instance (Storable (f r), Storable (Rec f rs)) => Storable (Rec f (r ': rs)) where+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 #-}++instance Generic (Rec f '[]) where+  type Rep (Rec f '[]) =+    C1 ('MetaCons "RNil" 'PrefixI 'False)+       (S1 ('MetaSel 'Nothing+          'NoSourceUnpackedness+          'NoSourceStrictness+          'DecidedLazy) U1)+  from RNil = M1 (M1 U1)+  to (M1 (M1 U1)) = RNil++instance (Generic (Rec f rs)) => Generic (Rec f (r ': rs)) where+  type Rep (Rec f (r ': rs)) =+    C1 ('MetaCons ":&" ('InfixI 'RightAssociative 7) 'False)+    (S1 ('MetaSel 'Nothing+         'NoSourceUnpackedness+         'SourceStrict+         'DecidedStrict)+       (Rec0 (f r))+      :*:+      S1 ('MetaSel 'Nothing+           'NoSourceUnpackedness+           'NoSourceStrictness+           'DecidedLazy)+         (Rep (Rec f rs)))+  from (x :& xs) = M1 (M1 (K1 x) :*: M1 (from xs))+  to (M1 (M1 (K1 x) :*: M1 xs)) = x :& to xs++instance ReifyConstraint NFData f xs => NFData (Rec f xs) where+  rnf = go . reifyConstraint @NFData+    where+      go :: forall elems. Rec (Dict NFData :. f) elems -> ()+      go RNil = ()+      go (Compose (Dict x) :& xs) = rnf x `seq` go xs++type family Head xs where+  Head (x ': _) = x+type family Tail xs where+  Tail (_ ': xs) = xs++type family AllRepsMatch_ (f :: j -> *) (xs :: [j]) (g :: k -> *) (ys :: [k]) :: Constraint where+  AllRepsMatch_ f (x ': xs) g ys =+    ( ys ~ (Head ys ': Tail ys)+    , Coercible (f x) (g (Head ys))+    , AllRepsMatch_ f xs g (Tail ys) )+  AllRepsMatch_ _ '[] _ ys = ys ~ '[]++-- | @AllRepsMatch f xs g ys@ means that @xs@ and @ys@ have the+-- same lengths, and that mapping @f@ over @xs@ and @g@ over @ys@+-- produces lists whose corresponding elements are 'Coercible' with+-- each other. For example, the following hold:+--+-- @AllRepsMatch Proxy '[1,2,3] Proxy '[4,5,6]@+-- @AllRepsMatch Sum '[Int,Word] Identity '[Min Int, Max Word]@+type AllRepsMatch f xs g ys = (AllRepsMatch_ f xs g ys, AllRepsMatch_ g ys f xs)++-- This two-sided approach means that the *length* of each list+-- can be inferred from the length of the other. I don't know how+-- useful that is in practice, but we get it almost for free.++-- | Given that for each element @x@ in the list @xs@,+repsMatchCoercion :: AllRepsMatch f xs g ys => Coercion (Rec f xs) (Rec g ys)+repsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ())++{-+-- "Proof" that repsMatchCoercion is sensible.+repsMatchConvert :: AllRepsMatch f xs g ys => Rec f xs -> Rec g ys+repsMatchConvert RNil = RNil+repsMatchConvert (x :& xs) = coerce x :& repsMatchConvert xs+-}++#if __GLASGOW_HASKELL__ >= 806+consMatchCoercion ::+  (forall (x :: k). Coercible (f x) (g x)) => Coercion (Rec f xs) (Rec g xs)+#else+consMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).+  Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs)+#endif+consMatchCoercion = unsafeCoerce (Coercion :: Coercion () ())+{-+-- "Proof" that consMatchCoercion is sensible.+consMatchConvert ::+  (forall (x :: k). Coercible (f x) (g x)) => Rec f xs -> Rec g xs+consMatchConvert RNil = RNil+consMatchConvert (x :& xs) = coerce x :& consMatchConvert xs++-- And for old GHC.+consMatchConvert' :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).+  Forall (Similar f g) => Rec f xs -> Rec g xs+consMatchConvert' RNil = RNil+consMatchConvert' ((x :: f x) :& xs) =+  case inst :: Forall (Similar f g) DC.:- Similar f g x of+    DC.Sub DC.Dict -> coerce x :& consMatchConvert' xs+-}++{-+-- This is sensible, but I suspect the ergonomics will be awful+-- thanks to the interaction between Coercible constraint resolution+-- and constraint resolution with quantified constraints. Is there+-- a good way to accomplish it?++-- | Given+--+-- @+-- forall x. Coercible (f x) (g x)+-- @+--+-- provide the constraint+--+-- @+-- forall xs. Coercible (Rec f xs) (Rec g xs)+-- @+consMatchCoercible :: forall k f g rep (r :: TYPE rep).+     (forall (x :: k). Coercible (f x) (g x))+  => ((forall (xs :: [k]). Coercible (Rec f xs) (Rec g xs)) => r) -> r+consMatchCoercible f = case unsafeCoerce @(Zouch f f) @(Zouch f g) (Zouch $ \r -> r) of+  Zouch q -> q f++newtype Zouch (f :: k -> *) (g :: k -> *) =+  Zouch (forall rep (r :: TYPE rep). ((forall (xs :: [k]). Coercible (Rec f xs) (Rec g xs)) => r) -> r)+-}
+ Data/Vinyl/Curry.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++{-|++Provides combinators for currying and uncurrying functions over arbitrary vinyl+records.++-}+module Data.Vinyl.Curry where+import           Data.Kind (Type)+import           Data.Vinyl+import           Data.Vinyl.Functor+import           Data.Vinyl.XRec++-- * Currying++class RecordCurry ts where+  {-|+  N-ary version of 'curry' over functorial records.++  Example specialized signatures:++  @+  rcurry :: (Rec Maybe '[Int, Double] -> Bool) -> Maybe Int -> Maybe Double -> Bool+  rcurry :: (Rec (Either Int) '[Double, String, ()] -> Int) -> Either Int Double -> Either Int String -> Either Int () -> Int+  rcurry :: (Rec f '[] -> Bool) -> Bool+  @++  -}+  rcurry :: (Rec f ts -> a) -> CurriedF f ts a++class RecordCurry' ts where+  {-|+  N-ary version of 'curry' over pure records.++  Example specialized signatures:++  @+  rcurry' :: (Rec Identity '[Int, Double] -> Bool) -> Int -> Double -> Bool+  rcurry' :: (Rec Identity '[Double, String, ()] -> Int) -> Double -> String -> () -> Int+  rcurry' :: (Rec Identity '[] -> Bool) -> Bool+  @++  -}+  rcurry' :: (Rec Identity ts -> a) -> Curried ts a+++instance RecordCurry '[] where+  rcurry f = f RNil+  {-# INLINABLE rcurry #-}+instance RecordCurry' '[] where+  rcurry' f = f RNil+  {-# INLINABLE rcurry' #-}++instance RecordCurry ts => RecordCurry (t ': ts) where+  rcurry f x = rcurry (\xs -> f (x :& xs))+  {-# INLINABLE rcurry #-}+instance RecordCurry' ts => RecordCurry' (t ': ts) where+  rcurry' f x = rcurry' (\xs -> f (Identity x :& xs))+  {-# INLINABLE rcurry' #-}++-- * Uncurrying++{-|+N-ary version of 'uncurry' over functorial records.++Example specialized signatures:++@+runcurry :: (Maybe Int -> Maybe Double -> String) -> Rec Maybe '[Int, Double] -> String+runcurry :: (IO FilePath -> String) -> Rec IO '[FilePath] -> String+runcurry :: Int -> Rec f '[] -> Int+@+-}+runcurry :: CurriedF f ts a -> Rec f ts -> a+runcurry x RNil      = x+runcurry f (x :& xs) = runcurry (f x) xs+{-# INLINABLE runcurry #-}+++{-|+N-ary version of 'uncurry' over pure records.++Example specialized signatures:++@+runcurry' :: (Int -> Double -> String) -> Rec Identity '[Int, Double] -> String+runcurry' :: Int -> Rec Identity '[] -> Int+@++Example usage:++@+f :: Rec Identity '[Bool, Int, Double] -> Either Int Double+f = runcurry' $ \b x y -> if b then Left x else Right y+@+-}+runcurry' :: Curried ts a -> Rec Identity ts -> a+runcurry' x RNil               = x+runcurry' f (Identity x :& xs) = runcurry' (f x) xs+{-# INLINABLE runcurry' #-}++-- | Apply an uncurried function to an 'XRec'.+xruncurry :: CurriedX f ts a -> XRec f ts -> a+xruncurry x RNil = x+xruncurry f (x :& xs) = xruncurry (f (unX x)) xs+{-# INLINABLE xruncurry #-}++-- | Apply an uncurried function to a 'Rec' like 'runcurry' except the+-- function enjoys a type simplified by the 'XData' machinery that+-- strips away type-induced noise like 'Identity', 'Compose', and+-- 'ElField'.+runcurryX :: IsoXRec f ts => CurriedX f ts a -> Rec f ts -> a+runcurryX f = xruncurry f . toXRec+{-# INLINE runcurryX #-}++-- * Applicative Combinators++{-|+Lift an N-ary function to work over a record of 'Applicative' computations.++>>> runcurryA' (+) (Just 2 :& Just 3 :& RNil)+Just 5++>>> runcurryA' (+) (Nothing :& Just 3 :& RNil)+Nothing+-}+runcurryA' :: (Applicative f) => Curried ts a -> Rec f ts -> f a+runcurryA' f = fmap (runcurry' f) . rtraverse (fmap Identity)+{-# INLINE runcurryA' #-}++{-|+Lift an N-ary function over types in @g@ to work over a record of 'Compose'd+'Applicative' computations. A more general version of 'runcurryA''.++Example specialized signatures:++@+runcurryA :: (g x -> g y -> a) -> Rec (Compose Maybe g) '[x, y] -> Maybe a+@+-}+runcurryA :: (Applicative f) => CurriedF g ts a -> Rec (Compose f g) ts -> f a+runcurryA f = fmap (runcurry f) . rtraverse getCompose+{-# INLINE runcurryA #-}++-- * Curried Function Types++{-|+For the list of types @ts@, @'Curried' ts a@ is a curried function type from+arguments of types in @ts@ to a result of type @a@.++>>> :kind! Curried '[Int, Bool, String] Int+Curried '[Int, Bool, String] Int :: *+= Int -> Bool -> [Char] -> Int+-}+type family Curried ts a where+  Curried '[] a = a+  Curried (t ': ts) a = t -> Curried ts a+++{-|+For the type-level list @ts@, @'CurriedF' f ts a@ is a curried function type+from arguments of type @f t@ for @t@ in @ts@, to a result of type @a@.++>>> :kind! CurriedF Maybe '[Int, Bool, String] Int+CurriedF Maybe '[Int, Bool, String] Int :: *+= Maybe Int -> Maybe Bool -> Maybe [Char] -> Int+-}+type family CurriedF (f :: u -> Type) (ts :: [u]) a where+  CurriedF f '[] a = a+  CurriedF f (t ': ts) a = f t -> CurriedF f ts a++{-|+For the type-level list @ts@, @'CurriedX' f ts a@ is a curried function type+from arguments of type @HKD f t@ for @t@ in @ts@, to a result of type @a@.++>>> :set -XTypeOperators+>>> :kind! CurriedX (Maybe :. Identity) '[Int, Bool, String] Int+CurriedX (Maybe :. Identity) '[Int, Bool, String] Int :: *+= Maybe Int -> Maybe Bool -> Maybe [Char] -> Int+-}+type family CurriedX (f :: u -> Type) (ts :: [u]) a where+  CurriedX f '[] a = a+  CurriedX f (t ': ts) a = HKD f t -> CurriedX f ts a
Data/Vinyl/Derived.hs view
@@ -1,51 +1,141 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds  #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GADTs      #-} {-# LANGUAGE PolyKinds  #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+-- | Commonly used 'Rec' instantiations. module Data.Vinyl.Derived where  import Data.Proxy+import Data.Vinyl.ARec import Data.Vinyl.Core import Data.Vinyl.Functor-import Foreign.Ptr (castPtr)-import Foreign.Storable+import Data.Vinyl.Lens+import Data.Vinyl.TypeLevel (Fst, Snd, RIndex)+import GHC.OverloadedLabels import GHC.TypeLits -data ElField (field :: (Symbol, *)) where-  Field :: KnownSymbol s => !t -> ElField '(s,t)+-- | Alias for Field spec+type a ::: b = '(a, b) +-- | A record of named fields. type FieldRec = Rec ElField-type HList = Rec Identity-type LazyHList = Rec Thunk -deriving instance Eq t => Eq (ElField '(s,t))-deriving instance Ord t => Ord (ElField '(s,t))+-- | An 'ARec' of named fields to provide constant-time field access.+type AFieldRec ts = ARec ElField ts -instance Show t => Show (ElField '(s,t)) where-  show (Field x) = (symbolVal (Proxy::Proxy s))++" :-> "++show x+-- | Heterogeneous list whose elements are evaluated during list+-- construction.+type HList = Rec Identity +-- | Heterogeneous list whose elements are left as-is during list+-- construction (cf. 'HList').+type LazyHList = Rec Thunk+ -- | Get the data payload of an 'ElField'. getField :: ElField '(s,t) -> t getField (Field x) = x +-- | Get the label name of an 'ElField'.+getLabel :: forall s t. KnownSymbol s => ElField '(s,t) -> String+getLabel (Field _) = symbolVal (Proxy::Proxy s)+ -- | 'ElField' is isomorphic to a functor something like @Compose -- ElField ('(,) s)@. fieldMap :: (a -> b) -> ElField '(s,a) -> ElField '(s,b) 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) {-# INLINE rfield #-} +infix 8 =:++-- | Operator for creating an 'ElField'. With the @-XOverloadedLabels@+-- extension, this permits usage such as, @#foo =: 23@ to produce a+-- value of type @ElField ("foo" ::: Int)@.+(=:) :: KnownSymbol l => Label (l :: Symbol) -> (v :: *) -> ElField (l ::: v)+_ =: v = Field v++-- | Get a named field from a record.+rgetf+  :: forall l f v record us.+     (HasField record l us us v v, RecElemFCtx record f)+  => Label l -> record f us -> f (l ::: v)+rgetf _ = rget @(l ::: v)++-- | Get the value associated with a named field from a record.+rvalf+  :: (HasField record l us us v v, RecElemFCtx record ElField)+  => Label l -> record ElField us -> v+rvalf x = getField . rgetf x++-- | Set a named field. @rputf' #foo 23@ sets the field named @#foo@ to+-- @23@.+rputf' :: forall l v v' record us us'.+          (HasField record l us us' v v', KnownSymbol l, RecElemFCtx record ElField)+       => Label l -> v' -> record ElField us -> record ElField us'+rputf' _ = rput' @_ @(l:::v) . (Field :: v' -> ElField '(l,v'))++-- | Set a named field without changing its type. @rputf #foo 23@ sets+-- the field named @#foo@ to @23@.+rputf :: forall l v record us.+          (HasField record l us us v v, KnownSymbol l, RecElemFCtx record ElField)+       => Label l -> v -> record ElField us -> record ElField us+rputf _ = rput @_ @(l:::v) . Field++-- | A lens into a 'Rec' identified by a 'Label'.+rlensfL' :: forall l v v' record g f us us'.+             (Functor g, HasField record l us us' v v', RecElemFCtx record f)+          => Label l+          -> (f (l ::: v) -> g (f (l ::: v')))+          -> record f us+          -> g (record f us')+rlensfL' _ f = rlens' @(l ::: v) f++-- | A type-preserving lens into a 'Rec' identified by a 'Label'.+rlensfL :: forall l v record g f us.+           (Functor g, HasField record l us us v v, RecElemFCtx record f)+        => Label l+        -> (f (l ::: v) -> g (f (l ::: v)))+        -> record f us+        -> g (record f us)+rlensfL _ f = rlens' @(l ::: v) f++-- | A lens into the payload value of a 'Rec' field identified by a+-- 'Label'.+rlensf' :: forall l v v' record g us us'.+           (Functor g, HasField record l us us' v v', RecElemFCtx record ElField)+        => Label l -> (v -> g v') -> record ElField us -> g (record ElField us')+rlensf' _ f = rlens' @(l ::: v) (rfield f)++-- | A type-preserving lens into the payload value of a 'Rec' field+-- identified by a 'Label'.+rlensf :: forall l v record g us.+          (Functor g, HasField record l us us v v, RecElemFCtx record ElField)+        => Label l -> (v -> g v) -> record ElField us -> g (record ElField us)+rlensf _ f = rlens @(l ::: v) (rfield f)+ -- | Shorthand for a 'FieldRec' with a single field.-(=:) :: KnownSymbol s => proxy '(s,a) -> a -> FieldRec '[ '(s,a) ]-(=:) _ x = Field x :& RNil+(=:=) :: KnownSymbol s => Label (s :: Symbol) -> a -> FieldRec '[ '(s,a) ]+(=:=) _ x = Field x :& RNil  -- | A proxy for field types. data SField (field :: k) = SField@@ -55,9 +145,86 @@ instance KnownSymbol s => Show (SField '(s,t)) where   show _ = "SField "++symbolVal (Proxy::Proxy s) -instance forall s t. (KnownSymbol s, Storable t)-    => Storable (ElField '(s,t)) where-  sizeOf _ = sizeOf (undefined::t)-  alignment _ = alignment (undefined::t)-  peek ptr = Field `fmap` peek (castPtr ptr)-  poke ptr (Field x) = poke (castPtr ptr) x+type family FieldType l fs where+  FieldType l '[] = TypeError ('Text "Cannot find label "+                               ':<>: 'ShowType l+                               ':<>: 'Text " in fields")+  FieldType l ((l ::: v) ': fs) = v+  FieldType l ((l' ::: v') ': fs) = FieldType l fs++-- | Constraint that a label is associated with a particular type in a+-- record.+type HasField record l fs fs' v v' =+  (RecElem record (l ::: v) (l ::: v') fs fs' (RIndex (l ::: v) fs), FieldType l fs ~ v, FieldType l fs' ~ v')++-- | Proxy for label type+data Label (a :: Symbol) = Label+  deriving (Eq, Show)++instance s ~ s' => IsLabel s (Label s') where+#if __GLASGOW_HASKELL__ < 802+  fromLabel _ = Label+#else+  fromLabel = Label+#endif++-- | Defines a constraint that lets us extract the label from an+-- 'ElField'. Used in 'rmapf' and 'rpuref'.+class (KnownSymbol (Fst a), a ~ '(Fst a, Snd a)) => KnownField a where+instance KnownSymbol l => KnownField (l ::: v) where++-- | Shorthand for working with records of fields as in 'rmapf' and+-- 'rpuref'.+type AllFields fs = (RPureConstrained KnownField fs, RecApplicative fs, RApply fs)++-- | Map a function between functors across a 'Rec' taking advantage+-- of knowledge that each element is an 'ElField'.+rmapf :: AllFields fs+      => (forall a. KnownField a => f a -> g a)+      -> Rec f fs -> Rec g fs+rmapf f = (rpureConstrained @KnownField (Lift f) <<*>>)++-- | Remove the first component (e.g. the label) from a type-level+-- list of pairs.+type family Unlabeled ts where+  Unlabeled '[] = '[]+  Unlabeled ('(s,x) ': xs) = x ': Unlabeled xs++-- | Facilities for removing and replacing the type-level label, or+-- column name, part of a record.+class StripFieldNames ts where+  stripNames :: Rec ElField ts -> Rec Identity (Unlabeled ts)+  stripNames' :: Functor f => Rec (f :. ElField) ts -> Rec f (Unlabeled ts)+  withNames :: Rec Identity (Unlabeled ts) -> Rec ElField ts+  withNames' :: Functor f => Rec f (Unlabeled ts) -> Rec (f :. ElField) ts++instance StripFieldNames '[] where+  stripNames RNil = RNil+  stripNames' RNil = RNil+  withNames RNil = RNil+  withNames' RNil = RNil++instance (KnownSymbol s, StripFieldNames ts) => StripFieldNames ('(s,t) ': ts) where+  stripNames (Field x :& xs) = pure x :& stripNames xs+  stripNames' (Compose x :& xs) = fmap getField x :& stripNames' xs+  withNames (Identity x :& xs) = Field x :& withNames xs+  withNames' (x :& xs) = Compose (fmap Field x) :& withNames' xs++-- | Construct a 'Rec' with 'ElField' elements.+rpuref :: AllFields fs => (forall a. KnownField a => f a) -> Rec f fs+rpuref f = rpureConstrained @KnownField f++-- | Operator synonym for 'rmapf'.+(<<$$>>)+  :: AllFields fs+  => (forall a. KnownField a => f a -> g a) -> Rec f fs -> Rec g fs+(<<$$>>) = rmapf++-- | Produce a 'Rec' of the labels of a 'Rec' of 'ElField's.+rlabels :: AllFields fs => Rec (Const String) fs+rlabels = rpuref getLabel'+  where getLabel' :: forall l v. KnownSymbol l+                  => Const String (l ::: v)+        getLabel' = Const (symbolVal (Proxy::Proxy l))++-- * Specializations for working with an 'ARec' of named fields.
+ Data/Vinyl/FromTuple.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+-- | Concise vinyl record construction from tuples up to size 8. An+-- 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.Kind (Type)+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))++-- | Convert a tuple of types formed by the application of a common+-- type constructor to a tuple of the common type constructor and a+-- list of the types to which it is applied in the original+-- tuple. E.g. @TupleToRecArgs f (f a, f b) ~ (f, [a,b])@.+type family TupleToRecArgs f t = (r :: (u -> Type, [u])) | r -> t where+  TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g, f h) =+    '(f, [a,b,c,d,e,z,g,h])+  TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g) = '(f, [a,b,c,d,e,z,g])+  TupleToRecArgs f (f a, f b, f c, f d, f e, f z) = '(f, [a,b,c,d,e,z])+  TupleToRecArgs f (f a, f b, f c, f d, f e) = '(f, [a,b,c,d,e])+  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.+type family UncurriedRec (t :: (u -> Type, [u])) = r | r -> t where+  UncurriedRec '(f, ts) = Rec f ts++-- | Apply the 'XRec' type constructor to a type-level tuple of its+-- arguments.+type family UncurriedXRec (t :: (u -> Type, [u])) = r | r -> t where+  UncurriedXRec '(f, ts) = XRec f ts++-- | Convert between an 'XRec' and an isomorphic tuple.+class TupleXRec f t where+  -- | Convert an 'XRec' to a tuple. Useful for pattern matching on an+  -- entire record.+  xrecTuple :: XRec f t -> ListToHKDTuple f t+  -- | Build an 'XRec' from a tuple.+  xrecX :: ListToHKDTuple f t -> XRec f t++instance TupleXRec f '[a,b] where+  xrecTuple (a ::& b ::& XRNil) = (a, b)+  xrecX (a, b) = a ::& b ::& XRNil++instance TupleXRec f '[a,b,c] where+  xrecTuple (a ::& b ::& c ::& XRNil) = (a, b, c)+  xrecX (a, b, c) = a ::& b ::& c ::& XRNil++instance TupleXRec f '[a,b,c,d] where+  xrecTuple (a ::& b ::& c ::& d ::& XRNil) = (a, b, c, d)+  xrecX (a, b, c, d) = a ::& b ::& c ::& d ::& XRNil++instance TupleXRec f '[a,b,c,d,e] where+  xrecTuple (a ::& b ::& c ::& d ::& e ::& XRNil) =+    (a, b, c, d, e)+  xrecX (a, b, c, d, e) = a ::& b ::& c ::& d ::& e ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z] where+  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& XRNil) =+    (a, b, c, d, e, z)+  xrecX (a, b, c, d, e, z) = a ::& b ::& c ::& d ::& e ::& z ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z,g] where+  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil) =+    (a, b, c, d, e, z, g)+  xrecX (a, b, c, d, e, z, g) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil++instance TupleXRec f '[a,b,c,d,e,z,g,h] where+  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil) =+    (a, b, c, d, e, z, g, h)+  xrecX (a, b, c, d, e, z, g, h) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil++type family ListToHKDTuple (f :: u -> Type) (ts :: [u]) :: Type 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)+  ListToHKDTuple f '[a,b,c,d,e] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e)+  ListToHKDTuple f '[a,b,c,d,e,z] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z)+  ListToHKDTuple f '[a,b,c,d,e,z,g] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g)+  ListToHKDTuple f '[a,b,c,d,e,z,g,h] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g, HKD f h)+  ListToHKDTuple f x = TypeError ('Text "Tuples are only supported up to size 8")++-- | Convert a 'Rec' to a tuple going through 'HKD' to reduce+-- syntactic noise. Useful for pattern matching on an entire 'Rec'.+ruple :: (IsoXRec f ts, TupleXRec f ts)+      => Rec f ts -> ListToHKDTuple f ts+ruple = xrecTuple . toXRec++-- | Build a 'Rec' from a tuple passing through 'XRec'. This admits+-- the most concise syntax for building a 'Rec'. For example, @xrec+-- ("joe", 23) :: Rec Identity '[String, Int]@.+xrec :: (IsoXRec f t, TupleXRec f t) => ListToHKDTuple f t -> Rec f t+xrec = fromXRec . xrecX++-- | Build a 'Rec' from a tuple. An example would be building a value+-- of type @Rec f '[a,b]@ from a tuple of values with type @'(f a, f+-- b)@.+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++instance TupleRec f (f a, f b, f c) where+  record (a,b,c) = a :& b :& c :& RNil++instance TupleRec f (f a, f b, f c, f d) where+  record (a,b,c,d) = a :& b :& c :& d :& RNil++instance TupleRec f (f a, f b, f c, f d, f e) where+  record (a,b,c,d,e) = a :& b :& c :& d :& e :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z) where+  record (a,b,c,d,e,z) = a :& b :& c :& d :& e :& z :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z, f g) where+  record (a,b,c,d,e,z,g) = a :& b :& c :& d :& e :& z :& g :& RNil++instance TupleRec f (f a, f b, f c, f d, f e, f z, f g, f h) where+  record (a,b,c,d,e,z,g,h) = a :& b :& c :& d :& e :& z :& g :& h :& RNil++-- | 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
@@ -1,26 +1,71 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} -module Data.Vinyl.Functor where+module Data.Vinyl.Functor+  ( -- * Introduction+    -- $introduction+    -- * Data Types+    Identity(..)+  , Thunk(..)+  , Lift(..)+  , ElField(..)+  , Compose(..), onCompose+  , (:.)+  , Const(..)+    -- * Discussion -import Control.Applicative-import Data.Foldable-import Data.Traversable+    -- ** Example+    -- $example++    -- ** Ecosystem+    -- $ecosystem+  ) where++import Data.Proxy+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import Foreign.Ptr (castPtr) import Foreign.Storable+import GHC.Generics+import GHC.TypeLits+import GHC.Types (Type)+import Data.Vinyl.TypeLevel (Snd) +{- $introduction+    This module provides functors and functor compositions+    that can be used as the interpretation function for a+    'Rec'. For a more full discussion of this, scroll down+    to the bottom.+-}++-- | This is identical to the "Identity" from "Data.Functor.Identity"+-- in "base" except for its 'Show' instance. newtype Identity a   = Identity { getIdentity :: a }     deriving ( Functor              , Foldable              , Traversable              , Storable+             , Eq+             , Ord+             , Generic              ) +-- | Used this instead of 'Identity' to make a record+--   lazy in its fields. data Thunk a   = Thunk { getThunk :: a }     deriving ( Functor@@ -33,9 +78,23 @@  newtype Compose (f :: l -> *) (g :: k -> l) (x :: k)   = Compose { getCompose :: f (g x) }-    deriving (Storable)+    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 :.  newtype Const (a :: *) (b :: k)   = Const { getConst :: a }@@ -43,8 +102,80 @@              , Foldable              , Traversable              , Storable+             , Generic              ) +-- | A value with a phantom 'Symbol' label. It is not a+-- Haskell 'Functor', but it is used in many of the same places a+-- 'Functor' is used in vinyl.+--+-- Morally: newtype ElField (s, t) = Field t+-- But GHC doesn't allow that+newtype ElField (t :: (Symbol, Type)) = Field (Snd t)++deriving instance Eq t => Eq (ElField '(s,t))+deriving instance Ord t => Ord (ElField '(s,t))++instance KnownSymbol s => Generic (ElField '(s,a)) where+  type Rep (ElField '(s,a)) = C1 ('MetaCons s 'PrefixI 'False) (Rec0 a)+  from (Field x) = M1 (K1 x)+  to (M1 (K1 x)) = Field x++instance (Num t, KnownSymbol s) => Num (ElField '(s,t)) where+  Field x + Field y = Field (x+y)+  Field x * Field y = Field (x*y)+  abs (Field x) = Field (abs x)+  signum (Field x) = Field (signum x)+  fromInteger = Field . fromInteger+  negate (Field x) = Field (negate x)++instance Semigroup t => Semigroup (ElField '(s,t)) where+  Field x <> Field y = Field (x <> y)++instance (KnownSymbol s, Monoid t) => Monoid (ElField '(s,t)) where+  mempty = Field mempty+  mappend (Field x) (Field y) = Field (mappend x y)++instance (Real t, KnownSymbol s) => Real (ElField '(s,t)) where+  toRational (Field x) = toRational x++instance (Fractional t, KnownSymbol s) => Fractional (ElField '(s,t)) where+  fromRational = Field . fromRational+  Field x / Field y = Field (x / y)++instance (Floating t, KnownSymbol s) => Floating (ElField '(s,t)) where+  pi = Field pi+  exp (Field x) = Field (exp x)+  log (Field x) = Field (log x)+  sin (Field x) = Field (sin x)+  cos (Field x) = Field (cos x)+  asin (Field x) = Field (asin x)+  acos (Field x) = Field (acos x)+  atan (Field x) = Field (atan x)+  sinh (Field x) = Field (sinh x)+  cosh (Field x) = Field (cosh x)+  asinh (Field x) = Field (asinh x)+  acosh (Field x) = Field (acosh x)+  atanh (Field x) = Field (atanh x)++instance (RealFrac t, KnownSymbol s) => RealFrac (ElField '(s,t)) where+  properFraction (Field x) = fmap Field (properFraction x)++instance (Show t, KnownSymbol s) => Show (ElField '(s,t)) where+  show (Field x) = symbolVal (Proxy::Proxy s) ++" :-> "++show x++instance forall s t. (KnownSymbol s, Storable t)+    => Storable (ElField '(s,t)) where+  sizeOf _ = sizeOf (undefined::t)+  alignment _ = alignment (undefined::t)+  peek ptr = Field `fmap` peek (castPtr ptr)+  poke ptr (Field x) = poke (castPtr ptr) x+instance Show a => Show (Const a b) where+  show (Const x) = "(Const "++show x ++")"++instance Eq a => Eq (Const a b) where+  Const x == Const y = x == y+ instance (Functor f, Functor g) => Functor (Compose f g) where   fmap f (Compose x) = Compose (fmap (fmap f) x) @@ -58,6 +189,9 @@   pure x = Compose (pure (pure x))   Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +instance Show (f (g a)) => Show (Compose f g a) where+  show (Compose x) = show x+ instance Applicative Identity where   pure = Identity   Identity f <*> Identity x = Identity (f x)@@ -91,3 +225,99 @@   pure x = Lift (pure x, pure x)   Lift (f, g) <*> Lift (x, y) = Lift (f <*> x, g <*> y) +-- $setup+-- >>> import Data.Vinyl.Core+-- >>> :set -XDataKinds+--++{- $example+    The data types in this module are used to build interpretation+    fuctions for a 'Rec'. To build a 'Rec' that is simply a heterogeneous+    list, use 'Identity':++>>> :{+let myRec1 :: Rec Identity '[Int,Bool,Char]+    myRec1 = Identity 4 :& Identity True :& Identity 'c' :& RNil+:}++    For a record in which the fields are optional, you could alternatively+    write:++>>> :{+let myRec2 :: Rec Maybe '[Int,Bool,Char]+    myRec2 = Just 4 :& Nothing :& Nothing :& RNil+:}++    And we can gather all of the effects with 'rtraverse':++>>> let r2 = rtraverse (fmap Identity) myRec2+>>> :t r2+r2 :: Maybe (Rec Identity '[Int, Bool, Char])+>>> r2+Nothing++    If the fields only exist once an environment is provided, you can+    build the record as follows:++>>> :{+let myRec3 :: Rec ((->) Int) '[Int,Bool,Char]+    myRec3 = (+5) :& (const True) :& (head . show) :& RNil+:}++    And again, we can collect these effects with "rtraverse":++>>> (rtraverse (fmap Identity) myRec3) 8+{13, True, '8'}++    If you want the composition of these two effects, you can use "Compose":++>>> import Data.Char (chr)+>>> :{+let safeDiv a b = if b == 0 then Nothing else Just (div a b)+    safeChr i = if i >= 32 && i <= 126 then Just (chr i) else Nothing+    myRec4 :: Rec (Compose ((->) Int) Maybe) '[Int,Char]+    myRec4 = (Compose $ safeDiv 42) :& (Compose safeChr) :& RNil+:}++-}++{- $ecosystem+    Of the five data types provided by this modules, three can+    be found in others places: "Identity", "Compose", and "Const".+    They are included with "vinyl" to help keep the dependency+    list small. The differences will be discussed here.++    The "Data.Functor.Identity" module was originally provided+    by "transformers". When GHC 7.10 was released, it was moved+    into "base-4.8". The "Identity" data type provided by that+    module is well recognized across the haskell ecosystem+    and has typeclass instances for lots of common typeclasses.+    The significant difference between it and the copy of+    it provided here is that this one has a different 'Show'+    instance. This is illustrated below:++>>> Identity "hello"+"hello"++    But, when using "Identity" from "base":++>>> import qualified Data.Functor.Identity as Base+>>> Base.Identity "hello"+Identity "hello"++    This 'Show' instance makes records look nicer in GHCi.+    Feel free to use "Data.Functor.Identity" if you do not+    need the prettier output or if you need the many additional+    typeclass instances that are provided for the standard+    "Identity".++    The story with "Compose" and "Const" is much more simple.+    These also exist in "transformers", although "Const"+    is named "Constant" there. Prior to the release of+    "transformers-0.5", they were not polykinded, making+    them unusable for certain universes. However, in+    "transformers-0.5" and forward, they have been made+    polykinded. This means that they are just as usable with 'Rec'+    as the vinyl equivalents but with many more typeclass+    instances such as 'Ord' and 'Show'.+-}
Data/Vinyl/Lens.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -7,10 +11,20 @@ {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE CPP                   #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif +-- | Lenses into record fields. module Data.Vinyl.Lens-  ( RElem(..)-  , RSubset(..)+  ( RecElem(..)+  , rget, rput, rput', rlens, rlens'+  , RElem+  , RecSubset(..)+  , rsubset, rcast, rreplace+  , rdowncast+  , RSubset   , REquivalent   , type (∈)   , type (⊆)@@ -19,105 +33,197 @@   , type (:~:)   ) where +import Data.Kind (Constraint) import Data.Vinyl.Core import Data.Vinyl.Functor import Data.Vinyl.TypeLevel-import Data.Typeable (Proxy(..))+#if __GLASGOW_HASKELL__ < 806+import Data.Kind+#endif --- | The presence of a field in a record is witnessed by a lens into its value.--- The third parameter to 'RElem', @i@, is there to help the constraint solver--- realize that this is a decidable predicate with respect to the judgemental--- equality in @k@.-class i ~ RIndex r rs => RElem (r :: k) (rs :: [k]) (i :: Nat) where+-- | The presence of a field in a record is witnessed by a lens into+-- its value.  The fifth parameter to 'RecElem', @i@, is there to help+-- the constraint solver realize that this is a decidable predicate+-- with respect to the judgemental equality in @k@.+class (i ~ RIndex r rs, NatToInt i)+  => RecElem (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) (i :: Nat) | r r' rs i -> rs' where+  -- | An opportunity for instances to generate constraints based on+  -- the functor parameter of records passed to class methods.+  type RecElemFCtx record (f :: k -> *) :: Constraint+  type RecElemFCtx record f = ()    -- | We can get a lens for getting and setting the value of a field which is   -- in a record. As a convenience, we take a proxy argument to fix the   -- particular field being viewed. These lenses are compatible with the @lens@   -- library. Morally:   ---  -- > rlens :: sing r => Lens' (Rec f rs) (f r)-  rlens-    :: Functor g-    => sing r-    -> (f r -> g (f r))-    -> Rec f rs-    -> g (Rec f rs)+  -- > rlensC :: Lens' (Rec f rs) (Rec f rs') (f r) (f r')+  rlensC+    :: (Functor g, RecElemFCtx record f)+    => (f r -> g (f r'))+    -> record f rs+    -> g (record f rs')    -- | For Vinyl users who are not using the @lens@ package, we provide a getter.-  rget-    :: sing r-    -> Rec f rs+  rgetC+    :: (RecElemFCtx record f, r ~ r')+    => record 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,   -- and so we do not take a proxy argument here.-  rput-    :: f r-    -> Rec f rs-    -> Rec f rs-  rput y = getIdentity . rlens Proxy (\_ -> Identity y)+  rputC+    :: RecElemFCtx record f+    => f r'+    -> record f rs+    -> record f rs' +-- | 'RecElem' for classic vinyl 'Rec' types.+type RElem x rs = RecElem Rec x x rs rs+ -- This is an internal convenience stolen from the @lens@ library. lens   :: Functor f-  => (t -> s)-  -> (t -> a -> b)-  -> (s -> f a)-  -> t-  -> f b+  => (s -> a)+  -> (s -> b -> t)+  -> (a -> f b)+  -> s+  -> f t lens sa sbt afb s = fmap (sbt s) $ afb (sa s) {-# INLINE lens #-} -instance RElem r (r ': rs) Z where-  rlens _ f (x :& xs) = fmap (:& xs) (f x)-  {-# INLINE rlens #-}+instance RecElem Rec r r' (r ': rs) (r' ': rs) 'Z where+  rlensC f (x :& xs) = fmap (:& xs) (f x)+  {-# INLINE rlensC #-}+  rgetC = getConst . rlensC Const+  {-# INLINE rgetC #-}+  rputC y = getIdentity . rlensC @_ @_ @r (\_ -> Identity y)+  {-# INLINE rputC #-} -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 #-}+instance (RIndex r (s ': rs) ~ 'S i, RecElem Rec r r' rs rs' i)+  => RecElem Rec r r' (s ': rs) (s ': rs') ('S i) where+  rlensC f (x :& xs) = fmap (x :&) (rlensC f xs)+  {-# INLINE rlensC #-}+  rgetC = getConst . rlensC @_ @_ @r @r' Const+  {-# INLINE rgetC #-}+  rputC y = getIdentity . rlensC @_ @_ @r (\_ -> Identity y)+  {-# INLINE rputC #-} +--  | The 'rgetC' field getter with the type arguments re-ordered for+--  more convenient usage with @TypeApplications@.+rget :: forall r rs f record.+        (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)+     => record f rs -> f r+rget = rgetC++-- | The type-changing field setter 'rputC' with the type arguments+-- re-ordered for more convenient usage with @TypeApplications@.+rput' :: forall k (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) record f+       . (RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f)+      => f r' -> record f rs -> record f rs'+rput' = rputC @k @record @r @r' @rs @rs'++-- | Type-preserving field setter. This type is simpler to work with+-- than that of 'rput''.+rput :: forall k (r :: k) rs record f. (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)+      => f r -> record f rs -> record f rs+rput = rput' @_ @r @r @rs @rs @record++-- | Type-changing field lens 'rlensC' with the type arguments+-- re-ordered for more convenient usage with @TypeApplications@.+rlens' :: forall r r' record rs rs' f g.+          (RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f, Functor g)+       => (f r -> g (f r')) -> record f rs -> g (record f rs')+rlens' = rlensC++-- | Type-preserving field lens. This type is simpler to work with+-- than that of 'rlens''.+rlens :: forall r record rs f g.+         (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f, Functor g)+       => (f r -> g (f r)) -> record f rs -> g (record f rs)+rlens = rlensC+ -- | 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 -- record to a smaller one, or we may replace the values in a slice of a -- record.-class is ~ RImage rs ss => RSubset (rs :: [k]) (ss :: [k]) is where+class is ~ RImage rs ss => RecSubset record rs ss is where+  -- | An opportunity for instances to generate constraints based on+  -- the functor parameter of records passed to class methods.+  type RecSubsetFCtx record (f :: k -> *) :: Constraint+  type RecSubsetFCtx record f = ()    -- | This is a lens into a slice of the larger record. Morally, we have:   --   -- > rsubset :: Lens' (Rec f ss) (Rec f rs)-  rsubset-    :: Functor g-    => (Rec f rs -> g (Rec f rs))-    -> Rec f ss-    -> g (Rec f ss)+  rsubsetC+    :: (Functor g, RecSubsetFCtx record f)+    => (record f rs -> g (record f rs))+    -> record f ss+    -> g (record f ss)    -- | The getter of the 'rsubset' lens is 'rcast', which takes a larger record   -- to a smaller one by forgetting fields.-  rcast-    :: Rec f ss-    -> Rec f rs-  rcast = getConst . rsubset Const-  {-# INLINE rcast #-}+  rcastC+    :: RecSubsetFCtx record f+    => record f ss+    -> record f rs+  rcastC = getConst . rsubsetC Const+  {-# INLINE rcastC #-}    -- | The setter of the 'rsubset' lens is 'rreplace', which allows a slice of   -- a record to be replaced with different values.-  rreplace-    :: Rec f rs-    -> Rec f ss-    -> Rec f ss-  rreplace rs = getIdentity . rsubset (\_ -> Identity rs)-  {-# INLINE rreplace #-}+  rreplaceC+    :: RecSubsetFCtx record f+    => record f rs+    -> record f ss+    -> record f ss+  rreplaceC rs = getIdentity . rsubsetC (\_ -> Identity rs)+  {-# INLINE rreplaceC #-} -instance RSubset '[] ss '[] where-  rsubset = lens (const RNil) const+-- | A lens into a slice of the larger record. This is 'rsubsetC' with+-- the type arguments reordered for more convenient usage with+-- @TypeApplications@.+rsubset :: forall k rs ss f g record is.+           (RecSubset record (rs :: [k]) (ss :: [k]) is,+           Functor g, RecSubsetFCtx record f)+        => (record f rs -> g (record f rs)) -> record f ss -> g (record f ss)+rsubset = rsubsetC -instance (RElem r ss i , RSubset rs ss is) => RSubset (r ': rs) ss (i ': is) where-  rsubset = lens (\ss -> rget Proxy ss :& rcast ss) set+-- | Takes a larger record to a smaller one by forgetting fields. This+-- is 'rcastC' with the type arguments reordered for more convenient+-- usage with @TypeApplications@.+rcast :: forall rs ss f record is.+        (RecSubset record rs ss is, RecSubsetFCtx record f)+      => record f ss -> record f rs+rcast = rcastC++-- | Allows a slice of a record to be replaced with different+-- values. This is 'rreplaceC' with the type arguments reordered for+-- more convenient usage with @TypeApplications@.+rreplace :: forall rs ss f record is.+            (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++instance RecSubset Rec '[] ss '[] where+  rsubsetC = lens (const RNil) const++instance (RElem r ss i , RSubset rs ss is) => RecSubset Rec (r ': rs) ss (i ': is) where+  rsubsetC = lens (\ss -> rget ss :& rcastC ss) set     where       set :: Rec f ss -> Rec f (r ': rs) -> Rec f ss-      set ss (r :& rs) = rput r $ rreplace rs ss+      set ss (r :& rs) = rput r $ rreplaceC rs ss  -- | Two record types are equivalent when they are subtypes of each other. type REquivalent rs ss is js = (RSubset rs ss is, RSubset ss rs js)
+ Data/Vinyl/Recursive.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif++-- | Recursive definitions of various core vinyl functions. These are+-- simple definitions that put less strain on the compiler. They are+-- expected to have slower run times, but faster compile times than+-- the definitions in "Data.Vinyl.Core".+module Data.Vinyl.Recursive where+#if __GLASGOW_HASKELL__ < 806+import Data.Kind+#endif+import Data.Proxy (Proxy(..))+import Data.Vinyl.Core (rpure, RecApplicative, Rec(..), Dict(..))+import Data.Vinyl.Functor (Compose(..), (:.), Lift(..), Const(..))+import Data.Vinyl.TypeLevel++-- | Two records may be pasted together.+rappend+  :: Rec f as+  -> Rec f bs+  -> Rec f (as ++ bs)+rappend RNil ys = ys+rappend (x :& xs) ys = x :& (xs `rappend` ys)++-- | A shorthand for 'rappend'.+(<+>)+  :: Rec f as+  -> Rec f bs+  -> Rec f (as ++ bs)+(<+>) = rappend++-- | '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@.+rmap+  :: (forall x. f x -> g x)+  -> Rec f rs+  -> Rec g rs+rmap _ RNil = RNil+rmap η (x :& xs) = η x :& (η `rmap` xs)+{-# INLINE rmap #-}++-- | A shorthand for 'rmap'.+(<<$>>)+  :: (forall x. f x -> g x)+  -> Rec f rs+  -> Rec g rs+(<<$>>) = rmap+{-# INLINE (<<$>>) #-}++-- | An inverted shorthand for 'rmap'.+(<<&>>)+  :: Rec f rs+  -> (forall x. f x -> g x)+  -> Rec g rs+xs <<&>> f = rmap f xs+{-# INLINE (<<&>>) #-}++-- | A record of components @f r -> g r@ may be applied to a record of @f@ to+-- get a record of @g@.+rapply+  :: Rec (Lift (->) f g) rs+  -> Rec f rs+  -> Rec g rs+rapply RNil RNil = RNil+rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs)+{-# INLINE rapply #-}++-- | A shorthand for 'rapply'.+(<<*>>)+  :: Rec (Lift (->) f g) rs+  -> Rec f rs+  -> Rec g rs+(<<*>>) = rapply+{-# INLINE (<<*>>) #-}++-- | A record may be traversed with respect to its interpretation functor. This+-- can be used to yank (some or all) effects from the fields of the record to+-- the outside of the record.+rtraverse+  :: Applicative h+  => (forall x. f x -> h (g x))+  -> Rec f rs+  -> h (Rec g rs)+rtraverse _ RNil      = pure RNil+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+  -> [a]+recordToList RNil = []+recordToList (x :& xs) = getConst x : recordToList xs+++-- | Sometimes we may know something for /all/ fields of a record, but when+-- you expect to be able to /each/ of the fields, you are then out of luck.+-- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly,+-- the constraint solver is not quite smart enough to realize this and we must+-- make it patently obvious by reifying the constraint pointwise with proof.+reifyConstraint+  :: RecAll f rs c+  => proxy c+  -> Rec f rs+  -> Rec (Dict c :. f) rs+reifyConstraint prx rec =+  case rec of+    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 u c (f :: u -> *) proxy ts.+                    (AllConstrained c ts, RecApplicative ts)+                 => proxy c -> (forall a. c a => f a) -> Rec f ts+rpureConstrained _ f = go (rpure Proxy)+  where go :: AllConstrained c ts' => Rec Proxy 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
+ Data/Vinyl/SRec.hs view
@@ -0,0 +1,411 @@+-- | 'Storable' records offer an efficient flat, packed representation+-- in memory. In particular, field access is constant time (i.e. it+-- doesn't depend on where in the record the field is) and as fast as+-- possible, but updating fields may not be as efficient. The+-- requirement is that all fields of a record have 'Storable'+-- instances.+--+-- The implementation leaks into the usual vinyl lens API: the+-- requirement of 'Storable' instances necessitates specialization on+-- the functor argument of the record so that GHC can find all+-- required instances at compile time (this is required for+-- constant-time field access). What we do is allow ourselves to write+-- instances of the 'RecElem' and 'RecSubset' classes (that provide+-- the main vinyl lens API) that are restricted to particular choices+-- of the record functor. This is why the 'SRec2' type that implements+-- records here takes two functor arguments: they will usually be the+-- same; we fix one when writing instances and write instance contexts+-- that reference that type, and then require that the methods+-- (e.g. 'rget') are called on records whose functor argument is equal+-- to the one we picked. For usability, we provide an 'SRec' type+-- whose lens API is fixed to 'ElField' as the functor. Other+-- specializations are possible, and the work of those instances can+-- always be passed along to the 'SRec2' functions.+--+-- Note that the lens field accessors for 'SRec' do not support+-- changing the types of the fields as they do for 'Rec' and+-- 'ARec'.+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif++-- We get warnings about incomplete patterns on various class+-- instances.+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+module Data.Vinyl.SRec (+  -- * Main record lens API+  SRec(..), toSRec, fromSRec+  -- * Lens API specialized to 'SRec2'+  , sget, sput, slens+  , srecGetSubset, srecSetSubset+  -- * Internals+  , toSRec2, fromSRec2, SRec2(..)+  , FieldOffset, FieldOffsetAux(..), StorableAt(..)+  , peekField, pokeField+) where+import Data.Coerce (coerce)+#if __GLASGOW_HASKELL__ < 806+import Data.Kind+#endif+import Data.Vinyl.Core+import Data.Vinyl.Functor (Lift(..), Compose(..), type (:.), ElField)+import Data.Vinyl.Lens (RecElem(..), RecSubset(..), type (⊆), RecElemFCtx)+import Data.Vinyl.TypeLevel (NatToInt, RImage, RIndex, Nat(..), RecAll, AllConstrained)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..))+import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)+#if __GLASGOW_HASKELL__ >= 900+import Unsafe.Coerce (unsafeCoerce#)+import GHC.Prim (touch#, RealWorld)+#else+import GHC.Prim (touch#, unsafeCoerce#, RealWorld)+#endif++import GHC.IO (IO(IO))+import GHC.Base (realWorld#)+import GHC.TypeLits (Symbol)+import GHC.Prim (MutableByteArray#, newAlignedPinnedByteArray#, byteArrayContents#)+import GHC.Ptr (Ptr(..))+import GHC.Types (Int(..))++-- * Byte array code adapted from the `memory` package.++data Bytes = Bytes (MutableByteArray# RealWorld)++newBytes :: Int -> IO Bytes+newBytes (I# n) = IO $ \s ->+  case newAlignedPinnedByteArray# n 8# s of+    (# s', mbarr #) -> (# s', Bytes mbarr #)++touchBytes :: Bytes -> IO ()+touchBytes (Bytes mbarr) = IO $ \s -> case touch# mbarr s of s' -> (# s', () #)+{-# INLINE touchBytes #-}++withBytesPtr :: Bytes -> (Ptr a -> IO r) -> IO r+withBytesPtr b@(Bytes mbarr) f = do+  f (Ptr (byteArrayContents# (unsafeCoerce# mbarr))) <* touchBytes b+{-# INLINE withBytesPtr #-}++-- * Pun ForeignPtr names to ease refactoring++newtype ForeignPtr (a :: k) = ForeignPtr Bytes++withForeignPtr :: ForeignPtr a -> (Ptr b -> IO r) -> IO r+withForeignPtr (ForeignPtr b) = withBytesPtr b+{-# INLINE withForeignPtr #-}++mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes = fmap ForeignPtr . newBytes+{-# INLINE mallocForeignPtrBytes #-}++-- * The SRec types++-- | A 'Storable'-backed 'Rec'. Each field of such a value has+-- statically known size, allowing for a very efficient representation+-- and very fast field access. The @2@ suffix is due to apparently+-- taking /two/ functor arguments, but the first type parameter is+-- phantom and exists so that we can write multiple instances of+-- 'RecElem' and 'RecSubset' for different functors. The first functor+-- argument will typically be identical to the second argument. We+-- currently provide instances for the 'ElField' functor; if you wish+-- to use it at a different type, consider using 'sget', 'sput', and+-- 'slens' which work with any functor given that the necessary+-- 'Storable' instances exist.+newtype SRec2 (g :: k -> *) (f :: k -> *) (ts :: [k]) =+  SRec2 (ForeignPtr (Rec f ts))++-- | A simpler type for 'SRec2' whose 'RecElem' and 'RecSubset'+-- instances are specialized to the 'ElField' functor.+newtype SRec f ts = SRecNT { getSRecNT :: SRec2 f f ts }++-- | Create an 'SRec2' from a 'Rec'.+toSRec2 :: forall f ts. Storable (Rec f ts) => Rec f ts -> SRec2 f f ts+toSRec2 x = unsafePerformIO $ do+  ptr <- mallocForeignPtrBytes (sizeOf (undefined :: Rec f ts))+  SRec2 ptr <$ (withForeignPtr ptr (flip poke x))+{-# NOINLINE toSRec2 #-}++-- | Create an 'SRec' from a 'Rec'. This should offer very fast field+-- access, but note that its lens API (via 'RecElem' and 'RecSubset')+-- is restricted to the 'ElField' functor.+toSRec :: Storable (Rec f ts) => Rec f ts -> SRec f ts+toSRec = SRecNT . toSRec2+{-# INLINE toSRec #-}++-- | Create a 'Rec' from an 'SRec2'.+fromSRec2 :: Storable (Rec f ts) => SRec2 g f ts -> Rec f ts+fromSRec2 (SRec2 ptr) = inlinePerformIO (withForeignPtr ptr peek)+{-# INLINE fromSRec2 #-}++-- | Create a 'Rec' from an 'SRec'.+fromSRec :: Storable (Rec f ts) => SRec f ts -> Rec f ts+fromSRec (SRecNT s) = fromSRec2 s+{-# INLINE fromSRec #-}++-- | Just like unsafePerformIO, but we inline it. Big performance gains as+-- it exposes lots of things to further inlining. /Very unsafe/. In+-- particular, you should do no memory allocation inside an+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.+--+-- Copied from the @text@ package+{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r++-- | Capture a 'Storable' dictionary along with a byte offset from+-- some origin address.+data StorableAt f a where+  StorableAt :: Storable (f a) => {-# UNPACK  #-} !Int -> StorableAt f a++-- | The ability to work with a particular field of a 'Rec' stored at+-- a 'Ptr'.+class (RIndex t ts ~ i, RecAll f ts Storable) => FieldOffsetAux f ts t i where+  -- | Get the byte offset of a field from the given origin and the+  -- 'Storable' dictionary needed to work with that field.+  fieldOffset :: Int -> StorableAt f t++-- | A more concise constraint equivalent to 'FieldOffsetAux'.+class FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where+instance FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where++instance (RecAll f (t ': ts) Storable) => FieldOffsetAux f (t ': ts) t 'Z where+  fieldOffset !n = StorableAt n+  {-# INLINE fieldOffset #-}++instance (RIndex t (s ': ts) ~ 'S i,+          FieldOffsetAux f ts t i,+          RecAll f (s ': ts) Storable)+  => FieldOffsetAux f (s ': ts) t ('S i) where+  fieldOffset !n = fieldOffset @f @ts @t @i (n + sizeOf (undefined :: f s))+  {-# INLINE fieldOffset #-}++-- | Set a field in a record stored at a 'ForeignPtr'.+pokeField :: forall f t ts. FieldOffset f ts t+          => ForeignPtr (Rec f ts) -> f t -> IO ()+pokeField fptr x = case fieldOffset @f @ts @t 0 of+                     StorableAt i -> withForeignPtr fptr $ \ptr ->+                                       pokeByteOff ptr i x+{-# INLINE pokeField #-}++-- | Get a field in a record stored at a 'ForeignPtr'.+peekField :: forall f t ts. FieldOffset f ts t+          => ForeignPtr (Rec f ts) -> IO (f t)+peekField fptr = case fieldOffset @f @ts @t 0 of+                   StorableAt i -> withForeignPtr fptr $ \ptr ->+                                     peekByteOff ptr i+{-# INLINE peekField #-}++-- | Get a field from an 'SRec'.+sget :: forall f t ts. FieldOffset f ts t+     => SRec2 f f ts -> f t+sget (SRec2 ptr) = inlinePerformIO (peekField ptr)+{-# INLINE sget #-}++mallocAndCopy :: ForeignPtr a -> Int -> IO (ForeignPtr a)+mallocAndCopy src n = do+  dst <- mallocForeignPtrBytes n+  withForeignPtr src $ \src' ->+    withForeignPtr dst $ \dst' ->+      dst <$ copyBytes dst' src' n++-- | Set a field.+sput :: forall u (f :: u -> *) (t :: u) (ts :: [u]).+        ( FieldOffset f ts t+        , Storable (Rec f ts)+        , AllConstrained (FieldOffset f ts) ts)+     => f t -> SRec2 f f ts -> SRec2 f f ts+sput !x (SRec2 src) = unsafePerformIO $ do+  let !n = sizeOf (undefined :: Rec f ts)+  dst <- mallocAndCopy src n+  SRec2 dst <$ pokeField dst x+{-# INLINE [1] sput #-}++pokeFieldUnsafe :: forall f t ts. FieldOffset f ts t+                => f t -> SRec2 f f ts -> SRec2 f f ts+pokeFieldUnsafe x y@(SRec2 ptr) = unsafeDupablePerformIO (y <$ pokeField ptr x)+{-# INLINE [1] pokeFieldUnsafe #-}++{-# RULES+"sput" forall x y z. sput x (sput y z) = pokeFieldUnsafe x (sput y z)+"sputUnsafe" forall x y z. sput x (pokeFieldUnsafe y z) = pokeFieldUnsafe x (pokeFieldUnsafe y z)+  #-}++-- | A lens for a field of an 'SRec2'.+slens :: ( Functor g+         , FieldOffset f ts t+         , Storable (Rec f ts)+         , AllConstrained (FieldOffset f ts) ts)+      => (f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)+slens f sr = fmap (flip sput sr) (f (sget sr))+{-# INLINE slens #-}++-- Note: we need the functor to appear in the instance head so that we+-- can demand the needed 'Storable' instances. We do this by giving+-- 'SRec2' a phantom tag that duplicates the "real" functor parameter,+-- and define a constraint that the real argument is in fact+-- 'ElField'. This lets us write instances for different applications+-- of @SRec2@ (e.g. instance for @SRec2 Foo@ for records of type+-- @SRec2 Foo Foo ts@, and an instance for @SRec2 Bar@ for records of+-- type @SRec2 Bar Bar ts@).++-- | Field accessors for 'SRec2' specialized to 'ElField' as the+-- functor.+instance ( i ~ RIndex t ts+         , NatToInt i+         , FieldOffset ElField ts t+         , Storable (Rec ElField ts)+         , AllConstrained (FieldOffset ElField ts) ts)+  => RecElem (SRec2 ElField) t t ts ts i where+  type RecElemFCtx (SRec2 ElField) f = f ~ ElField+  rlensC = slens+  {-# INLINE rlensC #-}+  rgetC = sget+  {-# INLINE rgetC #-}+  rputC = sput+  {-# INLINE rputC #-}+++coerceSRec1to2 :: SRec f ts -> SRec2 f f ts+coerceSRec1to2 = coerce++coerceSRec2to1 :: SRec2 f f ts -> SRec f ts+coerceSRec2to1 = coerce++instance ( i ~ RIndex (t :: (Symbol,*)) (ts :: [(Symbol,*)])+         , NatToInt i+         , FieldOffset ElField ts t+         , Storable (Rec ElField ts)+         , AllConstrained (FieldOffset ElField ts) ts)+  => RecElem SRec (t :: (Symbol,*)) t (ts :: [(Symbol,*)]) ts i where+  type RecElemFCtx SRec f = f ~ ElField+  rlensC f = fmap coerceSRec2to1 . slens f . coerceSRec1to2+  {-# INLINE rlensC #-}+  rgetC = sget . coerceSRec1to2+  {-# INLINE rgetC #-}+  rputC x = coerceSRec2to1 . sput x . coerceSRec1to2+  {-# INLINE rputC #-}++-- | Get a subset of a record's fields.+srecGetSubset :: forall u (ss :: [u]) (rs :: [u]) (f :: u -> *).+                 (RPureConstrained (FieldOffset f ss) rs,+                  RPureConstrained (FieldOffset f rs) rs,+                  RFoldMap rs, RMap rs, RApply rs,+                  Storable (Rec f rs))+              => SRec2 f f ss -> SRec2 f f rs+srecGetSubset (SRec2 ptr) = unsafeDupablePerformIO $ do+  dst <- mallocForeignPtrBytes (sizeOf (undefined :: Rec f rs))+  SRec2 dst <$ (withForeignPtr dst $ \dst' ->+                 rfoldMap @rs unTagIO (peekSmallPokeBig dst'))+  where peekers :: Rec (IO :. f) rs+        peekers = rpureConstrained @(FieldOffset f ss) mkPeeker+        {-# INLINE peekers #-}+        mkPeeker :: FieldOffset f ss t => (IO :. f) t+        mkPeeker = Compose (peekField ptr)+        {-# INLINE mkPeeker #-}+        pokers :: Ptr (Rec f rs) -> Rec (Poker f) rs+        pokers dst = rpureConstrained @(FieldOffset f rs) (mkPoker dst)+        {-# INLINE pokers #-}+        mkPoker :: forall t. Ptr (Rec f rs) -> FieldOffset f rs t => Poker f t+        mkPoker dst = case fieldOffset @f @rs @t 0 of+                        StorableAt i -> Lift (TaggedIO . pokeByteOff dst i)+        {-# INLINE mkPoker #-}+        peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t+        peekNPoke (Compose m) (Lift f) = TaggedIO (m >>= unTagIO . f)+        {-# INLINE peekNPoke #-}+        peekSmallPokeBig :: Ptr (Rec f rs) -> Rec TaggedIO rs+        peekSmallPokeBig dst' = Lift . peekNPoke <<$>> peekers <<*>> pokers dst'+{-# INLINE srecGetSubset #-}++-- | Phantom tagged 'IO ()' value. Used to work with vinyl's 'Lift'+-- that wants @forall a. f a -> g a@.+newtype TaggedIO a = TaggedIO { unTagIO :: IO () }++-- | A dressed up function of type @f a -> IO ()@+type Poker f = Lift (->) f TaggedIO++-- | Set a subset of a record's fields.+srecSetSubset :: forall u (f :: u -> *) (ss :: [u]) (rs :: [u]).+                 (rs ⊆ ss,+                  RPureConstrained (FieldOffset f ss) rs,+                  RPureConstrained (FieldOffset f rs) rs,+                  RFoldMap rs, RMap rs, RApply rs,+                  Storable (Rec f ss))+              => SRec2 f f ss -> SRec2 f f rs -> SRec2 f f ss+srecSetSubset (SRec2 srcBig) (SRec2 srcSmall) = unsafeDupablePerformIO $ do+  let n = sizeOf (undefined :: Rec f ss)+  dst <- mallocForeignPtrBytes n+  withForeignPtr srcBig $ \srcBig' ->+    withForeignPtr dst $ \dst' ->+      copyBytes dst' srcBig' n+  SRec2 dst <$ (withForeignPtr dst $ \dst' ->+                 rfoldMap @rs unTagIO+                           (Lift . peekNPoke <<$>> peekers <<*>> pokers dst'))+  where peekers :: Rec (IO :. f) rs+        peekers = rpureConstrained @(FieldOffset f rs) mkPeeker+        {-# INLINE peekers #-}+        mkPeeker :: FieldOffset f rs t => (IO :. f) t+        mkPeeker = Compose (peekField srcSmall)++        pokers :: Ptr (Rec f ss) -> Rec (Poker f) rs+        pokers dst = rpureConstrained @(FieldOffset f ss) (mkPoker dst)+        {-# INLINE pokers #-}+        mkPoker :: forall t. FieldOffset f ss t => Ptr (Rec f ss) -> Poker f t+        mkPoker dst = case fieldOffset @f @ss @t 0 of+                        StorableAt i -> Lift (TaggedIO . pokeByteOff dst i)+        {-# INLINE mkPoker #-}+        peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t+        peekNPoke (Compose m) (Lift f) = TaggedIO (m >>= unTagIO . f)+        {-# INLINE peekNPoke #-}+{-# INLINE srecSetSubset #-}++instance (is ~ RImage rs ss,+          RecSubset Rec rs ss is,+          Storable (Rec ElField rs),+          Storable (Rec ElField ss),+          RPureConstrained (FieldOffset ElField ss) rs,+          RPureConstrained (FieldOffset ElField rs) rs,+          RFoldMap rs, RMap rs, RApply rs)+  => RecSubset (SRec2 ElField) rs ss is where+  type RecSubsetFCtx (SRec2 ElField) f = f ~ ElField+  rsubsetC :: forall g. Functor g+           => (SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs))+           -> SRec2 ElField ElField ss+           -> g (SRec2 ElField ElField ss)+  rsubsetC f big@(SRec2 _) = fmap (srecSetSubset big) (f smallRec)+    where smallRec :: SRec2 ElField ElField rs+          smallRec = srecGetSubset big+          {-# INLINE smallRec #-}+  {-# INLINE rsubsetC #-}++instance (is ~ RImage rs ss,+          RecSubset Rec rs ss is,+          Storable (Rec ElField rs),+          Storable (Rec ElField ss),+          RPureConstrained (FieldOffset ElField ss) rs,+          RPureConstrained (FieldOffset ElField rs) rs,+          RFoldMap rs, RMap rs, RApply rs)+  => RecSubset SRec rs ss is where+  type RecSubsetFCtx SRec f = f ~ ElField+  rsubsetC f (SRecNT s) = SRecNT <$> rsubsetC (fmap getSRecNT . f . SRecNT) s+  {-# INLINE rsubsetC #-}
+ Data/Vinyl/Syntax.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, InstanceSigs,+             MultiParamTypeClasses, ScopedTypeVariables,+             TypeApplications, TypeFamilies, TypeOperators,+             UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Concise vinyl record field lens syntax. This module exports an+-- orphan instance to make working with labels a bit more powerful. It+-- will conflict with other libraries that provide special syntax for+-- labels (i.e. placing a label in function application position, as+-- in @#age 23@, or using a label as a lens).+--+-- Example:+-- @fieldRec (#x =: True, #y =: 'b') :: FieldRec '[ '("x", Bool), '("y", Char) ]@+-- @fieldRec (#x =: True, #y =: 'b') & #x %~ not@+module Data.Vinyl.Syntax where+import Data.Vinyl.Derived (HasField, (:::), rfield)+import Data.Vinyl.Functor (ElField)+import Data.Vinyl.Lens (RecElemFCtx, rlens')+import GHC.OverloadedLabels (IsLabel(..))+-- import GHC.TypeLits (KnownSymbol)++-- | Concise record construction syntax. Example: @record (#name "Joe", #age 23)@.+-- instance forall s a b. (KnownSymbol s, b ~ ElField '(s,a))+--   => IsLabel s (a -> b) where+-- #if __GLASGOW_HASKELL__ < 802+--   fromLabel _ = Field @s @a+-- #else+--   fromLabel = Field @s @a+-- #endif++-- | Concise 'ElField' lenses. Example @myRec & #name %~ map+-- toUpper@.+--+-- Credit to Tikhon Jelvis who shared this technique on the+-- Haskell-Cafe mailing list on December 23, 2017.+instance forall s t t' ts ts' f record a' b'.+  (HasField record s ts ts' t t', Functor f, RecElemFCtx record ElField,+   a' ~ (t -> f t'), b' ~ (record ElField ts -> f (record ElField ts')))+  => IsLabel s (a' -> b') where+#if __GLASGOW_HASKELL__ < 802+  fromLabel _ = rlens' @(s ::: t) . rfield+#else+  fromLabel :: (t -> f t') -> (record ElField ts -> f (record ElField ts'))+  fromLabel = rlens' @(s ::: t) . rfield+#endif
+ Data/Vinyl/Tutorial/Overview.hs view
@@ -0,0 +1,297 @@+{-|++    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.++    Let's work through a quick example. We'll need to enable some language+    extensions first:++>>> :set -XDataKinds+>>> :set -XPolyKinds+>>> :set -XTypeApplications+>>> :set -XTypeOperators+>>> :set -XTypeFamilies+>>> :set -XFlexibleContexts+>>> :set -XFlexibleInstances+>>> :set -XNoMonomorphismRestriction+>>> :set -XGADTs+>>> :set -XTypeSynonymInstances+>>> :set -XTemplateHaskell+>>> :set -XStandaloneDeriving++>>> import Data.Vinyl+>>> import Data.Vinyl.Functor+>>> import Control.Applicative+>>> import Control.Lens hiding (Identity)+>>> import Control.Lens.TH+>>> import Data.Char+>>> import Test.DocTest+>>> import Data.Singletons.TH (genSingletons)+>>> import Data.Maybe++    Let's define a universe of fields which we want to use.++    First of all, we need a data type defining the field labels:++>>> data Fields = Name | Age | Sleeping | Master deriving Show++    Any record can be now described by a type-level list of these labels.+    The @DataKinds@ extension must be enabled to automatically turn all the+    constructors of the @Field@ type into types.++>>> type LifeForm = [Name, Age, Sleeping]++    Now, we need a way to map our labels to concrete types. We use a type+    family for this purpose. Unfortunately, type families aren't first class in Haskell.  That's+    why we also need a data type, with which we will parametrise 'Rec'.+    We also generate the necessary singletons for each field label using+    Template Haskell.++>>> :{+type family ElF (f :: Fields) :: * where+  ElF Name = String+  ElF Age = Int+  ElF Sleeping = Bool+  ElF Master = Rec Attr LifeForm+newtype Attr f = Attr { _unAttr :: ElF f }+makeLenses ''Attr+genSingletons [ ''Fields ]+instance Show (Attr Name) where show (Attr x) = "name: " ++ show x+instance Show (Attr Age) where show (Attr x) = "age: " ++ show x+instance Show (Attr Sleeping) where show (Attr x) = "sleeping: " ++ show x+instance Show (Attr Master) where show (Attr x) = "master: " ++ show x+:}++    To make field construction easier, we define an operator.  The first+    argument of this operator is a singleton - a constructor bringing the+    data-kinded field label type into the data level.  It's needed because+    there can be multiple labels with the same field type, so by just+    supplying a value of type @ElF f@ there would be no way to deduce the+    correct "f".++>>> :{+let (=::) :: sing f -> ElF f -> Attr f+    _ =:: x = Attr x+:}++    Now, let's try to make an entity that represents a human:++>>> :{+let jon = (SName =:: "jon")+       :& (SAge =:: 23)+       :& (SSleeping =:: False)+       :& RNil+:}++    Automatically, we can show the record:++>>> print jon+{name: "jon", age: 23, sleeping: False}++And its types are all inferred with no problem. Now, make a dog! Dogs+are life-forms, but unlike humans, they have masters. So, let’s build+my dog:++>>> :{+let tucker = (SName =:: "tucker")+          :& (SAge =:: 9)+          :& (SSleeping =:: True)+          :& (SMaster =:: jon)+          :& RNil+:}++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 humans (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:++>>> :{+let wakeUp :: (Sleeping ∈ fields) => Rec Attr fields -> Rec Attr fields+    wakeUp = rput $ SSleeping =:: 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.++>>> let tucker' = wakeUp tucker+>>> let jon' = wakeUp jon++>>> tucker' ^. rlens @Sleeping+sleeping: False++>>> tucker ^. rlens @Sleeping+sleeping: True++>>> jon' ^. rlens @Sleeping+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:++>>> let masterSleeping = rlens @Master . unAttr . rlens @Sleeping+>>> let tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker'++>>> tucker'' ^. masterSleeping+sleeping: True++A record @Rec f xs@ is a subtype of a record @Rec f 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:++>>> :{+let upcastedTucker :: Rec Attr LifeForm+    upcastedTucker = rcast tucker+:}++The subtyping relationship between record types is expressed with the+'<:' constraint; so, 'rcast' is of the following type:++> rcast :: r1 <: r2 => Rec f r2 -> Rec f r1++Also provided is a "≅" constraint which indicates record congruence+(that is, two record types differ only in the order of their fields).++In fact, 'rcast' is actually given as a special case of the lens 'rsubset',+which lets you modify entire (possibly non-contiguous) slices of a record!++Consider the following declaration:++> data Rec :: (u -> *) -> [u] -> * where+>   RNil :: Rec f '[]+>   (:&) :: f r -> Rec f rs -> Rec f (r ': rs)++Records are implicitly parameterized over a kind @u@, which stands for the+"universe" or key space. Keys (inhabitants of @u@) are then interpreted into+the types of their values by the first parameter to 'Rec', @f@. An extremely+powerful aspect of Vinyl records is that you can construct natural+transformations between different interpretation functors @f,g@, or postcompose+some other functor onto the stack. This can be used to immerse each field of a+record in some particular effect modality, and then the library functions can+be used to traverse and accumulate these effects.++Let\'s imagine that we want to do validation on a record that+represents a name and an age:++>>> type Person = [Name, Age]++We\'ve decided that names must be alphabetic, and ages must be positive. For+validation, we\'ll use 'Maybe' for now, though you should use a+left-accumulating @Validation@ type (the module @Data.Either.Validation@+from the @either@ package provides such a type, though we do not+cover it here).++>>> :{+let goodPerson :: Rec Attr Person+    goodPerson = (SName =:: "Jon")+              :& (SAge =:: 20)+              :& RNil+:}++>>> :{+let badPerson = (SName =:: "J#@#$on")+             :& (SAge =:: 20)+             :& RNil+:}++We\'ll give validation a (rather poor) shot.++>>> :{+let+    validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person)+    validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge+      where+      vName = validateName $ p ^. rlens @Name . unAttr+      vAge  = validateAge $ p ^. rlens @Age . unAttr+      validateName str | all isAlpha str = Just str+      validateName _ = Nothing+      validateAge i | i >= 0 = Just i+      validateAge _ = Nothing+:}++Let\'s try it out:++>>> isJust $ validatePerson goodPerson+True++>>> isJust $ validatePerson badPerson+False++The results are as expected (@Just@ for @goodPerson@, and a @Nothing@ 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.++>>> type Validator f = Lift (->) f (Maybe :. f)++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@:++>>> :{+let lift f = Lift $ Compose . f+    validateName (Attr str) | all isAlpha str = Just (Attr str)+    validateName _ = Nothing+    validateAge (Attr i) | i >= 0 = Just (Attr i)+    validateAge _ = Nothing+    vperson :: Rec (Validator Attr) Person+    vperson = lift validateName :& lift validateAge :& RNil+:}++And we can use the special application operator '<<*>>' (which is+analogous to '<*>', but generalized a bit) to use this to validate a+record:++>>> let goodPersonResult = vperson <<*>> goodPerson+>>> let badPersonResult  = vperson <<*>> badPerson++>>> isJust . getCompose $ goodPersonResult ^. rlens @Name+True++>>> isJust . getCompose $ goodPersonResult ^. rlens @Age+True++>>> isJust . getCompose $ badPersonResult ^. rlens @Name+False++>>> isJust . getCompose $ 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 @Maybe (Rec Attr Person)@) using `rtraverse`:++>>> :{+let mgoodPerson :: Maybe (Rec Attr Person)+    mgoodPerson = rtraverse getCompose goodPersonResult+:}++>>> let mbadPerson  = rtraverse getCompose badPersonResult++>>> isJust mgoodPerson+True++>>> isJust mbadPerson+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
Data/Vinyl/TypeLevel.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -6,27 +7,77 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE CPP                   #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE UndecidableInstances  #-}+#endif  module Data.Vinyl.TypeLevel where -import GHC.Exts+import Data.Coerce+import Data.Kind  -- | A mere approximation of the natural numbers. And their image as lifted by -- @-XDataKinds@ corresponds to the actual natural numbers. data Nat = Z | S !Nat +-- | Produce a runtime 'Int' value corresponding to a 'Nat' type.+class NatToInt (n :: Nat) where+  natToInt :: Int++instance NatToInt 'Z where+  natToInt = 0+  {-# INLINE natToInt #-}++instance NatToInt n => NatToInt ('S n) where+  natToInt = 1 + natToInt @n+  {-# INLINE natToInt #-}++-- | Reify a list of type-level natural number indices as runtime+-- 'Int's relying on instances of 'NatToInt'.+class IndexWitnesses (is :: [Nat]) where+  indexWitnesses :: [Int]++instance IndexWitnesses '[] where+  indexWitnesses = []+  {-# INLINE indexWitnesses #-}++instance (IndexWitnesses is, NatToInt i) => IndexWitnesses (i ': is) where+  indexWitnesses = natToInt @i : indexWitnesses @is+  {-# INLINE indexWitnesses #-}++-- | Project the first component of a type-level tuple.+type family Fst (a :: (k1,k2)) where Fst '(x,y) = x++-- | Project the second component of a type-level tuple.+type family Snd (a :: (k1,k2)) where Snd '(x,y) = y++type family RLength xs where+  RLength '[] = 'Z+  RLength (x ': xs) = 'S (RLength xs)+ -- | 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 occurrence 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 +88,42 @@   '[] ++ bs = bs   (a ': as) ++ bs = a ': (as ++ bs) +-- | Constraint that all types in a type-level list satisfy a+-- constraint.+type family AllConstrained (c :: u -> Constraint) (ts :: [u]) :: 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.+class AllSatisfied cs t where+instance AllSatisfied '[] t where+instance (c t, AllSatisfied cs t) => AllSatisfied (c ': cs) t where++-- | 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)++-- | 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++-- | This class is used for `consMatchCoercion` with older versions+-- of GHC.+class Coercible (f x) (g x) => Similar f g (x :: k)+instance Coercible (f x) (g x) => Similar f g (x :: k)
+ Data/Vinyl/XRec.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | A variant of 'Rec' whose values have eliminated common syntactic+-- clutter due to 'Identity', 'Compose', and 'ElField' type+-- constructors.+--+-- A common pain point with using 'Rec' is the mandatory /context/ of+-- each value. A basic record might look like this, @Identity "joe" :&+-- Identity 23 :& RNil :: Rec Identity '[String, Int]@. The 'Identity'+-- constructors are a nuisance, so we offer a way of avoiding them:+-- @"joe" ::& 23 ::& XRNil :: XRec Identity '[String,Int]@. Facilities+-- are provided for converting between 'XRec' and 'Rec' so that the+-- 'Rec' API is available even if you choose to use 'XRec' for+-- construction or pattern matching.+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)++type XRec f = Rec (XData f)+pattern (::&) :: HKD f r -> XRec f rs -> XRec f (r ': rs)+pattern x ::& xs = XData x :& xs+{-# COMPLETE (::&) #-}++infixr 7 ::&++pattern XRNil :: XRec f '[]+pattern XRNil = RNil+{-# COMPLETE XRNil #-}++-- | Like 'rmap', but the supplied function is written against the+-- 'HKD'-simplified types. This is 'xrmap' sandwiched in between+-- 'fromXRec' and 'toXRec'.+rmapX :: forall f g rs. (XRMap f g rs, IsoXRec f rs, IsoXRec g rs)+      => (forall a. HKD f a -> HKD g a) -> Rec f rs -> Rec g rs+rmapX f = fromXRec . xrmapAux aux . toXRec+  where aux :: forall a. XData f a -> XData g a+        aux = XData . f @a . unX++-- | This is 'rmapX' specialized to a type at which it does not change+-- interpretation functor. This can help with type inference.+rmapXEndo :: forall f rs. (XRMap f f rs, IsoXRec f rs)+          => (forall a. HKD f a -> HKD f a) -> Rec f rs -> Rec f rs+rmapXEndo f = fromXRec . xrmapAux aux . toXRec+  where aux :: forall a. XData f a -> XData f a+        aux = XData . f @a . unX++-- | This is 'rmap' for 'XRec'. We apply a natural transformation+-- between interpretation functors to transport a record value between+-- interpretations.+xrmap :: forall f g rs. XRMap f g rs+      => (forall a. HKD f a -> HKD g a) -> XRec f rs -> XRec g rs+xrmap f = xrmapAux aux+  where aux :: forall a. XData f a -> XData g a+        aux = XData . f @a . unX++-- | A wrapper for an 'HKD'-simplified value. That is, noisy value+-- constructors like 'Identity' and 'Compose' are ellided. This is+-- used in the 'xrmapAux' type class method, but may be ignored by+-- users whose needs are met by 'xrmap' and 'rmapX'.+newtype XData t a = XData { unX :: HKD t a }++-- | The implementation of 'xrmap' is broken into a type class to+-- permit unrolling of the recursion across a record. The function+-- mapped across the vector hides the 'HKD' type family under a newtype+-- constructor to help the type checker.+class XRMap f g rs where+  xrmapAux :: (forall a . XData f a -> XData g a) -> XRec f rs -> XRec g rs++instance XRMap f g '[] where+  xrmapAux _ RNil = RNil++instance forall f g r rs. (XRMap f g rs, IsoHKD f r, IsoHKD g r)+  => XRMap f g (r ': rs) where+  xrmapAux f (x :& xs) = f x :& xrmapAux f xs++-- | Like 'rapply': record of components @f r -> g r@ may be applied+-- to a record of @f@ to get a record of @g@.+class XRApply f g rs where+  xrapply :: XRec (Lift (->) f g) rs -> XRec f rs -> XRec g rs++instance XRApply f g '[] where+  xrapply RNil RNil = RNil++instance XRApply f g rs => XRApply f g (r ': rs) where+  xrapply (XData f :& fs) (XData x :& xs) = XData (f x) :& xrapply fs xs++-- | Conversion between 'XRec' and 'Rec'. It is convenient to build+-- and consume 'XRec' values to reduce syntactic noise, but 'Rec' has+-- a richer API that is difficult to build around the 'HKD' type+-- family.+class IsoXRec f ts where+  fromXRec :: XRec f ts -> Rec f ts+  toXRec :: Rec f ts -> XRec f ts++instance IsoXRec f '[] where+  fromXRec RNil = RNil+  toXRec RNil = XRNil++instance (IsoXRec f ts, IsoHKD f t) => IsoXRec f (t ': ts) where+  fromXRec (x ::& xs) = unHKD x :& fromXRec xs+  toXRec (x :& xs) = toHKD x ::& toXRec xs++-- | Isomorphism between a syntactically noisy value and a concise+-- one. For types like, 'Identity', we prefer to work with values of+-- the underlying type without writing out the 'Identity'+-- constructor. For @'Compose' f g a@, aka @(f :. g) a@, we prefer to+-- work directly with values of type @f (g a)@.+--+-- This involves the so-called /higher-kinded data/ type family. See+-- <http://reasonablypolymorphic.com/blog/higher-kinded-data> for more+-- discussion.+class IsoHKD f a where+  type HKD f a+  type HKD f a = f a+  unHKD :: HKD f a -> f a+  default unHKD :: HKD f a ~ f a => HKD f a -> f a+  unHKD = id+  toHKD :: f a -> HKD f a+  default toHKD :: (HKD f a ~ f a) => f a -> HKD f a+  toHKD = id++-- | Work with values of type 'Identity' @a@ as if they were simple of+-- type @a@.+instance IsoHKD Identity a where+  type HKD Identity a = a+  unHKD = Identity+  toHKD (Identity x) = x++-- | Work with values of type 'ElField' @'(s,a)@ as if they were of+-- type @a@.+instance KnownSymbol s => IsoHKD ElField '(s,a) where+  type HKD ElField '(s,a) = a+  unHKD = Field+  toHKD (Field x) = x++-- | Work with values of type 'Compose' @f g a@ as if they were of+-- type @f (g a)@.+instance (IsoHKD f (HKD g a), IsoHKD g a, Functor f) => IsoHKD (Compose f g) a where+  type HKD (Compose f g) a = HKD f (HKD g a)+  unHKD x = Compose (unHKD <$> unHKD x)+  toHKD (Compose fgx) = toHKD (toHKD <$> fgx)++-- | Work with values of type 'Lift' @(->) f g a@ as if they were of+-- type @f a -> g a@.+instance (IsoHKD f a, IsoHKD g a) => IsoHKD (Lift (->) f g) a where+  type HKD (Lift (->) f g) a = HKD f a -> HKD g a+  unHKD x = Lift (unHKD . x . toHKD)+  toHKD (Lift x) = toHKD . x . unHKD++instance IsoHKD IO a where+instance IsoHKD (Either a) b where+instance IsoHKD Maybe a where+instance IsoHKD First a where+instance IsoHKD Last a where+instance IsoHKD ((,) a) b where++-- | Work with values of type 'Sum' @a@ as if they were of type @a@.+instance IsoHKD Sum a where+  type HKD Sum a = a+  unHKD = Sum+  toHKD (Sum x) = x++-- | Work with values of type 'Product' @a@ as if they were of type @a@.+instance IsoHKD Product a where+  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
+ benchmarks/AccessorsBench.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE ScopedTypeVariables   #-}++import           Control.Monad (unless)+import           Criterion.Main+import Data.Monoid (Endo(..))+import           Data.Vinyl+import           Data.Vinyl.Syntax ()+import           Lens.Micro        ((%~), (&))+import           System.Exit       (exitFailure)++import           Bench.ARec+import           Bench.SRec+import           Bench.Rec++data HaskRec = HaskRec {+  a0 :: Int,+  a1 :: Int,+  a2 :: Int,+  a3 :: Int,+  a4 :: Int,+  a5 :: Int,+  a6 :: Int,+  a7 :: Int,+  a8 :: Int,+  a9 :: Int,+  a10 :: Int,+  a11 :: Int,+  a12 :: Int,+  a13 :: Int,+  a14 :: Int,+  a15 :: Int  } deriving Show++haskRec :: HaskRec+haskRec = HaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++sumHaskRec r =+    a0 r + a1 r + a2 r + a3 r + a4 r + a5 r + a6 r + a7 r + a8 r + a9 r+  + a10 r + a11 r + a12 r + a13 r + a14 r + a15 r++data StrictHaskRec = StrictHaskRec {+  sa0 :: !Int,+  sa1 :: !Int,+  sa2 :: !Int,+  sa3 :: !Int,+  sa4 :: !Int,+  sa5 :: !Int,+  sa6 :: !Int,+  sa7 :: !Int,+  sa8 :: !Int,+  sa9 :: !Int,+  sa10 :: !Int,+  sa11 :: !Int,+  sa12 :: !Int,+  sa13 :: !Int,+  sa14 :: !Int,+  sa15 :: !Int  }++shaskRec :: StrictHaskRec+shaskRec = StrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++sumSHaskRec r =+    sa0 r + sa1 r + sa2 r + sa3 r + sa4 r + sa5 r + sa6 r + sa7 r + sa8 r + sa9 r+  + sa10 r + sa11 r + sa12 r + sa13 r + sa14 r + sa15 r++data UStrictHaskRec = UStrictHaskRec {+  usa0 :: {-# UNPACK #-} !Int,+  usa1 :: {-# UNPACK #-} !Int,+  usa2 :: {-# UNPACK #-} !Int,+  usa3 :: {-# UNPACK #-} !Int,+  usa4 :: {-# UNPACK #-} !Int,+  usa5 :: {-# UNPACK #-} !Int,+  usa6 :: {-# UNPACK #-} !Int,+  usa7 :: {-# UNPACK #-} !Int,+  usa8 :: {-# UNPACK #-} !Int,+  usa9 :: {-# UNPACK #-} !Int,+  usa10 :: {-# UNPACK #-} !Int,+  usa11 :: {-# UNPACK #-} !Int,+  usa12 :: {-# UNPACK #-} !Int,+  usa13 :: {-# UNPACK #-} !Int,+  usa14 :: {-# UNPACK #-} !Int,+  usa15 :: {-# UNPACK #-} !Int  }++ushaskRec :: UStrictHaskRec+ushaskRec = UStrictHaskRec 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99++sumUSHaskRec r =+    usa0 r + usa1 r + usa2 r + usa3 r + usa4 r + usa5 r + usa6 r + usa7 r + usa8 r+    + usa9 r + usa10 r + usa11 r + usa12 r + usa13 r + usa14 r + usa15 r++type SubFields = '[ '("a0", Int), '("a8", Int), '("a15", Int)]++-- updateSRec :: forall record. RecordSubset record ElField SubFields Fields+--            => record ElField Fields -> record ElField Fields+updateSRec :: SRec ElField Fields -> SRec ElField Fields+updateSRec = rsubset %~ appEndo aux+  where aux :: Endo (SRec ElField SubFields)+        aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++updateARec :: ARec ElField Fields -> ARec ElField Fields+updateARec = rsubset %~ appEndo aux+  where aux :: Endo (ARec ElField SubFields)+        aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++updateRec :: Rec ElField Fields -> Rec ElField Fields+updateRec = rsubset %~ appEndo aux+  where aux :: Endo (Rec ElField SubFields)+        aux = Endo (\r -> r & #a15 %~ (+ 2) & #a8 %~ (+ 3) & #a0 %~ (+ 4))++data SubRec = SubRec { suba0 :: Int, suba8 :: Int, suba15 :: Int }++updateHaskRec :: HaskRec -> HaskRec+updateHaskRec r = r { a0 = suba0 s, a8 = suba8 s, a15 = suba15 s }+  where s = aux (SubRec (a0 r) (a8 r) (a15 r))+        aux r' = r' { suba0 = suba0 r' + 4, suba8 = suba8 r' + 3, suba15 = suba15 r' + 2 }++main :: IO ()+main =+  do let newF = mkRec 0+         arec = toARec newF+         srec = toSRec newF+     unless (rvalf #a15 arec == rvalf #a15 newF)+            (do putStrLn "AFieldRec accessor disagrees with rvalf"+                exitFailure)+     unless (rvalf #a15 srec == rvalf #a15 newF)+            (do putStrLn "SFieldRec accessor disagrees with rvalf"+                exitFailure)+     let srec' = updateSRec srec+         haskRec' = updateHaskRec haskRec+         arec' = updateARec arec+     unless (rvalf #a0 srec' == a0 haskRec' && a0 haskRec' == 4 &&+             rvalf #a8 srec' == a8 haskRec' && a8 haskRec' == 3 &&+             rvalf #a15 srec' == a15 haskRec' && a15 haskRec' == 101)+             (do putStrLn "SRec and Haskell Record updates disagree"+                 exitFailure)+     unless (rvalf #a0 arec' == 4 && rvalf #a8 arec' == 3 &&+             rvalf #a15 arec' == 101)+            (do putStrLn "ARec record updates are inconsistent"+                exitFailure)+     defaultMain+       [ bgroup "Update"+         [ bench "Haskell Record" $ nf (a15 . updateHaskRec) haskRec+         , bench "Rec" $ nf (rvalf #a15 . updateRec) newF+         , bench "ARec" $ nf (rvalf #a15 . updateARec) arec+         , bench "SRec" $ nf (rvalf #a15 . updateSRec) srec+         ]+         ,+         bgroup "creating"+         [ bench "vinyl record" $ whnf mkRec 0+         , bench "toSRec" $ whnf mkToSRec 0+         , bench "New style ARec with toARec " $ whnf mkToARec 0+         , bench "New style ARec with arec " $ whnf mkARec 0+         ]+         ,bgroup "sums"+         [ bench "haskell record" $ nf sumHaskRec haskRec+         , bench "strict haskell record" $ whnf sumSHaskRec shaskRec+         , bench "unboxed strict haskell record" $ whnf sumUSHaskRec ushaskRec+         , bench "vinyl SRec" $ nf sumSRec srec+         , bench "vinyl Rec" $ nf sumRec newF+         , bench "vinyl ARec" $ nf sumARec arec+         ]+       , bgroup "FieldRec"+         [ bench "a0" $ nf (rvalf #a0) newF+         , bench "a4" $ nf (rvalf #a4) newF+         , bench "a8" $ nf (rvalf #a8) newF+         , bench "a12" $ nf (rvalf #a12) newF+         , bench "a15"  $ nf (rvalf #a15) newF+         ]+         , bgroup "AFieldRec"+         [ bench "a0" $ nf (rvalf #a0) arec+         -- , bench "a4" $ nf (rvalf #a4) arec+         -- , bench "a8" $ nf (rvalf #a8) arec+         -- , bench "a12" $ nf (rvalf #a12) arec+         , bench "a15"  $ nf (rvalf #a15) arec+         ]+         , bgroup "SFieldRec"+         [ bench "a0" $ nf (rvalf #a0) srec+         -- , bench "a4" $ nf (rvalf #a4) srec+         -- , bench "a8" $ nf (rvalf #a8) srec+         -- , bench "a12" $ nf (rvalf #a12) srec+         , bench "a15"  $ nf (rvalf #a15) srec+         ]+         , bgroup "Haskell Record"+         [ bench "a0" $ nf a0 haskRec+         -- , bench "a4" $ nf a4 haskRec+         -- , bench "a8" $ nf a8 haskRec+         -- , bench "a12" $ nf a12 haskRec+         , bench "a15"  $ nf a15 haskRec+         ]+         , bgroup "Strict Haskell Record"+         [ bench "a0" $ nf sa0 shaskRec+         -- , bench "a4" $ nf sa4 shaskRec+         -- , bench "a8" $ nf sa8 shaskRec+         -- , bench "a12" $ nf sa12 shaskRec+         , bench "a15"  $ nf sa15 shaskRec+         ]+         , bgroup "Unpacked Strict Haskell Record"+         [ bench "a0" $ nf usa0 ushaskRec+         -- , bench "a4" $ nf usa4 ushaskRec+         -- , bench "a8" $ nf usa8 ushaskRec+         -- , bench "a12" $ nf usa12 ushaskRec+         , bench "a15"  $ nf usa15 ushaskRec+         ]+       ]
+ benchmarks/AsABench.hs view
@@ -0,0 +1,14 @@+{-# language DataKinds, TypeOperators, TypeApplications #-}+import Data.Vinyl.CoRec+import Data.Vinyl.Functor (Identity(..))+import Criterion.Main++main :: IO ()+main = let x1 :: CoRec Identity '[Int,Bool,Char,Double,(),Float]+           x1 = CoRec (Identity (23::Int))+           x5 :: CoRec Identity '[Bool,Char,Double,(),Int,Float]+           x5 = CoRec (Identity (23::Int))+       in defaultMain [ bench "asASafe1" $ whnf (asASafe @Int) x1+                      , bench "asA1" $ whnf (asA @Int) x1+                      , bench "asASafe5" $ whnf (asASafe @Int) x5+                      , bench "asA5" $ whnf (asA @Int) x5 ]
+ benchmarks/Bench/ARec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++module Bench.ARec where++import Data.Vinyl+import Data.Vinyl.ARec.Internal+import Data.Vinyl.Syntax ()++import Bench.Rec++mkARec :: Int -> ARec ElField Fields+mkARec i= arec (Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons`+                  Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons`+                  Field i `arcons` Field i `arcons` Field i `arcons` Field i `arcons`+                  Field i `arcons` Field i `arcons` Field i `arcons` Field 99 `arcons`+                  arnil)+++mkToARec :: Int -> ARec ElField Fields+mkToARec i= toARec (Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field 99 :&+                  RNil)++sumARec :: ARec ElField Fields -> Int+sumARec str =+    get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str+  + get #a5 str + get #a6 str + get #a7 str + get #a8 str+  + get #a9 str + get #a10 str + get #a11 str + get #a12 str+  + get #a13 str + get #a14 str + get #a15 str+  where+    get label r = rvalf label r+    {-# INLINE get #-}
+ benchmarks/Bench/Rec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++module Bench.Rec where++import           Data.Vinyl+import           Data.Vinyl.Syntax ()+++type Fields = '[ '( "a0", Int ), '( "a1", Int ), '( "a2", Int ), '( "a3", Int )+               , '( "a4", Int ), '( "a5", Int ), '( "a6", Int ), '( "a7", Int )+               , '( "a8", Int ), '( "a9", Int ), '( "a10", Int ), '( "a11", Int )+               , '( "a12", Int ), '( "a13", Int ), '( "a14", Int ), '( "a15", Int )+               ]++mkRec :: Int -> Rec ElField Fields+mkRec i= Field i :& Field i :& Field i :& Field i :&+         Field i :& Field i :& Field i :& Field i :&+         Field i :& Field i :& Field i :& Field i :&+         Field i :& Field i :& Field i :& Field 99 :&+         RNil++sumRec :: Rec ElField Fields -> Int+sumRec str =+    get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str+  + get #a5 str + get #a6 str + get #a7 str + get #a8 str+  + get #a9 str + get #a10 str + get #a11 str + get #a12 str+  + get #a13 str + get #a14 str + get #a15 str+  where+    get (_label :: Label s) r =+      let (Field v) = rget @'(s, _) r+      in v+    {-# INLINE get #-}
+ benchmarks/Bench/SRec.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++module Bench.SRec where++import Data.Vinyl.SRec+import Data.Vinyl++import Bench.Rec (Fields)+++mkToSRec :: Int -> SRec ElField Fields+mkToSRec i= toSRec (Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field i :&+                  Field i :& Field i :& Field i :& Field 99 :&+                  RNil)+++sumSRec :: SRec ElField Fields -> Int+sumSRec str =+    get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str+  + get #a5 str + get #a6 str + get #a7 str + get #a8 str+  + get #a9 str + get #a10 str + get #a11 str + get #a12 str+  + get #a13 str + get #a14 str + get #a15 str+  where+    get (label :: Label s) r =+      case rget @'(s, Int) r of+        Field v -> v+    {-# INLINE get #-}
+ benchmarks/EqualityBench.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}+import Control.Monad (join)+import Criterion.Main+import Data.Functor.Identity+import Data.Vinyl+import Data.Vinyl.TypeLevel++class Eq2 a where+  eq2 :: a -> a -> Bool++instance RecAll f rs Eq => Eq2 (Rec f rs) where+  eq2 RNil RNil = True+  eq2 (a :& as) (b :& bs) = a == b && eq2 as bs++main :: IO ()+main = defaultMain [+         bench "Eq" $ whnf (join (==)) r1+       , bench "Eq2" $ whnf (join eq2) r1 ]+  where r1 = pure 23 :& pure 'b' :& pure 3.14 :& RNil :: Rec Identity '[Int, Char, Double]
benchmarks/StorableBench.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}+{-# LANGUAGE DataKinds, GADTs, OverloadedLabels, 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,11 +8,10 @@ -- 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 Lens.Micro+import Lens.Micro.Extras (view) import Control.Monad (when) import qualified Data.Foldable as F-import Data.Proxy import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Data.Vinyl@@ -28,40 +28,51 @@ randVecStd :: (Storable a, Variate a) => Int -> IO (V.Vector a) randVecStd = withSystemRandom . randVec -vNorm :: Proxy '("normal", V3 a)-vNorm = Proxy- 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))+(*~) :: Num a => ASetter s t a a -> a -> s -> t+l *~ x = l %~ (* x)+infixr 4 *~ -vinylNSumL :: (Num a, Storable a) => V.Vector (MyVertex a) -> a-vinylNSumL = V.sum . V.map (F.sum . view (rlens vNorm . rfield))+vinylNormSumLens :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSumLens = V.sum . V.map (F.sum . view (rlensf #normal)) -doubleNvi :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)-doubleNvi = V.map (rlens vNorm . rfield . _y *~ (2::Float))+vinylNormSumLabel :: (Num a, Storable a) => V.Vector (MyVertex a) -> a+vinylNormSumLabel = V.sum . V.map (F.sum . rvalf #normal) -vinylNSum :: (Num a, Storable a) => V.Vector (MyVertex a) -> a-vinylNSum = V.sum . V.map (F.sum . view rfield . rget vNorm)+doubleNormYLens :: V.Vector (MyVertex Float) -> V.Vector (MyVertex Float)+doubleNormYLens = V.map (rlensf #normal . _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)++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-          when (any (/= vinylAns) [vinylLans, flatAns, reasAns])+              vinylAns = vinylNormSum $ doubleNormY vinylVerts+              vinylLans = vinylNormSumLens $ doubleNormYLens vinylVerts+              vinylLabAns = vinylNormSumLabel $ doubleNormYLens vinylVerts+              flatAns = flatNormSum $ doubleNormFlat flatVerts+              reasAns = reasNormSum $ doubleNormReas reasVerts+          when (any (/= vinylAns) [ vinylLans, flatAns, reasAns, vinylLabAns ])                (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 "vinyl-label" $+                        whnf (vinylNormSumLabel . doubleNormYLens) vinylVerts                       , bench "reasonable" $-                        whnf (reasNSum . doubleNre) reasVerts ]+                        whnf (reasNormSum . doubleNormReas) reasVerts ]   where n = 1000  --------------------------------------------------------------------------------@@ -96,11 +107,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 +132,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 })
+ tests/Aeson.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE CPP, DataKinds, DeriveGeneric, FlexibleContexts,+             FlexibleInstances, GADTs, OverloadedStrings, PolyKinds,+             ScopedTypeVariables, TypeApplications, TypeOperators,+             ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Demonstrate encoding a 'Rec' to JSON. Three approaches are shown:+-- the first utilizes 'ToJSON' instances for the record's+-- interpretation type constructor applied to each of its fields. This+-- has the advantage of being concise by virtue of re-using a lot of+-- existing pieces. The downside to relying on existing 'ToJSON'+-- instances is that they encode self-contained JSON values, when what+-- we want to do is construct a single JSON object encompassing each+-- record field as a named field of that JSON object. We can do this+-- by inspecting the JSON serialization of each field, and extracting+-- it as a key-value pair if it was serialized as a JSON object with a+-- single named field. This works, but means that the types do not+-- guarantee correctness (i.e. if a record field is serialized as a+-- 'Number', we won't be able to include it in the serialization of+-- the 'Rec').+--+-- The second approach uses a bit of @aeson@ internals to instead+-- serialize each 'Rec' field as a key-value pair with no additional+-- decoration. This should be faster as well as more tightly typed+-- since we do not need to undo any 'Value' wrapping of the individual+-- record fields.+--+-- The third approach uses aeson's built-in functions for working with+-- 'Generic'. This requires some post-processing to address precisely+-- the above problem: the function based on 'Generic' ends up+-- producing a self-contained 'Value' for each field of the+-- record. Specifically, each field becomes an 'Array' that is either+-- empty or contains an 'Object' with a single field as well as+-- another, nested, 'Array' for the rest of the record. We include+-- here a function to flatten that recursive structure into the+-- 'Object' shape we want.+module Main where+import Control.Lens (view, deep)+import Control.Monad.State.Strict+import qualified Data.HashMap.Strict as H+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup ((<>))+#endif+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Vinyl+import Data.Vinyl.Class.Method (RecMapMethod1(..))+import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..))+import Data.Aeson+import Data.Aeson.Encoding.Internal (wrapObject, pair)+#if MIN_VERSION_aeson(2,0,0)+import Control.Lens (_1, (%~))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#endif+import Data.Aeson.Lens (_Object)+import GHC.Generics (Generic, Rep)+import GHC.TypeLits (KnownSymbol)+import Test.Hspec++-- * Compatibility with aeson < 2+#if MIN_VERSION_aeson(2,0,0)+type KeyMap = KeyMap.KeyMap Value++keyFromString :: String -> Key+keyFromString = Key.fromString++keyFromText :: Text -> Key+keyFromText = Key.fromText++keyMapToList :: KeyMap -> [(Key,Value)]+keyMapToList = KeyMap.toList+#else+type Key = Text+type KeyMap = H.HashMap Text Value++keyFromString :: String -> Key+keyFromString = T.pack++keyFromText :: Text -> Key+keyFromText = id++keyMapToList :: KeyMap -> [(Key,Value)]+keyMapToList = H.toList+#endif++-- * Implementing 'ToJSON' for 'Rec'++-- | An 'Identity' functor is not reflected in a value's JSON+-- serialization.+instance ToJSON a => ToJSON (Identity a) where+  toJSON (Identity x) = toJSON x++-- | A named field serializes to a JSON object with a single named+-- field.+instance (KnownSymbol s, ToJSON a) => ToJSON (ElField '(s,a)) where+  toJSON x = object [(keyFromString (getLabel x), toJSON (getField x))]++-- | A @((Text,) :. f) a@ value maps to a JSON field whose name is the+-- 'Text' value, and whose value has type @f a@.+instance ToJSON (f a) => ToJSON ((((,) Text) :. f) a) where+  toJSON (Compose (name, x)) = object [(keyFromText name, toJSON x)]++-- | Replace each field of a record with the result of serializing it+-- to a JSON 'Value', and then extracting that 'Value''s single named+-- field. If the serialization is not in the form of an object with a+-- single field, the conversion fails with a 'Nothing'.+fieldsToJSON :: (RecMapMethod1 ToJSON f rs)+             => Rec f rs -> Rec (Maybe :. Const (Key,Value)) rs+fieldsToJSON = rmapMethod1 @ToJSON (Compose . aux)+  where aux x = case toJSON x of+                  Object (keyMapToList -> [field]) -> Just (Const field)+                  _ -> Nothing++-- | Convert a homogeneous record to a list factored through an outer+-- functor. A useful specialization is when the outer functor is+-- 'Maybe': if any field is 'Nothing', then the result of this+-- function is 'Nothing'.+recToListF :: (Applicative f, RFoldMap rs) => Rec (f :. Const a) rs -> f [a]+recToListF = fmap (rfoldMap (pure . getConst)) . rtraverse getCompose++instance (RFoldMap rs, RecMapMethod1 ToJSON f rs)+  => ToJSON (Rec f rs) where+  toJSON = maybe err object . recToListF . fieldsToJSON+    where err = error (unlines [ "The interpretation functor of this "+                               , "record did not produce a named field "+                               , "for at least one of its fields." ])++-- * Naming anonymous fields++-- | Pair each record field with its position.+recIndexed :: Rec f rs -> Rec ((,) Int :. f) rs+recIndexed = flip evalState 1 . rtraverse aux+  where aux x = do i <- get+                   Compose (i,x) <$ put (i+1)++-- | A helper to pair each field of a record with a name derived from+-- its position in the record. This reflects the implicit ordering of+-- the type-level list of the record's fields.+nameFields :: RMap rs => Rec f rs -> Rec ((,) Text :. f) rs+nameFields = rmap aux . recIndexed+  where aux (Compose (i,x)) = Compose ("field"<>T.pack (show i), x)++-- * Test Cases++r1 :: Rec ElField '[("age" ::: Int), ("iscool" ::: Bool), ("yearbook" ::: Text)]+r1 = xrec (23, True, "You spin me right round")++r1JSON :: Value+r1JSON = object [ "age" .= (23 :: Int)+                , "iscool" .= True+                , "yearbook" .= ("You spin me right round" :: Text) ]++r2 :: Rec Identity '[Int,Bool,Text]+r2 = xrec (23, True, "You spin me right round")++r2JSON :: Value+r2JSON = object [ "field1" .= (23 :: Int)+                , "field2" .= True+                , "field3" .= ("You spin me right round" :: Text) ]++-- | A type with its own JSON Object encoding+data MyType = MyType { bike :: Bool, skateboard :: Bool } deriving Generic+instance ToJSON MyType++r3 :: Rec ElField '[ "age" ::: Int+                   , "iscool" ::: Bool+                   , "yearbook" ::: Text+                   , "hobbies" ::: MyType ]+r3 = xrec (23, True, "You spin me right round", MyType True True)++r3JSON :: Value+r3JSON = object [ "age" .= (23 :: Int)+                , "iscool" .= True+                , "yearbook" .= ("You spin me right round" :: Text)+                , "hobbies" .= object ["bike" .= True, "skateboard" .= True] ]++main :: IO ()+main = hspec $ do+  describe "Simple Rec to JSON" $ do+    it "Named fields" $+      toJSON r1 `shouldBe` r1JSON+    it "Anonymous fields" $+      toJSON (nameFields r2) `shouldBe` r2JSON+    it "Nested objects" $+      toJSON r3 `shouldBe` r3JSON+  describe "Type-safe Rec to JSON" $ do+    it "Named fields" $+      recToJSON r1 `shouldBe` r1JSON+    it "Anonymous fields" $+      recToJSON (nameFields r2) `shouldBe` r2JSON+    it "Nested objects" $+      recToJSON r3 `shouldBe` r3JSON+  describe "Via Generics" $ do+    it "Named fields" $+      grecToJSON r1 `shouldBe` r1JSON+    it "Anonymous fields" $+      grecToJSON (nameFields r2) `shouldBe` r2JSON+    it "Nested objects" $+      grecToJSON r3 `shouldBe` r3JSON++-- * More type safe and efficient++-- | Produce a JSON key-value pair from a Haskell value. This is what+-- we want from each field of our records. The simple encoding above+-- that treats each record field as a self-contained JSON 'Value'+-- loses precision in the type.+class ToJSONField a where+  encodeJSONField :: a -> Series+  toJSONField :: a -> (Key,Value)++-- | An @ElField '(s,a)@ value maps to a JSON field with name @s@ and+-- value @a@.+instance (ToJSON a, KnownSymbol s) => ToJSONField (ElField '(s,a)) where+  encodeJSONField x = pair (keyFromString (getLabel x))+                           (toEncoding (getField x))+  toJSONField x = (keyFromString (getLabel x), toJSON (getField x))++-- | A @((Text,) :. f) a@ value maps to a JSON field whose name is the+-- 'Text' value, and whose value has type @f a@.+instance ToJSON (f a) => ToJSONField (((,) Text :. f) a) where+  encodeJSONField (Compose (name,val)) =+    pair (keyFromText name) (toEncoding val)+  toJSONField (Compose (name,val)) = (keyFromText name, toJSON val)++encodeRec :: (RFoldMap rs, RecMapMethod1 ToJSONField f rs)+          => Rec f rs -> Encoding+encodeRec = wrapObject+          . pairs+          . rfoldMap getConst+          . rmapMethod1 @ToJSONField (Const . encodeJSONField)++recToJSON :: (RFoldMap rs, RecMapMethod1 ToJSONField f rs)+          => Rec f rs -> Value+recToJSON = object+          . rfoldMap ((:[]) . getConst)+          . rmapMethod1 @ToJSONField (Const . toJSONField)++-- * Generically++-- | If a 'Value' is a nested 'Array' of 'Object's, extract the+-- collection of key-value pairs from the entire recursive structure.+allAesonFields :: Value -> Maybe Object+allAesonFields (Array arr) =+  case V.toList arr of+    [] -> Just mempty+    [Object field, objTail] -> fmap (field <>) (allAesonFields objTail)+    _ -> Nothing+allAesonFields _ = Nothing++-- | Try un-nesting a recursive 'Array' of fields. That is, if a+-- 'Value' is laid out as @Array [Object [(key1,value1)], Array+-- [Object [(key2, value2)], ...]]@ we extract all the key-value+-- pairs, @[(key1,value1), (key2, value2), ...]@.+unnestFields :: Value -> Value+unnestFields v = maybe v Object (allAesonFields v)++-- | A lens implementation of something a bit looser than+-- 'unnestFields'.+allFields :: Value -> Object+#if MIN_VERSION_aeson(2,0,0)+allFields = KeyMap.fromList+#if MIN_VERSION_lens_aeson(1,2,0)+          . keyMapToList+#else+          . map (_1 %~ Key.fromText)+          . H.toList+#endif+          . view (deep _Object)+#else+allFields = view (deep _Object)+#endif++-- | The generic 'ToJSON' instance is not quite right since we use the+-- record's interpretation type constructor to define serialization,+-- resulting in each record field being treated as a self-contained+-- JSON object. What we want is for each record field to become a+-- named field of a single JSON object, so we must post-process the+-- result of the function defined on 'Generic'.+grecToJSON :: (Generic (Rec f rs), GToJSON Zero (Rep (Rec f rs)))+           => Rec f rs -> Value+grecToJSON = Object . allFields . genericToJSON defaultOptions
+ tests/CoRecSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP, DataKinds, FlexibleContexts, ScopedTypeVariables,+             TypeApplications, 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 =+  describe "CoRecs" $ do+    let x = CoRec (pure True) :: Field '[Int,Bool,()]+    it "Can be cast successfully" $+      asA @Bool x `shouldBe` Just True+    it "Can fail to cast" $+      asA @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))
− tests/Intro.lhs 
@@ -1,260 +0,0 @@-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, PolyKinds, TypeOperators, TypeFamilies #-}-> {-# LANGUAGE FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction #-}-> {-# LANGUAGE GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}-> import Data.Vinyl-> import Data.Vinyl.Functor-> import Control.Applicative-> import Control.Lens hiding (Identity)-> import Control.Lens.TH-> import Data.Char-> import Test.DocTest-> import Data.Singletons.TH--Let’s define a universe of fields which we want to use:--> data Fields = Name | Age | Sleeping | Master deriving Show-> type LifeForm = [Name, Age, Sleeping]--> type family ElF (f :: Fields) :: * where->   ElF Name = String->   ElF Age = Int->   ElF Sleeping = Bool->   ElF Master = Rec Attr LifeForm--> newtype Attr f = Attr { _unAttr :: ElF f }-> makeLenses ''Attr-> instance Show (Attr Name) where show (Attr x) = "name: " ++ show x-> instance Show (Attr Age) where show (Attr x) = "age: " ++ show x-> instance Show (Attr Sleeping) where show (Attr x) = "sleeping: " ++ show x-> instance Show (Attr Master) where show (Attr x) = "master: " ++ show x--> (=::) :: sing f -> ElF f -> Attr f-> _ =:: x = Attr x--> genSingletons [ ''Fields ]--Now, let’s try to make an entity that represents a man:--> jon = (SName =:: "jon")->    :& (SAge =:: 23)->    :& (SSleeping =:: False)->    :& RNil--Automatically, we can show the record:--> -- |-> -- >>> show jon-> -- "{name: \"jon\", age: 23, sleeping: False}"--And its types are all inferred with no problem. Now, make a dog! Dogs are-life-forms, but unlike men, they have masters. So, let’s build my dog:--> tucker = (SName =:: "tucker")->       :& (SAge =:: 9)->       :& (SSleeping =:: True)->       :& (SMaster =:: jon)->       :& RNil--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 ∈ fields) => Rec Attr fields -> Rec Attr fields-> wakeUp = rput $ SSleeping =:: 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 SSleeping-> -- sleeping: False-> ---> -- >>> tucker ^. rlens SSleeping-> -- sleeping: True-> ---> -- >>> jon' ^. rlens SSleeping-> -- 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 = rlens SMaster . unAttr . rlens SSleeping-> tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker'--> -- | >>> tucker'' ^. masterSleeping-> -- sleeping: True--Subtyping Relation and Coercion----------------------------------A record `Rec f xs` is a subtype of a record `Rec f 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 :: Rec Attr LifeForm-> upcastedTucker = rcast tucker--The subtyping relationship between record types is expressed with the-`(<:)` constraint; so, cast is of the following type:--< rcast :: r1 <: r2 => Rec f r1 -> Rec f r2--Also provided is a `(≅)` constraint which indicates record congruence-(that is, two record types differ only in the order of their fields).--In fact, `rcast` is actually given as a special case of the lens `rsubset`,-which lets you modify entire (possibly non-contiguous) slices of a record!--Records are polymorphic over functors----------------------------------------Consider the following declaration:--< data Rec :: (u -> *) -> [u] -> * where-<   RNil :: Rec f '[]-<   (:&) :: f r -> Rec f rs -> Rec f (r ': rs)--Records are implicitly parameterized over a kind `u`, which stands for the-"universe" or key space. Keys (inhabitants of `u`) are then interpreted into-the types of their values by the first parameter to `Rec`, `f`. An extremely-powerful aspect of Vinyl records is that you can construct natural-transformations between different interpretation functors `f,g`, or postcompose-some other functor onto the stack. This can be used to immerse each field of a-record in some particular effect modality, and then the library functions can-be used to traverse and accumulate these effects.--Let’s imagine that we want to do validation on a record that-represents a name and an age:--> type Person = [Name, Age]--We’ve decided that names must be alphabetic, and ages must be positive. For-validation, we’ll use `Maybe` for now, though you should use a-left-accumulating `Validation` type.--> goodPerson :: Rec Attr Person-> goodPerson = (SName =:: "Jon")->           :& (SAge =:: 20)->           :& RNil--> badPerson = (SName =:: "J#@#$on")->           :& (SAge =:: 20)->           :& RNil--We'll give validation a (rather poor) shot.--> validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person)-> validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge where->   vName = validateName $ p ^. rlens SName . unAttr->   vAge  = validateAge $ p ^. rlens SAge . unAttr->->   validateName str | all isAlpha str = Just str->   validateName _ = Nothing->   validateAge i | i >= 0 = Just i->   validateAge _ = Nothing--> -- $setup-> -- >>> let isJust (Just _) = True; isJust _ = False--> -- |-> -- >>> isJust $ validatePerson goodPerson-> -- True-> ---> -- >>> isJust $ validatePerson badPerson-> -- False--The results are as expected (`Just` for `goodPerson`, and a `Nothing` 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.--> type Validator f = Lift (->) f (Maybe :. f)--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 (Validator Attr) Person-> vperson = lift validateName :& lift validateAge :& RNil->   where->     lift f = Lift $ Compose . f->     validateName (Attr str) | all isAlpha str = Just (Attr str)->     validateName _ = Nothing->     validateAge (Attr i) | i >= 0 = Just (Attr i)->     validateAge _ = Nothing--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--> -- |-> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SName-> -- True-> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SAge-> -- True-> -- >>> isJust . getCompose $ badPersonResult ^. rlens SName-> -- False-> -- >>> isJust . getCompose $ badPersonResult ^. rlens SAge-> -- 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 `Maybe (Rec Attr Person)`) using `rtraverse`:--> mgoodPerson :: Maybe (Rec Attr Person)-> mgoodPerson = rtraverse getCompose goodPersonResult--> mbadPerson  = rtraverse getCompose badPersonResult--> -- |-> -- >>> isJust mgoodPerson-> -- True-> -- >>> isJust mbadPerson-> -- False--> main :: IO ()-> main = doctest ["tests/Intro.lhs"]
+ tests/Spec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs,+             NoMonomorphismRestriction, OverloadedLabels,+             ScopedTypeVariables, TypeApplications, TypeOperators #-}+{-# OPTIONS_GHC -Wall -Wno-type-defaults #-}+import Data.Vinyl+import Data.Vinyl.Functor (Lift(..), Const(..), Compose(..), (:.))+import Lens.Micro+import Test.Hspec+import Data.Vinyl.Syntax ()++import qualified CoRecSpec as C+import qualified XRecSpec as X++import qualified Test.ARec as ARec++-- 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+  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+    it "Can get field X" $ rvalf #x d3 `shouldBe` 5+    it "Can get field Y" $ rvalf #y d3 `shouldBe` "Hi"+  describe "ARec provides field accessors" $ do+    it "Can get field Y" $ rvalf #y (toARec d3) `shouldBe` "Hi"+    it "Can set field X" $ rvalf #x (rputf #x 7 (toARec d3)) `shouldBe` 7+  describe "Converting between Rec and ARec" $ do+    it "Can go back and forth" $+      rvalf #y (toARec (#y %~ (show . length) $+                          fromARec (rputf #x 7 (toARec d3))))+      `shouldBe` "2"+  describe "Converting between Rec and SRec" $ do+    it "Can go back and forth" $+      let d4 = #x =:= 5 <+> #y =:= 4 :: FieldRec '[ '("x",Int), '("y",Int)]+          isqrt = floor . (sqrt :: Double -> Double) . fromIntegral :: Int -> Int+      in rvalf #y (toSRec (#y %~ isqrt $+           fromSRec (rputf #x 7 (toSRec d4))))+      `shouldBe` 2++  describe "Produces field lenses from overloaded labels" $ do+    it "Can invert a boolean field" $ do+      (fieldRec (#x =: True, #y =: 'b') & #x %~ not)+      `shouldBe` fieldRec (#x =: False, #y =: 'b')+  describe "Supports tuple construction" $ do+    it "Can build ElField records from tuples" $+          fieldRec (#x =: 5, #y =: "Hi") `shouldBe` d3+    it "Can build Recs of Maybe values" $+      record @Maybe (Just True, Just 'a') `shouldBe` Just True :& Just 'a' :& RNil+    it "Can build Recs of Const values" $+      record @(Const String) ( Const "howdy" :: Const String Int+                             , Const "folks" :: Const String Double)+      `shouldBe` Const "howdy" :& Const "folks" :& RNil+  describe "Can change the types of individual fields" $ do+    it "Can set a field with a different type" $+      (#x .~ 2.1) d3 `shouldBe` fieldRec (#x =: 2.1, #y =: "Hi")+    it "Can change a field's type" $+      (d3 & #y %~ length) `shouldBe` fieldRec (#x =: 5, #y =: 2)++  ARec.spec
+ tests/Test/ARec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs,+             NoMonomorphismRestriction, OverloadedLabels,+             ScopedTypeVariables, TypeApplications, TypeOperators #-}+{-# OPTIONS_GHC -Wall -Wno-type-defaults #-}++module Test.ARec where++import Data.Vinyl.ARec+import Data.Vinyl+import Test.Hspec++import Data.Vinyl.Syntax ()++type FullARec = ARec ElField '[ "f0" ::: Int , "f1" ::: Bool , "f2" ::: String+                              , "f3" ::: Double, "f4" ::: Integer+                              , "f2" ::: Int -- intentionally duplicate field name+                              ]++type SubARecPre = ARec ElField '[ "f0" ::: Int , "f1" ::: Bool , "f2" ::: String ]++type SubARecDupes = ARec ElField '[ "f2" ::: String, "f2" ::: String+                                  , "f2" ::: Int, "f2" ::: String+                                  ]+++fullARec :: FullARec+fullARec = toARec ( #f0 =: 1 :& #f1 =: False :& #f2 =: "field2"+                  :& #f3 =: 3.1415 :& #f4 =: 4444+                  :& #f2 =: 666+                  :& RNil+                  )++-- For arecGetSubset -----------------------------------------------------------++subARecPre :: SubARecPre+subARecPre = toARec ( #f0 =: 1 :& #f1 =: False :& #f2 =: "field2" :&  RNil)++subARecDupes :: SubARecDupes+subARecDupes = toARec ( #f2 =: "field2" :& #f2 =: "field2"+                        :& #f2 =: 666 :& #f2 =: "field2"+                        :& RNil+                      )++arecWithDupes :: ARec ElField '[ "f" ::: Int, "f" ::: Int]+arecWithDupes = toARec (#f =: 1 :& #f =: 2 :& RNil)++-- For arecSetSubset -----------------------------------------------------------++subARecPreSet :: SubARecPre+subARecPreSet = toARec ( #f0 =: 11 :& #f1 =: True :& #f2 =: "field2-updated" :&  RNil)++fullARecUpdated :: FullARec+fullARecUpdated = toARec ( #f0 =: 11 :& #f1 =: True :& #f2 =: "field2-updated"+                           :& #f3 =: 3.1415 :& #f4 =: 4444+                           :& #f2 =: 666+                           :& RNil+                         )++updateARecWithDupes :: ARec ElField '[ '("f0", Int), '("f0", Int), '("f0", Int)]+updateARecWithDupes = toARec (#f0 =: 3 :& #f0 =: 66 :& #f0 =: 1 :&RNil)++subARecDupesUpdated :: SubARecDupes+subARecDupesUpdated = toARec ( #f2 =: "updated" :& #f2 =: "field2"+                               :& #f2 =: 666 :& #f2 =: "field2"+                               :& RNil+                             )++++spec :: SpecWith ()+spec = describe "ARec" $ do+  describe "arecGetSubset" $ do+    it "retrieves a prefix ARec" $+      -- The part to be retrieved is type-directed+      arecGetSubset fullARec `shouldBe` subARecPre+    it "retrieves the full ARec" $ do+      -- Should catch off-by-one errors that lead to overflow+      arecGetSubset fullARec `shouldBe` fullARec+    it "handles an empty subARec correctly" $+      arecGetSubset fullARec `shouldBe` toARec RNil+    it "handles duplicate field names correctly in the sub arec" $+      arecGetSubset fullARec `shouldBe` subARecDupes+    it "handles duplicate field names correctly in the source arec" $+      -- When both the name and the type of the field match we retrieve from the+      -- first field+      arecGetSubset arecWithDupes `shouldBe` toARec (#f =: (1 :: Int) :& RNil)+  describe "arecSetSubset" $ do+    it "sets a subset of fields" $ do+      arecSetSubset fullARec subARecPreSet `shouldBe` fullARecUpdated+    it "handles updates to every field" $ do+      -- Should catch off-by-one errors that lead to overflow+      arecSetSubset fullARec fullARec `shouldBe` fullARec+    it "handles an empty subset" $ do+      arecSetSubset fullARec (toARec RNil) `shouldBe` fullARec+    it "handles duplicates in the updating ARec" $ do+      -- The behaviour here should be that the _last_ updating field prevails+      arecSetSubset fullARec updateARecWithDupes `shouldBe` fullARec+    it "handles updatees with duplicate fields" $ do+      -- Here, only the _first_ field should be updated+      arecSetSubset subARecDupes (toARec (#f2 =: "updated" :& RNil))+        `shouldBe` subARecDupesUpdated
+ 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,19 +1,20 @@ name:                vinyl-version:             0.5.1+version:             0.14.3 synopsis:            Extensible Records -- description: license:             MIT license-file:        LICENSE author:              Jonathan Sterling-maintainer:          jonsterling@me.com+maintainer:          acowley@gmail.com -- copyright: category:            Records stability:           Experimental build-type:          Simple cabal-version:       >=1.10 extra-source-files:  CHANGELOG.md+tested-with:         GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1, GHC == 9.2.1 -description: Extensible records for Haskell with lenses using modern GHC features.+description: Extensible records for Haskell with lenses.  source-repository head   type:     git@@ -21,27 +22,108 @@  library   exposed-modules:     Data.Vinyl+                     , Data.Vinyl.ARec+                     , Data.Vinyl.ARec.Internal+                     , Data.Vinyl.ARec.Internal.SmallArray+                     , Data.Vinyl.Class.Method                      , Data.Vinyl.Core+                     , Data.Vinyl.CoRec+                     , Data.Vinyl.Curry+                     , Data.Vinyl.FromTuple                      , Data.Vinyl.Lens                      , Data.Vinyl.Derived                      , Data.Vinyl.TypeLevel                      , Data.Vinyl.Functor                      , Data.Vinyl.Notation-  build-depends:       base >=4.7 && <= 5, ghc-prim+                     , Data.Vinyl.Recursive+                     , Data.Vinyl.SRec+                     , Data.Vinyl.Syntax+                     , Data.Vinyl.Tutorial.Overview+                     , Data.Vinyl.XRec+  build-depends:       base >= 4.11 && <= 5,+                       ghc-prim,+                       deepseq,+                       array+  if impl (ghc < 8.6.0)+    build-depends: constraints >= 0.6.1   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+  ghc-options:         -Wall+  other-extensions:    TypeApplications -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, mwc-random, lens, linear-  ghc-options:      -O2 -fllvm+  build-depends:    base,+                    vector,+                    criterion,+                    vinyl,+                    mwc-random,+                    microlens,+                    linear,+                    primitive+  ghc-options:      -O2+-- -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques   default-language: Haskell2010 -test-suite doctests+benchmark equality   type:             exitcode-stdio-1.0+  hs-source-dirs:   benchmarks+  main-is:          EqualityBench.hs+  build-depends:    base, criterion, vinyl+  ghc-options:      -O2+  default-language: Haskell2010++benchmark accessors+  type:             exitcode-stdio-1.0+  hs-source-dirs:   benchmarks+  main-is:          AccessorsBench.hs+  build-depends:    base, criterion, tagged, vinyl, microlens+  other-modules:    Bench.ARec+                    Bench.SRec+                    Bench.Rec+  ghc-options:      -O2+  default-language: Haskell2010++benchmark asa+  type:             exitcode-stdio-1.0+  hs-source-dirs:   benchmarks+  main-is:          AsABench.hs+  build-depends:    base, criterion, vinyl+  ghc-options:      -O2+  default-language: Haskell2010++-- TODO: Use cabal-docspec+-- test-suite doctests+--   type:             exitcode-stdio-1.0+--   hs-source-dirs:   tests+--   other-modules:    Intro+--   main-is:          doctests.hs+--   if impl (ghc < 9.0.1)+--     build-depends:    base, lens, doctest >= 0.8, singletons >= 0.10 && < 3, vinyl+--   else+--     build-depends:    base, lens, doctest >= 0.8, singletons-th >= 3 && < 3.1, vinyl+--   default-language: Haskell2010++test-suite aeson+  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+  main-is:          Aeson.hs+  build-depends:    base, hspec, aeson >= 1.4, text, mtl, vinyl,+                    vector, unordered-containers, lens, lens-aeson   default-language: Haskell2010++test-suite spec+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Spec.hs+  other-modules:       CoRecSpec+                       XRecSpec+                       Test.ARec+  build-depends:       base+                     , vinyl+                     , microlens+                     , hspec+                     , should-not-typecheck >= 2.0 && < 2.2+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010