packages feed

vinyl 0.5.2 → 0.14.3

raw patch · 32 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,95 @@+# 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)
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
@@ -1,12 +1,22 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE ConstraintKinds       #-}+{-# 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 +    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@@ -14,10 +24,20 @@     is given at the bottom of this page. -} -module Data.Vinyl.Class.Method -  ( -- * Eq Functions-    recEq-    -- * Ord Functions+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@@ -36,10 +56,14 @@     -- * 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@@ -49,12 +73,12 @@ recCompare RNil RNil = EQ recCompare (a :& as) (b :& bs) = compare a b <> recCompare as bs --- | This function differs from the original 'mempty' in that +-- | 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 +--   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 +--   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@@ -85,15 +109,15 @@  recAbs :: RecAll f rs Num => Rec f rs -> Rec f rs recAbs RNil = RNil-recAbs (a :& as) = abs a :& recAbs as +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 +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 +recNegate (a :& as) = negate a :& recAbs as  -- | This function differs from the original 'minBound'. --   See 'recMempty'.@@ -107,9 +131,121 @@ 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 +    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: @@ -119,24 +255,24 @@  > recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering -    The only difference is the constraint. Let's look at a potential +    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 +    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)) +> 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 +    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. +    a somewhat more complicated case. -    What if the exact subrecord we were projecting couldn't be +    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@@ -187,6 +323,3 @@     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,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE CPP                   #-}@@ -9,22 +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-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (Const(..))-#endif-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@@ -39,6 +70,22 @@ 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@@ -54,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@@ -75,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@@ -83,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@@ -124,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@@ -143,33 +273,84 @@ -- 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@@ -187,14 +368,136 @@   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,37 +1,48 @@ {-# 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 +module Data.Vinyl.Functor   ( -- * Introduction     -- $introduction     -- * Data Types     Identity(..)   , Thunk(..)   , Lift(..)-  , Compose(..)+  , ElField(..)+  , Compose(..), onCompose   , (:.)   , Const(..)     -- * Discussion-    +     -- ** Example     -- $example-    +     -- ** Ecosystem     -- $ecosystem   ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (Const)-import Data.Foldable-import Data.Traversable+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@@ -50,6 +61,7 @@              , Storable              , Eq              , Ord+             , Generic              )  -- | Used this instead of 'Identity' to make a record@@ -66,8 +78,21 @@  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 :. @@ -77,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) @@ -92,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)@@ -156,7 +256,7 @@ >>> r2 Nothing -    If the fields only exist once an environment is provided, you can +    If the fields only exist once an environment is provided, you can     build the record as follows:  >>> :{@@ -191,7 +291,7 @@     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. +    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:@@ -212,10 +312,10 @@     "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 +    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
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
@@ -4,12 +4,13 @@     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@@ -27,7 +28,7 @@ >>> import Control.Lens.TH >>> import Data.Char >>> import Test.DocTest->>> import Data.Singletons.TH+>>> import Data.Singletons.TH (genSingletons) >>> import Data.Maybe      Let's define a universe of fields which we want to use.@@ -37,7 +38,7 @@ >>> 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 autmatically turn all the+    The @DataKinds@ extension must be enabled to automatically turn all the     constructors of the @Field@ type into types.  >>> type LifeForm = [Name, Age, Sleeping]@@ -93,7 +94,7 @@ are life-forms, but unlike humans, they have masters. So, let’s build my dog: ->>> :{ +>>> :{ let tucker = (SName =:: "tucker")           :& (SAge =:: 9)           :& (SSleeping =:: True)@@ -120,20 +121,20 @@ >>> let tucker' = wakeUp tucker >>> let jon' = wakeUp jon ->>> tucker' ^. rlens SSleeping+>>> tucker' ^. rlens @Sleeping sleeping: False ->>> tucker ^. rlens SSleeping+>>> tucker ^. rlens @Sleeping sleeping: True ->>> jon' ^. rlens SSleeping+>>> 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 SMaster . unAttr . rlens SSleeping+>>> let masterSleeping = rlens @Master . unAttr . rlens @Sleeping >>> let tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker'  >>> tucker'' ^. masterSleeping@@ -156,7 +157,7 @@ The subtyping relationship between record types is expressed with the '<:' constraint; so, 'rcast' is of the following type: -> rcast :: r1 <: r2 => Rec f r1 -> Rec f r2+> 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).@@ -206,12 +207,12 @@ We\'ll give validation a (rather poor) shot.  >>> :{-let +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 SName . unAttr-      vAge  = validateAge $ p ^. rlens SAge . unAttr+      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@@ -258,16 +259,16 @@ >>> let goodPersonResult = vperson <<*>> goodPerson >>> let badPersonResult  = vperson <<*>> badPerson ->>> isJust . getCompose $ goodPersonResult ^. rlens SName+>>> isJust . getCompose $ goodPersonResult ^. rlens @Name True ->>> isJust . getCompose $ goodPersonResult ^. rlens SAge+>>> isJust . getCompose $ goodPersonResult ^. rlens @Age True ->>> isJust . getCompose $ badPersonResult ^. rlens SName+>>> isJust . getCompose $ badPersonResult ^. rlens @Name False ->>> isJust . getCompose $ badPersonResult ^. rlens SAge+>>> isJust . getCompose $ badPersonResult ^. rlens @Age True  So now we have a partial record, and we can still do stuff with its contents.@@ -288,11 +289,9 @@ 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/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,284 +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 singletons--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.--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 autmatically 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:--> type family ElF (f :: Fields) :: * where->   ElF Name = String->   ElF Age = Int->   ElF Sleeping = Bool->   ElF Master = Rec Attr LifeForm--Unfortunately, type families aren't first class in Haskell.  That's-why we also need a data type, with which we will parametrise `Rec`:--> 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--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`.--> (=::) :: sing f -> ElF f -> Attr f-> _ =:: x = Attr x--We generate the necessary singletons for each field label using-Template Haskell:--> genSingletons [ ''Fields ]--Now, let’s try to make an entity that represents a human:--> 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 humans, 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 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:---> 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, rcast 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", "Data/Vinyl/Tutorial/Overview.hs"]
+ 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.2+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,37 +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+                     , Data.Vinyl.Recursive+                     , Data.Vinyl.SRec+                     , Data.Vinyl.Syntax                      , Data.Vinyl.Tutorial.Overview-  build-depends:       base >=4.7 && <= 5, ghc-prim+                     , 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.1, 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  benchmark equality   type:             exitcode-stdio-1.0   hs-source-dirs:   benchmarks   main-is:          EqualityBench.hs-  build-depends:    base >= 4.7 && <= 5, criterion, vinyl >= 0.5.1-  ghc-options:      -O2 -fllvm+  build-depends:    base, criterion, vinyl+  ghc-options:      -O2   default-language: Haskell2010 -test-suite doctests+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