diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,104 @@ -0.5.1 ---------- +# 0.14.3 +- Compatibility with `lens-aeson` > 1.2 +# 0.14.2 +- Export the `ToARec` class + +# 0.14.1 +- Compatibility with `aeson` > 2.0 + +# 0.14.0 +- `ARec` efficiency improvements (@Philonous) +- Make `ElField` a newtype (@Philonous) + +The `ElField` change brings more opportunities for the optimizer, but can result in longer compile times. + +# 0.13.3 +- Fixed CHANGELOG entry for 0.13.2: it referred to version 0.14.0 +- Relax bounds on `hspec` + +# 0.13.2 +- Removed aput and alens from Data.Vinyl.ARec. They were used internally, but their type is unsound. + +# 0.13.1 +- GHC 9.0.1 support + +# 0.13.0 +- GHC 8.10.1 support fix. A fix for the previous attempt at 8.10 support involves a backwards incompatible change. + +# 0.12.2 + +- GHC 8.10.1 support + +# 0.12.0 + +- GHC 8.8.1 support. Class type signatures were changed to remove explicit kind variables. This is to simplify the use of `TypeApplications` which changed with GHC 8.8.1 to require explicit application to those kind variables. Leaving them out of the class definitions preserves existing usage of `TypeApplications`. Thanks to Justin Le (@mstksg). + +# 0.11.0 + +- Changed the `Show` instance of `CoRec` +- Added the `corec` helper that specifically helps type inference when + constructing `CoRec ElField` values. + +# 0.10.0 + +- Changed the types of `Data.Vinyl.CoRec.onCoRec` and `Data.Vinyl.CoRec.onField`. This was pushing through the changes to drop the use of `Proxy` arguments, relying instead on `TypeApplications`. Also added `onCoRec1` and `onField` to work with functions relying on a single type class. + +- Faster `asA` and `asA'`. These implementations utilize `unsafeCoerce` in their implementations after we have performed a runtime check that proves (to us) that the types match up. The old implementations are still available as `asASafe` and `asA'Safe`. While both implementations can run in constant time if the compiler optimizes everything successfully, the faster variants are a bit more than 3x faster in a trivial benchmark. + +- Add a `Generic` instance for `Rec` and common functors. + +- Add a variety of `ToJSON` implementations as a test case. One or all of these should probably exist as a separate package to avoid `vinyl` depending on `aeson`, but their content may be of interest. + +# 0.9.2 + +- Add `runcurryX` for applying an uncurried function to a `Rec` passing through the `XRec` machinery to strip out syntactic noise. + +# 0.9.0 + +- A new `SRec` type for constant time field access for records with densely packed `Storable` fields. Conversion from `Rec` is accomplished with `toSRec`, while `fromSRec` takes you back to `Rec`. Record updates are fairly slow compared to native Haskell records and even `Rec`, but reading a field is as fast as anything. + +- Concise record construction syntax from tuples. Construct a `FieldRec` with `fieldRec (#x =: True, #y =: 'b')` and have the type inferred as `Rec ElField '[ '("x", Bool), '("y", Char) ]`. Or use `record` to build records of any functor. Thanks to @heptahedron on GitHub for prompting this feature, and @sboosali for thinking through various approaches. + +- Optional concise record field lens syntax. This uses an orphan `IsLabel` instance for all function types, so will conflict with any other library that does the same. Thus it is entirely opt-in: to enable this syntax, you must explicitly `import Data.Vinyl.Syntax`. This enables the use of labels as lenses. For example, `myRec & #name %~ map toUpper` to apply `map toUpper` to the `#name` field of the record value `myRec`. This technique is thanks to Tikhon Jelvis who shared it on the Haskell-Cafe mailing list. + +- Field lenses can now change the type of a record. Thanks to @heptahedron on GitHub for exploring this feature. Using the above-mentioned features, one might now write something like `myRec & #name %~ length` to produce a record whose `#name` field is the length of the`String` `#name` field of some record value, `myRec`. + +- Changed the type of `=:=` again to work directly with `Label`s as this is the most convenient usage. + +- Definitions in `Data.Vinyl.Core` are now consistently in terms of type classes. This permits inlining and specialization to a user's record types. In the case where the record type is known, call sites do not change. But for functions polymorphic in the record's fields, a constraint will be required. If those constraints are a nuisance, or compile times increase beyond comfort, users should use definitions from the `Data.Vinyl.Recursive` that are written in a recursive style (as in previous versions of the `vinyl` package), treating the record as a list of fields. + +- Added `restrictCoRec` and `weakenCoRec` suggested by @ElvishJerricco + +# 0.8.0 + +- Overhaul of `FieldRec`: records with named fields. We now take advantage of the `-XOverloadedLabels` extension to support referring to record fields by names such a `#myField`. + +- A new `ARec` type for constant-time field access. You can convert a classic, HList-like `Rec` into an `ARec` with `toARec`, or back the other way with `fromARec`. An `ARec` uses an `Array` to store record fields, so the usual trade-offs between lists and arrays apply: lists are cheap to construct by adding an element to the head, but slow to access; it is expensive to modify the shape of an array, but element lookup is constant-time. + +**Compatibility Break**: The operator `=:` for constructing a record with a single field has changed. That operation is now known as `=:=`, while `=:` is now used to construct an `ElField`. It was decided that single-field record construction was not a common use-case, so the shorter name could be used for the more common operation. Apologies for making the upgrade a bit bumpy. + +# 0.7.0 +- Simplified `match` +- Added `Data.Vinyl.Curry` + +# 0.6.0 + +Added a `CoRec` (co-record) type constructed in the same style as the existing `Rec` type for records. A `CoRec` is an open sum type: a value of `CoRec [a,b,c]` is either an `a`, a `b`, *or* a `c`. In contrast a `Rec [a,b,c]` includes an `a`, a `b`, *and*, a `c`. + +# 0.5.3 + +Added a concise `Show` instance for `Const`. + +# 0.5.2 + +Ported the tutorial to haddocks (andrewthad) + +# 0.5.1 + Added utilities for working with the `FieldRec` type. -Vinyl 0.5 -========= +# 0.5 Vinyl 0.5 combines the generality of Vinyl 0.4 with the ease-of-use of previous versions by eschewing the defunctionalized type families and just using plain @@ -14,8 +108,7 @@ Also new in 0.5 is a unified lens-based approach to subtyping, coercion and projection. -Vinyl 0.4 -========= +# 0.4 Vinyl 0.4 is a big departure from previous versions, in that it introduces a universe encoding as a means to generalize the space of keys from strings to diff --git a/Data/Vinyl.hs b/Data/Vinyl.hs --- a/Data/Vinyl.hs +++ b/Data/Vinyl.hs @@ -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) diff --git a/Data/Vinyl/ARec.hs b/Data/Vinyl/ARec.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/ARec.hs @@ -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 diff --git a/Data/Vinyl/ARec/Internal.hs b/Data/Vinyl/ARec/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/ARec/Internal.hs @@ -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) diff --git a/Data/Vinyl/ARec/Internal/SmallArray.hs b/Data/Vinyl/ARec/Internal/SmallArray.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/ARec/Internal/SmallArray.hs @@ -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 #-} diff --git a/Data/Vinyl/Class/Method.hs b/Data/Vinyl/Class/Method.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/Class/Method.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| This module uses 'RecAll' to extend common typeclass methods to records. + Generally, it is preferable to use the original typeclass methods to these + variants. For example, in most places where 'recCompare' could be used, + you could use 'compare' instead. They are useful in scenarios + that involve working on unknown subsets of a record's fields + because 'RecAll' constraints can easily be weakened. An example of this + is given at the bottom of this page. +-} + +module Data.Vinyl.Class.Method + ( -- * Mapping methods over records + RecMapMethod(..) + , rmapMethodF + , mapFields + , RecMapMethod1(..) + , RecPointed(..) + , rtraverseInMethod + , rsequenceInFields + -- * Support for 'RecMapMethod' + , FieldTyper, ApplyFieldTyper, PayloadType + -- * Eq Functions + , recEq + -- * Ord Functions + , recCompare + -- * Monoid Functions + , recMempty + , recMappend + , recMconcat + -- * Num Functions + , recAdd + , recSubtract + , recMultiply + , recAbs + , recSignum + , recNegate + -- * Bounded Functions + , recMinBound + , recMaxBound + -- * Example + -- $example + ) where +import Data.Functor.Product (Product(Pair)) +import Data.Vinyl.Core +import Data.Vinyl.Derived (KnownField, AllFields, FieldRec, traverseField) +import Data.Vinyl.Functor ((:.), getCompose, ElField(..)) +import Data.Vinyl.TypeLevel +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid +#endif + +recEq :: RecAll f rs Eq => Rec f rs -> Rec f rs -> Bool +recEq RNil RNil = True +recEq (a :& as) (b :& bs) = a == b && recEq as bs + +recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering +recCompare RNil RNil = EQ +recCompare (a :& as) (b :& bs) = compare a b <> recCompare as bs + +-- | This function differs from the original 'mempty' in that +-- it takes an argument. In some cases, you will already +-- have a record of the type you are interested in, and +-- that can be passed an the argument. In other situations +-- where this is not the case, you may need the +-- interpretation function of the argument record to be +-- @Const ()@ or @Proxy@ so the you can generate the +-- argument with 'rpure'. +recMempty :: RecAll f rs Monoid => Rec proxy rs -> Rec f rs +recMempty RNil = RNil +recMempty (_ :& rs) = mempty :& recMempty rs + +recMappend :: RecAll f rs Monoid => Rec f rs -> Rec f rs -> Rec f rs +recMappend RNil RNil = RNil +recMappend (a :& as) (b :& bs) = mappend a b :& recMappend as bs + +-- | This function differs from the original 'mconcat'. +-- See 'recMempty'. +recMconcat :: RecAll f rs Monoid => Rec proxy rs -> [Rec f rs] -> Rec f rs +recMconcat p [] = recMempty p +recMconcat p (rec : recs) = recMappend rec (recMconcat p recs) + +recAdd :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs +recAdd RNil RNil = RNil +recAdd (a :& as) (b :& bs) = (a + b) :& recAdd as bs + +recSubtract :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs +recSubtract RNil RNil = RNil +recSubtract (a :& as) (b :& bs) = (a - b) :& recSubtract as bs + +recMultiply :: RecAll f rs Num => Rec f rs -> Rec f rs -> Rec f rs +recMultiply RNil RNil = RNil +recMultiply (a :& as) (b :& bs) = (a * b) :& recSubtract as bs + +recAbs :: RecAll f rs Num => Rec f rs -> Rec f rs +recAbs RNil = RNil +recAbs (a :& as) = abs a :& recAbs as + +recSignum :: RecAll f rs Num => Rec f rs -> Rec f rs +recSignum RNil = RNil +recSignum (a :& as) = signum a :& recAbs as + +recNegate :: RecAll f rs Num => Rec f rs -> Rec f rs +recNegate RNil = RNil +recNegate (a :& as) = negate a :& recAbs as + +-- | This function differs from the original 'minBound'. +-- See 'recMempty'. +recMinBound :: RecAll f rs Bounded => Rec proxy rs -> Rec f rs +recMinBound RNil = RNil +recMinBound (_ :& rs) = minBound :& recMinBound rs + +-- | This function differs from the original 'maxBound'. +-- See 'recMempty'. +recMaxBound :: RecAll f rs Bounded => Rec proxy rs -> Rec f rs +recMaxBound RNil = RNil +recMaxBound (_ :& rs) = maxBound :& recMaxBound rs + +-- | When we wish to apply a typeclass method to each field of a +-- 'Rec', we typically care about typeclass instances of the record +-- field types irrespective of the record's functor context. To expose +-- the field types themselves, we utilize a constraint built from a +-- defunctionalized type family in the 'rmapMethod' method. The +-- symbols of the function space are defined by this data type. +data FieldTyper = FieldId | FieldSnd + +-- | The interpretation function of the 'FieldTyper' symbols. +type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where + ApplyFieldTyper 'FieldId a = a + ApplyFieldTyper 'FieldSnd a = Snd a + +-- | A mapping of record contexts into the 'FieldTyper' function +-- space. We explicitly match on 'ElField' to pick out the payload +-- type, and 'Compose' to pick out the inner-most context. All other +-- type constructor contexts are understood to not perform any +-- computation on their arguments. +type family FieldPayload (f :: u -> *) :: FieldTyper where + FieldPayload ElField = 'FieldSnd + FieldPayload (f :. g) = FieldPayload g + FieldPayload f = 'FieldId + +-- | Shorthand for combining 'ApplyFieldTyper' and 'FieldPayload'. +type family PayloadType f (a :: u) :: * where + PayloadType f a = ApplyFieldTyper (FieldPayload f) a + +-- | Generate a record from fields derived from type class +-- instances. +class RecPointed c f ts where + rpointMethod :: (forall a. c (f a) => f a) -> Rec f ts + +instance RecPointed c f '[] where + rpointMethod _ = RNil + {-# INLINE rpointMethod #-} + +instance (c (f t), RecPointed c f ts) + => RecPointed c f (t ': ts) where + rpointMethod f = f :& rpointMethod @c f + {-# INLINE rpointMethod #-} + +-- | Apply a typeclass method to each field of a 'Rec' where the class +-- constrains the index of the field, but not its interpretation +-- functor. +class RecMapMethod c f ts where + rmapMethod :: (forall a. c (PayloadType f a) => f a -> g a) + -> Rec f ts -> Rec g ts + +-- | Apply a typeclass method to each field of a 'Rec' where the class +-- constrains the field when considered as a value interpreted by the +-- record's interpretation functor. +class RecMapMethod1 c f ts where + rmapMethod1 :: (forall a. c (f a) => f a -> g a) + -> Rec f ts -> Rec g ts + +instance RecMapMethod c f '[] where + rmapMethod _ RNil = RNil + {-# INLINE rmapMethod #-} + +instance RecMapMethod1 c f '[] where + rmapMethod1 _ RNil = RNil + {-# INLINE rmapMethod1 #-} + +instance (c (PayloadType f t), RecMapMethod c f ts) + => RecMapMethod c f (t ': ts) where + rmapMethod f (x :& xs) = f x :& rmapMethod @c f xs + {-# INLINE rmapMethod #-} + +instance (c (f t), RecMapMethod1 c f ts) => RecMapMethod1 c f (t ': ts) where + rmapMethod1 f (x :& xs) = f x :& rmapMethod1 @c f xs + {-# INLINE rmapMethod1 #-} + +-- | Apply a typeclass method to each field of a @Rec f ts@ using the +-- 'Functor' instance for @f@ to lift the function into the +-- functor. This is a commonly-used specialization of 'rmapMethod' +-- composed with 'fmap'. +rmapMethodF :: forall c f ts. (Functor f, FieldPayload f ~ 'FieldId, RecMapMethod c f ts) + => (forall a. c a => a -> a) -> Rec f ts -> Rec f ts +rmapMethodF f = rmapMethod @c (fmap f) +{-# INLINE rmapMethodF #-} + +-- | Apply a typeclass method to each field of a 'FieldRec'. This is a +-- specialization of 'rmapMethod'. +mapFields :: forall c ts. RecMapMethod c ElField ts + => (forall a. c a => a -> a) -> FieldRec ts -> FieldRec ts +mapFields f = rmapMethod @c g + where g :: c (PayloadType ElField t) => ElField t -> ElField t + g (Field x) = Field (f x) +{-# INLINE mapFields #-} + +-- | Like 'rtraverseIn', but the function between functors may be +-- constrained. +rtraverseInMethod :: forall c h f g rs. + (RMap rs, RPureConstrained c rs, RApply rs) + => (forall a. c a => f a -> g (ApplyToField h a)) + -> Rec f rs + -> Rec g (MapTyCon h rs) +rtraverseInMethod f = rtraverseIn @h (withPairedDict @c f) + . rzipWith Pair (rpureConstrained @c aux) + where aux :: c b => DictOnly c b + aux = DictOnly + +-- Note: rtraverseInMethod is written with that `aux` helper in order +-- to work around compatibility with GHC < 8.4. Write it more +-- naturally as `DictOnly @c` does not work with older compilers. + +-- | Push an outer layer of interpretation functor into each named field. +rsequenceInFields :: forall f rs. (Functor f, AllFields rs, RMap rs) + => Rec (f :. ElField) rs -> Rec ElField (MapTyCon f rs) +rsequenceInFields = rtraverseInMethod @KnownField (traverseField id . getCompose) + + +{- $example + This module provides variants of typeclass methods that have + a 'RecAll' constraint instead of the normal typeclass + constraint. For example, a type-specialized 'compare' would + look like this: + +> compare :: Ord (Rec f rs) => Rec f rs -> Rec f rs -> Ordering + + The 'recCompare' function looks like this: + +> recCompare :: RecAll f rs Ord => Rec f rs -> Rec f rs -> Ordering + + The only difference is the constraint. Let's look at a potential + use case for these functions. + + Let's write a function that projects out a subrecord from two records and + then compares those for equality. We can write this with + the '<:' operator from @Data.Vinyl.Lens@ and the normal 'compare' + function. We don't need 'recCompare': + +> -- This needs ScopedTypeVariables +> projectAndCompare :: forall super sub f. (super <: sub, Ord (Rec f sub)) +> => Proxy sub -> Rec f super -> Rec f super -> Ordering +> projectAndCompare _ a b = compare (rcast a :: Rec f sub) (rcast b :: Rec f sub) + + That works fine for the majority of use cases, and it is probably how you should + write the function if it does everything you need. However, let's consider + a somewhat more complicated case. + + What if the exact subrecord we were projecting couldn't be + known at compile time? Assume that the end user was allowd to + choose the fields on which he or she wanted to compare records. + The @projectAndCompare@ function cannot handle this because of the + @Ord (Rec f sub)@ constraint. Even if we amend the constraint to + read @Ord (Rec f super)@ instead, we cannot use this information + to recover the @Ord (Rec f sub)@ constraint that we need. Let's + try another approach. + + We can use the following GADT to prove subsethood: + +> data Sublist (super :: [k]) (sub :: [k]) where +> SublistNil :: Sublist '[] +> SublistSuper :: Proxy r -> Sublist super sub -> Sublist (r ': super) sub +> SublistBoth :: Proxy r -> Sublist super sub -> Sublist (r ': super) (r ': sub) +> +> projectRec :: Sublist super sub -> Rec f super -> Rec f sub +> projectRec s r = case s of +> SublistNil -> RNil +> SublistBoth n snext -> case r of +> rhead :& rtail -> rhead :& projectRec snext rtail +> SublistSuper n snext -> case r of +> rhead :& rtail -> projectRec snext rtail + + It is also possible to write a typeclass to generate @Sublist@s + implicitly, but that is beyond the scope of this example. Let's + now write a function to use @Sublist@ to weaken a 'RecAll' + constraint: + +> import Data.Vinyl.Core hiding (Dict) +> import Data.Constraint +> +> weakenRecAll :: Proxy f -> Proxy c -> Sublist super sub -> RecAll f super c :- RecAll f sub c +> weakenRecAll f c s = case s of +> SublistNil -> Sub Dict +> SublistSuper _ snext -> Sub $ case weakenRecAll f c snext of +> Sub Dict -> Dict +> SublistBoth _ snext -> Sub $ case weakenRecAll f c snext of +> Sub Dict -> Dict + + Now we can write a different version of our original function: + +> -- This needs ScopedTypeVariables +> projectAndCompare2 :: forall super sub f. (RecAll f super Ord) +> => Sublist super sub -> Rec f super -> Rec f super -> Ordering +> projectAndCompare2 s a b = case weakenRecAll (Proxy :: Proxy f) (Proxy :: Proxy Ord) s of +> Sub Dict -> recCompare (projectRec s a) (projectRec s b) + + Notice that in this case, the 'Ord' constraint applies to the full set of fields + and is then weakened to target a subset of them instead. +-} diff --git a/Data/Vinyl/CoRec.hs b/Data/Vinyl/CoRec.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/CoRec.hs @@ -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 diff --git a/Data/Vinyl/Core.hs b/Data/Vinyl/Core.hs --- a/Data/Vinyl/Core.hs +++ b/Data/Vinyl/Core.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,20 +10,52 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | Core vinyl definitions. The 'Rec' data type is defined here, but +-- also of interest are definitions commonly used functions like +-- 'rmap', 'rapply', and 'rtraverse'. +-- +-- The definitions in this module are written in terms of type classes +-- so that the definitions may be specialized to each record type at +-- which they are used. This usually helps with runtime performance, +-- but can slow down compilation time. If you are experiencing poor +-- compile times, you may wish to try the semantically equivalent +-- definitions in the "Data.Vinyl.Recursive" module: they should +-- produce the same results given the same inputs as functions defined +-- in this module, but they will not be specialized to your record +-- type. Instead, they treat the record as a list of fields, so will +-- have performance linear in the size of the record. module Data.Vinyl.Core where - -import Data.Monoid +import Data.Coerce (Coercible) +#if __GLASGOW_HASKELL__ < 808 +import Data.Monoid (Monoid) +#endif +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup (Semigroup(..)) +#endif import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..)) -import Data.Vinyl.Functor -import Control.Applicative hiding (Const(..)) -import Data.Typeable (Proxy(..)) +import Data.Functor.Product (Product(Pair)) import Data.List (intercalate) +import Data.Vinyl.Functor import Data.Vinyl.TypeLevel +import Data.Type.Equality (TestEquality (..), (:~:) (..)) +import Data.Type.Coercion (TestCoercion (..), Coercion (..)) +import GHC.Generics +import GHC.Types (Constraint, Type) +import Unsafe.Coerce (unsafeCoerce) +import Control.DeepSeq (NFData, rnf) +#if __GLASGOW_HASKELL__ < 806 +import Data.Constraint.Forall (Forall) +#endif -- | A record is parameterized by a universe @u@, an interpretation @f@ and a -- list of rows @rs@. The labels or indices of the record are given by @@ -31,11 +65,27 @@ RNil :: Rec f '[] (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) -infixr :& +infixr 7 :& infixr 5 <+> infixl 8 <<$>> infixl 8 <<*>> +instance TestEquality f => TestEquality (Rec f) where + testEquality RNil RNil = Just Refl + testEquality (x :& xs) (y :& ys) = do + Refl <- testEquality x y + Refl <- testEquality xs ys + Just Refl + testEquality _ _ = Nothing + +instance TestCoercion f => TestCoercion (Rec f) where + testCoercion RNil RNil = Just Coercion + testCoercion (x :& xs) (y :& ys) = do + Coercion <- testCoercion x y + Coercion <- testCoercion xs ys + Just Coercion + testCoercion _ _ = Nothing + -- | Two records may be pasted together. rappend :: Rec f as @@ -51,20 +101,41 @@ -> Rec f (as ++ bs) (<+>) = rappend +-- | Combine two records by combining their fields using the given +-- function. The first argument is a binary operation for combining +-- two values (e.g. '(<>)'), the second argument takes a record field +-- into the type equipped with the desired operation, the third +-- argument takes the combined value back to a result type. +rcombine :: (RMap rs, RApply rs) + => (forall a. m a -> m a -> m a) + -> (forall a. f a -> m a) + -> (forall a. m a -> g a) + -> Rec f rs + -> Rec f rs + -> Rec g rs +rcombine smash toM fromM x y = + rmap fromM (rapply (rmap (Lift . smash) x') y') + where x' = rmap toM x + y' = rmap toM y + -- | 'Rec' @_ rs@ with labels in kind @u@ gives rise to a functor @Hask^u -> -- Hask@; that is, a natural transformation between two interpretation functors -- @f,g@ may be used to transport a value from 'Rec' @f rs@ to 'Rec' @g rs@. -rmap - :: (forall x. f x -> g x) - -> Rec f rs - -> Rec g rs -rmap _ RNil = RNil -rmap η (x :& xs) = η x :& (η `rmap` xs) -{-# INLINE rmap #-} +class RMap rs where + rmap :: (forall x. f x -> g x) -> Rec f rs -> Rec g rs +instance RMap '[] where + rmap _ RNil = RNil + {-# INLINE rmap #-} + +instance RMap xs => RMap (x ': xs) where + rmap f (x :& xs) = f x :& rmap f xs + {-# INLINE rmap #-} + -- | A shorthand for 'rmap'. (<<$>>) - :: (forall x. f x -> g x) + :: RMap rs + => (forall x. f x -> g x) -> Rec f rs -> Rec g rs (<<$>>) = rmap @@ -72,7 +143,8 @@ -- | An inverted shorthand for 'rmap'. (<<&>>) - :: Rec f rs + :: RMap rs + => Rec f rs -> (forall x. f x -> g x) -> Rec g rs xs <<&>> f = rmap f xs @@ -80,17 +152,23 @@ -- | A record of components @f r -> g r@ may be applied to a record of @f@ to -- get a record of @g@. -rapply - :: Rec (Lift (->) f g) rs - -> Rec f rs - -> Rec g rs -rapply RNil RNil = RNil -rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs) -{-# INLINE rapply #-} +class RApply rs where + rapply :: Rec (Lift (->) f g) rs + -> Rec f rs + -> Rec g rs +instance RApply '[] where + rapply _ RNil = RNil + {-# INLINE rapply #-} + +instance RApply xs => RApply (x ': xs) where + rapply (f :& fs) (x :& xs) = getLift f x :& (fs `rapply` xs) + {-# INLINE rapply #-} + -- | A shorthand for 'rapply'. (<<*>>) - :: Rec (Lift (->) f g) rs + :: RApply rs + => Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs (<<*>>) = rapply @@ -121,13 +199,68 @@ rtraverse f (x :& xs) = (:&) <$> f x <*> rtraverse f xs {-# INLINABLE rtraverse #-} +-- | While 'rtraverse' pulls the interpretation functor out of the +-- record, 'rtraverseIn' pushes the interpretation functor in to each +-- field type. This is particularly useful when you wish to discharge +-- that interpretation on a per-field basis. For instance, rather than +-- a @Rec IO '[a,b]@, you may wish to have a @Rec Identity '[IO a, IO +-- b]@ so that you can evaluate a single field to obtain a value of +-- type @Rec Identity '[a, IO b]@. +rtraverseIn :: forall h f g rs. + (forall a. f a -> g (ApplyToField h a)) + -> Rec f rs + -> Rec g (MapTyCon h rs) +rtraverseIn _ RNil = RNil +rtraverseIn f (x :& xs) = f x :& rtraverseIn f xs +{-# INLINABLE rtraverseIn #-} + +-- | Push an outer layer of interpretation functor into each field. +rsequenceIn :: forall f g (rs :: [Type]). (Traversable f, Applicative g) + => Rec (f :. g) rs -> Rec g (MapTyCon f rs) +rsequenceIn = rtraverseIn @f (sequenceA . getCompose) +{-# INLINABLE rsequenceIn #-} + +-- | Given a natural transformation from the product of @f@ and @g@ to @h@, we +-- have a natural transformation from the product of @'Rec' f@ and @'Rec' g@ to +-- @'Rec' h@. You can also think about this operation as zipping two records +-- with the same element types but different interpretations. +rzipWith :: (RMap xs, RApply xs) + => (forall x. f x -> g x -> h x) -> Rec f xs -> Rec g xs -> Rec h xs +rzipWith f = rapply . rmap (Lift . f) + +-- | Map each element of a record to a monoid and combine the results. +class RFoldMap rs where + rfoldMapAux :: Monoid m + => (forall x. f x -> m) + -> m + -> Rec f rs + -> m + +instance RFoldMap '[] where + rfoldMapAux _ m RNil = m + {-# INLINE rfoldMapAux #-} + +instance RFoldMap xs => RFoldMap (x ': xs) where + rfoldMapAux f m (r :& rs) = rfoldMapAux f (mappend m (f r)) rs + {-# INLINE rfoldMapAux #-} + +rfoldMap :: forall rs m f. (Monoid m, RFoldMap rs) + => (forall x. f x -> m) -> Rec f rs -> m +rfoldMap f = rfoldMapAux f mempty +{-# INLINE rfoldMap #-} + -- | A record with uniform fields may be turned into a list. -recordToList - :: Rec (Const a) rs - -> [a] -recordToList RNil = [] -recordToList (x :& xs) = getConst x : recordToList xs +class RecordToList rs where + recordToList :: Rec (Const a) rs -> [a] +instance RecordToList '[] where + recordToList RNil = [] + {-# INLINE recordToList #-} + +instance RecordToList xs => RecordToList (x ': xs) where + recordToList (x :& xs) = getConst x : recordToList xs + {-# INLINE recordToList #-} + -- | Wrap up a value with a capability given by its type data Dict c a where Dict @@ -140,53 +273,231 @@ -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly, -- the constraint solver is not quite smart enough to realize this and we must -- make it patently obvious by reifying the constraint pointwise with proof. -reifyConstraint - :: RecAll f rs c - => proxy c - -> Rec f rs - -> Rec (Dict c :. f) rs -reifyConstraint prx rec = - case rec of - RNil -> RNil - (x :& xs) -> Compose (Dict x) :& reifyConstraint prx xs +class ReifyConstraint c f rs where + reifyConstraint + :: Rec f rs + -> Rec (Dict c :. f) rs +instance ReifyConstraint c f '[] where + reifyConstraint RNil = RNil + {-# INLINE reifyConstraint #-} + +instance (c (f x), ReifyConstraint c f xs) + => ReifyConstraint c f (x ': xs) where + reifyConstraint (x :& xs) = Compose (Dict x) :& reifyConstraint xs + {-# INLINE reifyConstraint #-} + +-- | Build a record whose elements are derived solely from a +-- constraint satisfied by each. +class RPureConstrained c ts where + rpureConstrained :: (forall a. c a => f a) -> Rec f ts + +instance RPureConstrained c '[] where + rpureConstrained _ = RNil + {-# INLINE rpureConstrained #-} + +instance (c x, RPureConstrained c xs) => RPureConstrained c (x ': xs) where + rpureConstrained f = f :& rpureConstrained @c @xs f + {-# INLINE rpureConstrained #-} + +-- | Capture a type class instance dictionary. See +-- 'Data.Vinyl.Lens.getDict' for a way to obtain a 'DictOnly' value +-- from an 'RPureConstrained' constraint. +data DictOnly (c :: k -> Constraint) a where + DictOnly :: forall c a. c a => DictOnly c a + +-- | A useful technique is to use 'rmap (Pair (DictOnly @MyClass))' on +-- a 'Rec' to pair each field with a type class dictionary for +-- @MyClass@. This helper can then be used to eliminate the original. +withPairedDict :: (c a => f a -> r) -> Product (DictOnly c) f a -> r +withPairedDict f (Pair DictOnly x) = f x + +-- | Build a record whose elements are derived solely from a +-- list of constraint constructors satisfied by each. +class RPureConstraints cs ts where + rpureConstraints :: (forall a. AllSatisfied cs a => f a) -> Rec f ts + +instance RPureConstraints cs '[] where + rpureConstraints _ = RNil + {-# INLINE rpureConstraints #-} + +instance (AllSatisfied cs t, RPureConstraints cs ts) + => RPureConstraints cs (t ': ts) where + rpureConstraints f = f :& rpureConstraints @cs @ts f + {-# INLINE rpureConstraints #-} + -- | Records may be shown insofar as their points may be shown. -- 'reifyConstraint' is used to great effect here. -instance RecAll f rs Show => Show (Rec f rs) where +instance (RMap rs, ReifyConstraint Show f rs, RecordToList rs) + => Show (Rec f rs) where show xs = (\str -> "{" <> str <> "}") . intercalate ", " . recordToList . rmap (\(Compose (Dict x)) -> Const $ show x) - $ reifyConstraint (Proxy :: Proxy Show) xs + $ reifyConstraint @Show xs +instance Semigroup (Rec f '[]) where + RNil <> RNil = RNil + +instance (Semigroup (f r), Semigroup (Rec f rs)) + => Semigroup (Rec f (r ': rs)) where + (x :& xs) <> (y :& ys) = (x <> y) :& (xs <> ys) + instance Monoid (Rec f '[]) where mempty = RNil RNil `mappend` RNil = RNil instance (Monoid (f r), Monoid (Rec f rs)) => Monoid (Rec f (r ': rs)) where mempty = mempty :& mempty - (x :& xs) `mappend` (y :& ys) = (x <> y) :& (xs <> ys) + (x :& xs) `mappend` (y :& ys) = (mappend x y) :& (mappend xs ys) instance Eq (Rec f '[]) where _ == _ = True instance (Eq (f r), Eq (Rec f rs)) => Eq (Rec f (r ': rs)) where (x :& xs) == (y :& ys) = (x == y) && (xs == ys) +instance Ord (Rec f '[]) where + compare _ _ = EQ +instance (Ord (f r), Ord (Rec f rs)) => Ord (Rec f (r ': rs)) where + compare (x :& xs) (y :& ys) = mappend (compare x y) (compare xs ys) + instance Storable (Rec f '[]) where sizeOf _ = 0 alignment _ = 0 peek _ = return RNil poke _ RNil = return () -instance (Storable (f r), Storable (Rec f rs)) => Storable (Rec f (r ': rs)) where +instance (Storable (f r), Storable (Rec f rs)) + => Storable (Rec f (r ': rs)) where sizeOf _ = sizeOf (undefined :: f r) + sizeOf (undefined :: Rec f rs) - {-# INLINABLE sizeOf #-} + {-# INLINE sizeOf #-} alignment _ = alignment (undefined :: f r) - {-# INLINABLE alignment #-} + {-# INLINE alignment #-} peek ptr = do !x <- peek (castPtr ptr) !xs <- peek (ptr `plusPtr` sizeOf (undefined :: f r)) return $ x :& xs - {-# INLINABLE peek #-} + {-# INLINE peek #-} poke ptr (!x :& xs) = poke (castPtr ptr) x >> poke (ptr `plusPtr` sizeOf (undefined :: f r)) xs - {-# INLINEABLE poke #-} + {-# INLINE poke #-} + +instance Generic (Rec f '[]) where + type Rep (Rec f '[]) = + C1 ('MetaCons "RNil" 'PrefixI 'False) + (S1 ('MetaSel 'Nothing + 'NoSourceUnpackedness + 'NoSourceStrictness + 'DecidedLazy) U1) + from RNil = M1 (M1 U1) + to (M1 (M1 U1)) = RNil + +instance (Generic (Rec f rs)) => Generic (Rec f (r ': rs)) where + type Rep (Rec f (r ': rs)) = + C1 ('MetaCons ":&" ('InfixI 'RightAssociative 7) 'False) + (S1 ('MetaSel 'Nothing + 'NoSourceUnpackedness + 'SourceStrict + 'DecidedStrict) + (Rec0 (f r)) + :*: + S1 ('MetaSel 'Nothing + 'NoSourceUnpackedness + 'NoSourceStrictness + 'DecidedLazy) + (Rep (Rec f rs))) + from (x :& xs) = M1 (M1 (K1 x) :*: M1 (from xs)) + to (M1 (M1 (K1 x) :*: M1 xs)) = x :& to xs + +instance ReifyConstraint NFData f xs => NFData (Rec f xs) where + rnf = go . reifyConstraint @NFData + where + go :: forall elems. Rec (Dict NFData :. f) elems -> () + go RNil = () + go (Compose (Dict x) :& xs) = rnf x `seq` go xs + +type family Head xs where + Head (x ': _) = x +type family Tail xs where + Tail (_ ': xs) = xs + +type family AllRepsMatch_ (f :: j -> *) (xs :: [j]) (g :: k -> *) (ys :: [k]) :: Constraint where + AllRepsMatch_ f (x ': xs) g ys = + ( ys ~ (Head ys ': Tail ys) + , Coercible (f x) (g (Head ys)) + , AllRepsMatch_ f xs g (Tail ys) ) + AllRepsMatch_ _ '[] _ ys = ys ~ '[] + +-- | @AllRepsMatch f xs g ys@ means that @xs@ and @ys@ have the +-- same lengths, and that mapping @f@ over @xs@ and @g@ over @ys@ +-- produces lists whose corresponding elements are 'Coercible' with +-- each other. For example, the following hold: +-- +-- @AllRepsMatch Proxy '[1,2,3] Proxy '[4,5,6]@ +-- @AllRepsMatch Sum '[Int,Word] Identity '[Min Int, Max Word]@ +type AllRepsMatch f xs g ys = (AllRepsMatch_ f xs g ys, AllRepsMatch_ g ys f xs) + +-- This two-sided approach means that the *length* of each list +-- can be inferred from the length of the other. I don't know how +-- useful that is in practice, but we get it almost for free. + +-- | Given that for each element @x@ in the list @xs@, +repsMatchCoercion :: AllRepsMatch f xs g ys => Coercion (Rec f xs) (Rec g ys) +repsMatchCoercion = unsafeCoerce (Coercion :: Coercion () ()) + +{- +-- "Proof" that repsMatchCoercion is sensible. +repsMatchConvert :: AllRepsMatch f xs g ys => Rec f xs -> Rec g ys +repsMatchConvert RNil = RNil +repsMatchConvert (x :& xs) = coerce x :& repsMatchConvert xs +-} + +#if __GLASGOW_HASKELL__ >= 806 +consMatchCoercion :: + (forall (x :: k). Coercible (f x) (g x)) => Coercion (Rec f xs) (Rec g xs) +#else +consMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). + Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs) +#endif +consMatchCoercion = unsafeCoerce (Coercion :: Coercion () ()) +{- +-- "Proof" that consMatchCoercion is sensible. +consMatchConvert :: + (forall (x :: k). Coercible (f x) (g x)) => Rec f xs -> Rec g xs +consMatchConvert RNil = RNil +consMatchConvert (x :& xs) = coerce x :& consMatchConvert xs + +-- And for old GHC. +consMatchConvert' :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). + Forall (Similar f g) => Rec f xs -> Rec g xs +consMatchConvert' RNil = RNil +consMatchConvert' ((x :: f x) :& xs) = + case inst :: Forall (Similar f g) DC.:- Similar f g x of + DC.Sub DC.Dict -> coerce x :& consMatchConvert' xs +-} + +{- +-- This is sensible, but I suspect the ergonomics will be awful +-- thanks to the interaction between Coercible constraint resolution +-- and constraint resolution with quantified constraints. Is there +-- a good way to accomplish it? + +-- | Given +-- +-- @ +-- forall x. Coercible (f x) (g x) +-- @ +-- +-- provide the constraint +-- +-- @ +-- forall xs. Coercible (Rec f xs) (Rec g xs) +-- @ +consMatchCoercible :: forall k f g rep (r :: TYPE rep). + (forall (x :: k). Coercible (f x) (g x)) + => ((forall (xs :: [k]). Coercible (Rec f xs) (Rec g xs)) => r) -> r +consMatchCoercible f = case unsafeCoerce @(Zouch f f) @(Zouch f g) (Zouch $ \r -> r) of + Zouch q -> q f + +newtype Zouch (f :: k -> *) (g :: k -> *) = + Zouch (forall rep (r :: TYPE rep). ((forall (xs :: [k]). Coercible (Rec f xs) (Rec g xs)) => r) -> r) +-} diff --git a/Data/Vinyl/Curry.hs b/Data/Vinyl/Curry.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/Curry.hs @@ -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 diff --git a/Data/Vinyl/Derived.hs b/Data/Vinyl/Derived.hs --- a/Data/Vinyl/Derived.hs +++ b/Data/Vinyl/Derived.hs @@ -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. diff --git a/Data/Vinyl/FromTuple.hs b/Data/Vinyl/FromTuple.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/FromTuple.hs @@ -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) diff --git a/Data/Vinyl/Functor.hs b/Data/Vinyl/Functor.hs --- a/Data/Vinyl/Functor.hs +++ b/Data/Vinyl/Functor.hs @@ -1,26 +1,71 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Data.Vinyl.Functor where +module Data.Vinyl.Functor + ( -- * Introduction + -- $introduction + -- * Data Types + Identity(..) + , Thunk(..) + , Lift(..) + , ElField(..) + , Compose(..), onCompose + , (:.) + , Const(..) + -- * Discussion -import Control.Applicative -import Data.Foldable -import Data.Traversable + -- ** Example + -- $example + + -- ** Ecosystem + -- $ecosystem + ) where + +import Data.Proxy +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif +import Foreign.Ptr (castPtr) import Foreign.Storable +import GHC.Generics +import GHC.TypeLits +import GHC.Types (Type) +import Data.Vinyl.TypeLevel (Snd) +{- $introduction + This module provides functors and functor compositions + that can be used as the interpretation function for a + 'Rec'. For a more full discussion of this, scroll down + to the bottom. +-} + +-- | This is identical to the "Identity" from "Data.Functor.Identity" +-- in "base" except for its 'Show' instance. newtype Identity a = Identity { getIdentity :: a } deriving ( Functor , Foldable , Traversable , Storable + , Eq + , Ord + , Generic ) +-- | Used this instead of 'Identity' to make a record +-- lazy in its fields. data Thunk a = Thunk { getThunk :: a } deriving ( Functor @@ -33,9 +78,23 @@ newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) = Compose { getCompose :: f (g x) } - deriving (Storable) + deriving (Storable, Generic) +instance Semigroup (f (g a)) => Semigroup (Compose f g a) where + Compose x <> Compose y = Compose (x <> y) + +instance Monoid (f (g a)) => Monoid (Compose f g a) where + mempty = Compose mempty + mappend (Compose x) (Compose y) = Compose (mappend x y) + +-- | Apply a function to a value whose type is the application of the +-- 'Compose' type constructor. This works under the 'Compose' newtype +-- wrapper. +onCompose :: (f (g a) -> h (k a)) -> (f :. g) a -> (h :. k) a +onCompose f = Compose . f . getCompose + type f :. g = Compose f g +infixr 9 :. newtype Const (a :: *) (b :: k) = Const { getConst :: a } @@ -43,8 +102,80 @@ , Foldable , Traversable , Storable + , Generic ) +-- | A value with a phantom 'Symbol' label. It is not a +-- Haskell 'Functor', but it is used in many of the same places a +-- 'Functor' is used in vinyl. +-- +-- Morally: newtype ElField (s, t) = Field t +-- But GHC doesn't allow that +newtype ElField (t :: (Symbol, Type)) = Field (Snd t) + +deriving instance Eq t => Eq (ElField '(s,t)) +deriving instance Ord t => Ord (ElField '(s,t)) + +instance KnownSymbol s => Generic (ElField '(s,a)) where + type Rep (ElField '(s,a)) = C1 ('MetaCons s 'PrefixI 'False) (Rec0 a) + from (Field x) = M1 (K1 x) + to (M1 (K1 x)) = Field x + +instance (Num t, KnownSymbol s) => Num (ElField '(s,t)) where + Field x + Field y = Field (x+y) + Field x * Field y = Field (x*y) + abs (Field x) = Field (abs x) + signum (Field x) = Field (signum x) + fromInteger = Field . fromInteger + negate (Field x) = Field (negate x) + +instance Semigroup t => Semigroup (ElField '(s,t)) where + Field x <> Field y = Field (x <> y) + +instance (KnownSymbol s, Monoid t) => Monoid (ElField '(s,t)) where + mempty = Field mempty + mappend (Field x) (Field y) = Field (mappend x y) + +instance (Real t, KnownSymbol s) => Real (ElField '(s,t)) where + toRational (Field x) = toRational x + +instance (Fractional t, KnownSymbol s) => Fractional (ElField '(s,t)) where + fromRational = Field . fromRational + Field x / Field y = Field (x / y) + +instance (Floating t, KnownSymbol s) => Floating (ElField '(s,t)) where + pi = Field pi + exp (Field x) = Field (exp x) + log (Field x) = Field (log x) + sin (Field x) = Field (sin x) + cos (Field x) = Field (cos x) + asin (Field x) = Field (asin x) + acos (Field x) = Field (acos x) + atan (Field x) = Field (atan x) + sinh (Field x) = Field (sinh x) + cosh (Field x) = Field (cosh x) + asinh (Field x) = Field (asinh x) + acosh (Field x) = Field (acosh x) + atanh (Field x) = Field (atanh x) + +instance (RealFrac t, KnownSymbol s) => RealFrac (ElField '(s,t)) where + properFraction (Field x) = fmap Field (properFraction x) + +instance (Show t, KnownSymbol s) => Show (ElField '(s,t)) where + show (Field x) = symbolVal (Proxy::Proxy s) ++" :-> "++show x + +instance forall s t. (KnownSymbol s, Storable t) + => Storable (ElField '(s,t)) where + sizeOf _ = sizeOf (undefined::t) + alignment _ = alignment (undefined::t) + peek ptr = Field `fmap` peek (castPtr ptr) + poke ptr (Field x) = poke (castPtr ptr) x +instance Show a => Show (Const a b) where + show (Const x) = "(Const "++show x ++")" + +instance Eq a => Eq (Const a b) where + Const x == Const y = x == y + instance (Functor f, Functor g) => Functor (Compose f g) where fmap f (Compose x) = Compose (fmap (fmap f) x) @@ -58,6 +189,9 @@ pure x = Compose (pure (pure x)) Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +instance Show (f (g a)) => Show (Compose f g a) where + show (Compose x) = show x + instance Applicative Identity where pure = Identity Identity f <*> Identity x = Identity (f x) @@ -91,3 +225,99 @@ pure x = Lift (pure x, pure x) Lift (f, g) <*> Lift (x, y) = Lift (f <*> x, g <*> y) +-- $setup +-- >>> import Data.Vinyl.Core +-- >>> :set -XDataKinds +-- + +{- $example + The data types in this module are used to build interpretation + fuctions for a 'Rec'. To build a 'Rec' that is simply a heterogeneous + list, use 'Identity': + +>>> :{ +let myRec1 :: Rec Identity '[Int,Bool,Char] + myRec1 = Identity 4 :& Identity True :& Identity 'c' :& RNil +:} + + For a record in which the fields are optional, you could alternatively + write: + +>>> :{ +let myRec2 :: Rec Maybe '[Int,Bool,Char] + myRec2 = Just 4 :& Nothing :& Nothing :& RNil +:} + + And we can gather all of the effects with 'rtraverse': + +>>> let r2 = rtraverse (fmap Identity) myRec2 +>>> :t r2 +r2 :: Maybe (Rec Identity '[Int, Bool, Char]) +>>> r2 +Nothing + + If the fields only exist once an environment is provided, you can + build the record as follows: + +>>> :{ +let myRec3 :: Rec ((->) Int) '[Int,Bool,Char] + myRec3 = (+5) :& (const True) :& (head . show) :& RNil +:} + + And again, we can collect these effects with "rtraverse": + +>>> (rtraverse (fmap Identity) myRec3) 8 +{13, True, '8'} + + If you want the composition of these two effects, you can use "Compose": + +>>> import Data.Char (chr) +>>> :{ +let safeDiv a b = if b == 0 then Nothing else Just (div a b) + safeChr i = if i >= 32 && i <= 126 then Just (chr i) else Nothing + myRec4 :: Rec (Compose ((->) Int) Maybe) '[Int,Char] + myRec4 = (Compose $ safeDiv 42) :& (Compose safeChr) :& RNil +:} + +-} + +{- $ecosystem + Of the five data types provided by this modules, three can + be found in others places: "Identity", "Compose", and "Const". + They are included with "vinyl" to help keep the dependency + list small. The differences will be discussed here. + + The "Data.Functor.Identity" module was originally provided + by "transformers". When GHC 7.10 was released, it was moved + into "base-4.8". The "Identity" data type provided by that + module is well recognized across the haskell ecosystem + and has typeclass instances for lots of common typeclasses. + The significant difference between it and the copy of + it provided here is that this one has a different 'Show' + instance. This is illustrated below: + +>>> Identity "hello" +"hello" + + But, when using "Identity" from "base": + +>>> import qualified Data.Functor.Identity as Base +>>> Base.Identity "hello" +Identity "hello" + + This 'Show' instance makes records look nicer in GHCi. + Feel free to use "Data.Functor.Identity" if you do not + need the prettier output or if you need the many additional + typeclass instances that are provided for the standard + "Identity". + + The story with "Compose" and "Const" is much more simple. + These also exist in "transformers", although "Const" + is named "Constant" there. Prior to the release of + "transformers-0.5", they were not polykinded, making + them unusable for certain universes. However, in + "transformers-0.5" and forward, they have been made + polykinded. This means that they are just as usable with 'Rec' + as the vinyl equivalents but with many more typeclass + instances such as 'Ord' and 'Show'. +-} diff --git a/Data/Vinyl/Lens.hs b/Data/Vinyl/Lens.hs --- a/Data/Vinyl/Lens.hs +++ b/Data/Vinyl/Lens.hs @@ -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) diff --git a/Data/Vinyl/Recursive.hs b/Data/Vinyl/Recursive.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/Recursive.hs @@ -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 diff --git a/Data/Vinyl/SRec.hs b/Data/Vinyl/SRec.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/SRec.hs @@ -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 #-} diff --git a/Data/Vinyl/Syntax.hs b/Data/Vinyl/Syntax.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/Syntax.hs @@ -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 diff --git a/Data/Vinyl/Tutorial/Overview.hs b/Data/Vinyl/Tutorial/Overview.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/Tutorial/Overview.hs @@ -0,0 +1,297 @@ +{-| + + Vinyl is a general solution to the records problem in Haskell using + type level strings and other modern GHC features, featuring static + structural typing (with a subtyping relation), and automatic + row-polymorphic lenses. All this is possible without Template Haskell. + + Let's work through a quick example. We'll need to enable some language + extensions first: + +>>> :set -XDataKinds +>>> :set -XPolyKinds +>>> :set -XTypeApplications +>>> :set -XTypeOperators +>>> :set -XTypeFamilies +>>> :set -XFlexibleContexts +>>> :set -XFlexibleInstances +>>> :set -XNoMonomorphismRestriction +>>> :set -XGADTs +>>> :set -XTypeSynonymInstances +>>> :set -XTemplateHaskell +>>> :set -XStandaloneDeriving + +>>> import Data.Vinyl +>>> import Data.Vinyl.Functor +>>> import Control.Applicative +>>> import Control.Lens hiding (Identity) +>>> import Control.Lens.TH +>>> import Data.Char +>>> import Test.DocTest +>>> import Data.Singletons.TH (genSingletons) +>>> import Data.Maybe + + Let's define a universe of fields which we want to use. + + First of all, we need a data type defining the field labels: + +>>> data Fields = Name | Age | Sleeping | Master deriving Show + + Any record can be now described by a type-level list of these labels. + The @DataKinds@ extension must be enabled to automatically turn all the + constructors of the @Field@ type into types. + +>>> type LifeForm = [Name, Age, Sleeping] + + Now, we need a way to map our labels to concrete types. We use a type + family for this purpose. Unfortunately, type families aren't first class in Haskell. That's + why we also need a data type, with which we will parametrise 'Rec'. + We also generate the necessary singletons for each field label using + Template Haskell. + +>>> :{ +type family ElF (f :: Fields) :: * where + ElF Name = String + ElF Age = Int + ElF Sleeping = Bool + ElF Master = Rec Attr LifeForm +newtype Attr f = Attr { _unAttr :: ElF f } +makeLenses ''Attr +genSingletons [ ''Fields ] +instance Show (Attr Name) where show (Attr x) = "name: " ++ show x +instance Show (Attr Age) where show (Attr x) = "age: " ++ show x +instance Show (Attr Sleeping) where show (Attr x) = "sleeping: " ++ show x +instance Show (Attr Master) where show (Attr x) = "master: " ++ show x +:} + + To make field construction easier, we define an operator. The first + argument of this operator is a singleton - a constructor bringing the + data-kinded field label type into the data level. It's needed because + there can be multiple labels with the same field type, so by just + supplying a value of type @ElF f@ there would be no way to deduce the + correct "f". + +>>> :{ +let (=::) :: sing f -> ElF f -> Attr f + _ =:: x = Attr x +:} + + Now, let's try to make an entity that represents a human: + +>>> :{ +let jon = (SName =:: "jon") + :& (SAge =:: 23) + :& (SSleeping =:: False) + :& RNil +:} + + Automatically, we can show the record: + +>>> print jon +{name: "jon", age: 23, sleeping: False} + +And its types are all inferred with no problem. Now, make a dog! Dogs +are life-forms, but unlike humans, they have masters. So, let’s build +my dog: + +>>> :{ +let tucker = (SName =:: "tucker") + :& (SAge =:: 9) + :& (SSleeping =:: True) + :& (SMaster =:: jon) + :& RNil +:} + +Now, if we want to wake entities up, we don\'t want to have to write a +separate wake-up function for both dogs and humans (even though they +are of different type). Luckily, we can use the built-in lenses to +focus on a particular field in the record for access and update, +without losing additional information: + +>>> :{ +let wakeUp :: (Sleeping ∈ fields) => Rec Attr fields -> Rec Attr fields + wakeUp = rput $ SSleeping =:: False +:} + +Now, the type annotation on @wakeUp@ was not necessary; I just wanted +to show how intuitive the type is. Basically, it takes as an input +any record that has a 'Bool' field labelled @sleeping@, and modifies +that specific field in the record accordingly. + +>>> let tucker' = wakeUp tucker +>>> let jon' = wakeUp jon + +>>> tucker' ^. rlens @Sleeping +sleeping: False + +>>> tucker ^. rlens @Sleeping +sleeping: True + +>>> jon' ^. rlens @Sleeping +sleeping: False + +We can also access the entire lens for a field using the rLens +function; since lenses are composable, it’s super easy to do deep +update on a record: + +>>> let masterSleeping = rlens @Master . unAttr . rlens @Sleeping +>>> let tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker' + +>>> tucker'' ^. masterSleeping +sleeping: True + +A record @Rec f xs@ is a subtype of a record @Rec f ys@ if @ys ⊆ xs@; +that is to say, if one record can do everything that another record +can, the former is a subtype of the latter. As such, we should be able +to provide an upcast operator which "forgets" whatever makes one +record different from another (whether it be extra data, or different +order). + +Therefore, the following works: + +>>> :{ +let upcastedTucker :: Rec Attr LifeForm + upcastedTucker = rcast tucker +:} + +The subtyping relationship between record types is expressed with the +'<:' constraint; so, 'rcast' is of the following type: + +> rcast :: r1 <: r2 => Rec f r2 -> Rec f r1 + +Also provided is a "≅" constraint which indicates record congruence +(that is, two record types differ only in the order of their fields). + +In fact, 'rcast' is actually given as a special case of the lens 'rsubset', +which lets you modify entire (possibly non-contiguous) slices of a record! + +Consider the following declaration: + +> data Rec :: (u -> *) -> [u] -> * where +> RNil :: Rec f '[] +> (:&) :: f r -> Rec f rs -> Rec f (r ': rs) + +Records are implicitly parameterized over a kind @u@, which stands for the +"universe" or key space. Keys (inhabitants of @u@) are then interpreted into +the types of their values by the first parameter to 'Rec', @f@. An extremely +powerful aspect of Vinyl records is that you can construct natural +transformations between different interpretation functors @f,g@, or postcompose +some other functor onto the stack. This can be used to immerse each field of a +record in some particular effect modality, and then the library functions can +be used to traverse and accumulate these effects. + +Let\'s imagine that we want to do validation on a record that +represents a name and an age: + +>>> type Person = [Name, Age] + +We\'ve decided that names must be alphabetic, and ages must be positive. For +validation, we\'ll use 'Maybe' for now, though you should use a +left-accumulating @Validation@ type (the module @Data.Either.Validation@ +from the @either@ package provides such a type, though we do not +cover it here). + +>>> :{ +let goodPerson :: Rec Attr Person + goodPerson = (SName =:: "Jon") + :& (SAge =:: 20) + :& RNil +:} + +>>> :{ +let badPerson = (SName =:: "J#@#$on") + :& (SAge =:: 20) + :& RNil +:} + +We\'ll give validation a (rather poor) shot. + +>>> :{ +let + validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person) + validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge + where + vName = validateName $ p ^. rlens @Name . unAttr + vAge = validateAge $ p ^. rlens @Age . unAttr + validateName str | all isAlpha str = Just str + validateName _ = Nothing + validateAge i | i >= 0 = Just i + validateAge _ = Nothing +:} + +Let\'s try it out: + +>>> isJust $ validatePerson goodPerson +True + +>>> isJust $ validatePerson badPerson +False + +The results are as expected (@Just@ for @goodPerson@, and a @Nothing@ for +@badPerson@); but this was not very fun to build. + +Further, it would be nice to have some notion of a partial record; +that is, if part of it can\'t be validated, it would still be nice to +be able to access the rest. What if we could make a version of this +record where the elements themselves were validation functions, and +then that record could be applied to a plain one, to get a record of +validated fields? That\'s what we’re going to do. + +>>> type Validator f = Lift (->) f (Maybe :. f) + +Let\'s parameterize a record by it: when we do, then an element of type +@a@ should be a function @Identity a -> Result e a@: + +>>> :{ +let lift f = Lift $ Compose . f + validateName (Attr str) | all isAlpha str = Just (Attr str) + validateName _ = Nothing + validateAge (Attr i) | i >= 0 = Just (Attr i) + validateAge _ = Nothing + vperson :: Rec (Validator Attr) Person + vperson = lift validateName :& lift validateAge :& RNil +:} + +And we can use the special application operator '<<*>>' (which is +analogous to '<*>', but generalized a bit) to use this to validate a +record: + +>>> let goodPersonResult = vperson <<*>> goodPerson +>>> let badPersonResult = vperson <<*>> badPerson + +>>> isJust . getCompose $ goodPersonResult ^. rlens @Name +True + +>>> isJust . getCompose $ goodPersonResult ^. rlens @Age +True + +>>> isJust . getCompose $ badPersonResult ^. rlens @Name +False + +>>> isJust . getCompose $ badPersonResult ^. rlens @Age +True + +So now we have a partial record, and we can still do stuff with its contents. +Next, we can even recover the original behavior of the validator (that is, to +give us a value of type @Maybe (Rec Attr Person)@) using `rtraverse`: + +>>> :{ +let mgoodPerson :: Maybe (Rec Attr Person) + mgoodPerson = rtraverse getCompose goodPersonResult +:} + +>>> let mbadPerson = rtraverse getCompose badPersonResult + +>>> isJust mgoodPerson +True + +>>> isJust mbadPerson +False + +-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Data.Vinyl.Tutorial.Overview where + +import Data.Vinyl.Core +import Data.Vinyl.Functor +import Data.Vinyl.Lens diff --git a/Data/Vinyl/TypeLevel.hs b/Data/Vinyl/TypeLevel.hs --- a/Data/Vinyl/TypeLevel.hs +++ b/Data/Vinyl/TypeLevel.hs @@ -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) diff --git a/Data/Vinyl/XRec.hs b/Data/Vinyl/XRec.hs new file mode 100644 --- /dev/null +++ b/Data/Vinyl/XRec.hs @@ -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 +-- 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 diff --git a/benchmarks/AccessorsBench.hs b/benchmarks/AccessorsBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AccessorsBench.hs @@ -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 + ] + ] diff --git a/benchmarks/AsABench.hs b/benchmarks/AsABench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AsABench.hs @@ -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 ] diff --git a/benchmarks/Bench/ARec.hs b/benchmarks/Bench/ARec.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench/ARec.hs @@ -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 #-} diff --git a/benchmarks/Bench/Rec.hs b/benchmarks/Bench/Rec.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench/Rec.hs @@ -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 #-} diff --git a/benchmarks/Bench/SRec.hs b/benchmarks/Bench/SRec.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench/SRec.hs @@ -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 #-} diff --git a/benchmarks/EqualityBench.hs b/benchmarks/EqualityBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/EqualityBench.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-} +import Control.Monad (join) +import Criterion.Main +import Data.Functor.Identity +import Data.Vinyl +import Data.Vinyl.TypeLevel + +class Eq2 a where + eq2 :: a -> a -> Bool + +instance RecAll f rs Eq => Eq2 (Rec f rs) where + eq2 RNil RNil = True + eq2 (a :& as) (b :& bs) = a == b && eq2 as bs + +main :: IO () +main = defaultMain [ + bench "Eq" $ whnf (join (==)) r1 + , bench "Eq2" $ whnf (join eq2) r1 ] + where r1 = pure 23 :& pure 'b' :& pure 3.14 :& RNil :: Rec Identity '[Int, Char, Double] diff --git a/benchmarks/StorableBench.hs b/benchmarks/StorableBench.hs --- a/benchmarks/StorableBench.hs +++ b/benchmarks/StorableBench.hs @@ -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 }) diff --git a/tests/Aeson.hs b/tests/Aeson.hs new file mode 100644 --- /dev/null +++ b/tests/Aeson.hs @@ -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 diff --git a/tests/CoRecSpec.hs b/tests/CoRecSpec.hs new file mode 100644 --- /dev/null +++ b/tests/CoRecSpec.hs @@ -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)) diff --git a/tests/Intro.lhs b/tests/Intro.lhs deleted file mode 100644 --- a/tests/Intro.lhs +++ /dev/null @@ -1,260 +0,0 @@ -This introduction was originally published at - - -Vinyl: Modern Records for Haskell -================================= - -Vinyl is a general solution to the records problem in Haskell using -type level strings and other modern GHC features, featuring static -structural typing (with a subtyping relation), and automatic -row-polymorphic lenses. All this is possible without Template Haskell. - -First, install Vinyl from Hackage: - -< cabal update -< cabal install vinyl - -Let’s work through a quick example. We’ll need to enable some language -extensions first: - -> {-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} -> {-# LANGUAGE FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction #-} -> {-# LANGUAGE GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-} -> import Data.Vinyl -> import Data.Vinyl.Functor -> import Control.Applicative -> import Control.Lens hiding (Identity) -> import Control.Lens.TH -> import Data.Char -> import Test.DocTest -> import Data.Singletons.TH - -Let’s define a universe of fields which we want to use: - -> data Fields = Name | Age | Sleeping | Master deriving Show -> type LifeForm = [Name, Age, Sleeping] - -> type family ElF (f :: Fields) :: * where -> ElF Name = String -> ElF Age = Int -> ElF Sleeping = Bool -> ElF Master = Rec Attr LifeForm - -> newtype Attr f = Attr { _unAttr :: ElF f } -> makeLenses ''Attr -> instance Show (Attr Name) where show (Attr x) = "name: " ++ show x -> instance Show (Attr Age) where show (Attr x) = "age: " ++ show x -> instance Show (Attr Sleeping) where show (Attr x) = "sleeping: " ++ show x -> instance Show (Attr Master) where show (Attr x) = "master: " ++ show x - -> (=::) :: sing f -> ElF f -> Attr f -> _ =:: x = Attr x - -> genSingletons [ ''Fields ] - -Now, let’s try to make an entity that represents a man: - -> jon = (SName =:: "jon") -> :& (SAge =:: 23) -> :& (SSleeping =:: False) -> :& RNil - -Automatically, we can show the record: - -> -- | -> -- >>> show jon -> -- "{name: \"jon\", age: 23, sleeping: False}" - -And its types are all inferred with no problem. Now, make a dog! Dogs are -life-forms, but unlike men, they have masters. So, let’s build my dog: - -> tucker = (SName =:: "tucker") -> :& (SAge =:: 9) -> :& (SSleeping =:: True) -> :& (SMaster =:: jon) -> :& RNil - -Using Lenses ------------- - -Now, if we want to wake entities up, we don’t want to have to write a -separate wake-up function for both dogs and men (even though they are -of different type). Luckily, we can use the built-in lenses to focus -on a particular field in the record for access and update, without -losing additional information: - - -> wakeUp :: (Sleeping ∈ fields) => Rec Attr fields -> Rec Attr fields -> wakeUp = rput $ SSleeping =:: False - -Now, the type annotation on wakeUp was not necessary; I just wanted to -show how intuitive the type is. Basically, it takes as an input any -record that has a `Bool` field labelled `sleeping`, and modifies that -specific field in the record accordingly. - -> tucker' = wakeUp tucker -> jon' = wakeUp jon - -> -- | -> -- >>> tucker' ^. rlens SSleeping -> -- sleeping: False -> -- -> -- >>> tucker ^. rlens SSleeping -> -- sleeping: True -> -- -> -- >>> jon' ^. rlens SSleeping -> -- sleeping: False - -We can also access the entire lens for a field using the rLens -function; since lenses are composable, it’s super easy to do deep -update on a record: - -> masterSleeping = rlens SMaster . unAttr . rlens SSleeping -> tucker'' = masterSleeping .~ (SSleeping =:: True) $ tucker' - -> -- | >>> tucker'' ^. masterSleeping -> -- sleeping: True - -Subtyping Relation and Coercion -------------------------------- - -A record `Rec f xs` is a subtype of a record `Rec f ys` if `ys ⊆ xs`; -that is to say, if one record can do everything that another record -can, the former is a subtype of the latter. As such, we should be able -to provide an upcast operator which “forgets” whatever makes one -record different from another (whether it be extra data, or different -order). - -Therefore, the following works: - -> upcastedTucker :: Rec Attr LifeForm -> upcastedTucker = rcast tucker - -The subtyping relationship between record types is expressed with the -`(<:)` constraint; so, cast is of the following type: - -< rcast :: r1 <: r2 => Rec f r1 -> Rec f r2 - -Also provided is a `(≅)` constraint which indicates record congruence -(that is, two record types differ only in the order of their fields). - -In fact, `rcast` is actually given as a special case of the lens `rsubset`, -which lets you modify entire (possibly non-contiguous) slices of a record! - -Records are polymorphic over functors -------------------------------------- - -Consider the following declaration: - -< data Rec :: (u -> *) -> [u] -> * where -< RNil :: Rec f '[] -< (:&) :: f r -> Rec f rs -> Rec f (r ': rs) - -Records are implicitly parameterized over a kind `u`, which stands for the -"universe" or key space. Keys (inhabitants of `u`) are then interpreted into -the types of their values by the first parameter to `Rec`, `f`. An extremely -powerful aspect of Vinyl records is that you can construct natural -transformations between different interpretation functors `f,g`, or postcompose -some other functor onto the stack. This can be used to immerse each field of a -record in some particular effect modality, and then the library functions can -be used to traverse and accumulate these effects. - -Let’s imagine that we want to do validation on a record that -represents a name and an age: - -> type Person = [Name, Age] - -We’ve decided that names must be alphabetic, and ages must be positive. For -validation, we’ll use `Maybe` for now, though you should use a -left-accumulating `Validation` type. - -> goodPerson :: Rec Attr Person -> goodPerson = (SName =:: "Jon") -> :& (SAge =:: 20) -> :& RNil - -> badPerson = (SName =:: "J#@#$on") -> :& (SAge =:: 20) -> :& RNil - -We'll give validation a (rather poor) shot. - -> validatePerson :: Rec Attr Person -> Maybe (Rec Attr Person) -> validatePerson p = (\n a -> (SName =:: n) :& (SAge =:: a) :& RNil) <$> vName <*> vAge where -> vName = validateName $ p ^. rlens SName . unAttr -> vAge = validateAge $ p ^. rlens SAge . unAttr -> -> validateName str | all isAlpha str = Just str -> validateName _ = Nothing -> validateAge i | i >= 0 = Just i -> validateAge _ = Nothing - -> -- $setup -> -- >>> let isJust (Just _) = True; isJust _ = False - -> -- | -> -- >>> isJust $ validatePerson goodPerson -> -- True -> -- -> -- >>> isJust $ validatePerson badPerson -> -- False - -The results are as expected (`Just` for `goodPerson`, and a `Nothing` for -`badPerson`); but this was not very fun to build. - -Further, it would be nice to have some notion of a partial record; -that is, if part of it can’t be validated, it would still be nice to -be able to access the rest. What if we could make a version of this -record where the elements themselves were validation functions, and -then that record could be applied to a plain one, to get a record of -validated fields? That’s what we’re going to do. - -> type Validator f = Lift (->) f (Maybe :. f) - -Let’s parameterize a record by it: when we do, then an element of type -`a` should be a function `Identity a -> Result e a`: - -> vperson :: Rec (Validator Attr) Person -> vperson = lift validateName :& lift validateAge :& RNil -> where -> lift f = Lift $ Compose . f -> validateName (Attr str) | all isAlpha str = Just (Attr str) -> validateName _ = Nothing -> validateAge (Attr i) | i >= 0 = Just (Attr i) -> validateAge _ = Nothing - -And we can use the special application operator `<<*>>` (which is -analogous to `<*>`, but generalized a bit) to use this to validate a -record: - -> goodPersonResult = vperson <<*>> goodPerson -> badPersonResult = vperson <<*>> badPerson - -> -- | -> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SName -> -- True -> -- >>> isJust . getCompose $ goodPersonResult ^. rlens SAge -> -- True -> -- >>> isJust . getCompose $ badPersonResult ^. rlens SName -> -- False -> -- >>> isJust . getCompose $ badPersonResult ^. rlens SAge -> -- True - - -So now we have a partial record, and we can still do stuff with its contents. -Next, we can even recover the original behavior of the validator (that is, to -give us a value of type `Maybe (Rec Attr Person)`) using `rtraverse`: - -> mgoodPerson :: Maybe (Rec Attr Person) -> mgoodPerson = rtraverse getCompose goodPersonResult - -> mbadPerson = rtraverse getCompose badPersonResult - -> -- | -> -- >>> isJust mgoodPerson -> -- True -> -- >>> isJust mbadPerson -> -- False - -> main :: IO () -> main = doctest ["tests/Intro.lhs"] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -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 diff --git a/tests/Test/ARec.hs b/tests/Test/ARec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ARec.hs @@ -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 diff --git a/tests/XRecSpec.hs b/tests/XRecSpec.hs new file mode 100644 --- /dev/null +++ b/tests/XRecSpec.hs @@ -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 diff --git a/vinyl.cabal b/vinyl.cabal --- a/vinyl.cabal +++ b/vinyl.cabal @@ -1,19 +1,20 @@ name: vinyl -version: 0.5.1 +version: 0.14.3 synopsis: Extensible Records -- description: license: MIT license-file: LICENSE author: Jonathan Sterling -maintainer: jonsterling@me.com +maintainer: acowley@gmail.com -- copyright: category: Records stability: Experimental build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md +tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1, GHC == 9.2.1 -description: Extensible records for Haskell with lenses using modern GHC features. +description: Extensible records for Haskell with lenses. source-repository head type: git @@ -21,27 +22,108 @@ library exposed-modules: Data.Vinyl + , Data.Vinyl.ARec + , Data.Vinyl.ARec.Internal + , Data.Vinyl.ARec.Internal.SmallArray + , Data.Vinyl.Class.Method , Data.Vinyl.Core + , Data.Vinyl.CoRec + , Data.Vinyl.Curry + , Data.Vinyl.FromTuple , Data.Vinyl.Lens , Data.Vinyl.Derived , Data.Vinyl.TypeLevel , Data.Vinyl.Functor , Data.Vinyl.Notation - build-depends: base >=4.7 && <= 5, ghc-prim + , Data.Vinyl.Recursive + , Data.Vinyl.SRec + , Data.Vinyl.Syntax + , Data.Vinyl.Tutorial.Overview + , Data.Vinyl.XRec + build-depends: base >= 4.11 && <= 5, + ghc-prim, + deepseq, + array + if impl (ghc < 8.6.0) + build-depends: constraints >= 0.6.1 default-language: Haskell2010 - ghc-options: -fwarn-dodgy-exports -fwarn-dodgy-imports -fwarn-unused-matches -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-record-updates -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-orphans -fwarn-overlapping-patterns -fwarn-tabs -fwarn-type-defaults + ghc-options: -Wall + other-extensions: TypeApplications -benchmark bench-builder-all +benchmark storable type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: StorableBench.hs - build-depends: base >= 4.7 && <= 5, vector, criterion, vinyl == 0.5, mwc-random, lens, linear - ghc-options: -O2 -fllvm + build-depends: base, + vector, + criterion, + vinyl, + mwc-random, + microlens, + linear, + primitive + ghc-options: -O2 +-- -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques default-language: Haskell2010 -test-suite doctests +benchmark equality type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: EqualityBench.hs + build-depends: base, criterion, vinyl + ghc-options: -O2 + default-language: Haskell2010 + +benchmark accessors + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: AccessorsBench.hs + build-depends: base, criterion, tagged, vinyl, microlens + other-modules: Bench.ARec + Bench.SRec + Bench.Rec + ghc-options: -O2 + default-language: Haskell2010 + +benchmark asa + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: AsABench.hs + build-depends: base, criterion, vinyl + ghc-options: -O2 + default-language: Haskell2010 + +-- TODO: Use cabal-docspec +-- test-suite doctests +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: tests +-- other-modules: Intro +-- main-is: doctests.hs +-- if impl (ghc < 9.0.1) +-- build-depends: base, lens, doctest >= 0.8, singletons >= 0.10 && < 3, vinyl +-- else +-- build-depends: base, lens, doctest >= 0.8, singletons-th >= 3 && < 3.1, vinyl +-- default-language: Haskell2010 + +test-suite aeson + type: exitcode-stdio-1.0 hs-source-dirs: tests - main-is: Intro.lhs - build-depends: base >= 4.7 && <= 5, lens, vinyl == 0.5, doctest >= 0.8, singletons >= 0.10 + main-is: Aeson.hs + build-depends: base, hspec, aeson >= 1.4, text, mtl, vinyl, + vector, unordered-containers, lens, lens-aeson default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + other-modules: CoRecSpec + XRecSpec + Test.ARec + build-depends: base + , vinyl + , microlens + , hspec + , should-not-typecheck >= 2.0 && < 2.2 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010