From f7f00c9feff86fc7a34c367c6cf355be56c3b7f7 Mon Sep 17 00:00:00 2001
From: cfhammill <cfhammill@gmail.com>
Date: Fri, 30 Nov 2018 00:19:34 -0500
Subject: [PATCH] Implement record functor / field functor sequencing and
 joining

These help implement unnesting for list records. I'm not completely
happy with the MapTypeDeCon family in that it isn't applicable to
symbol paired fields. I couldn't get the reverse equivalent of
ApplyToField to work with the injectivity annotation.
---
 Data/Vinyl/Core.hs      | 37 +++++++++++++++++++++++++++++++++++++
 Data/Vinyl/TypeLevel.hs |  5 +++++
 2 files changed, 42 insertions(+)

diff --git a/Data/Vinyl/Core.hs b/Data/Vinyl/Core.hs
index 6c0c534..7f32d8a 100644
--- a/Data/Vinyl/Core.hs
+++ b/Data/Vinyl/Core.hs
@@ -209,6 +209,43 @@ rsequenceIn :: forall f g (rs :: [Type]). (Traversable f, Applicative g)
 rsequenceIn = rtraverseIn @f (sequenceA . getCompose)
 {-# INLINABLE rsequenceIn #-}
 
+-- | Sometimes record fields may contain an applicative functor that
+-- is not the same as the intepretation function. If the interpretation
+-- functor is traversable these can be swapped. An example use is extracting
+-- the list functor from each field of the record, replacing it with the
+-- interpretation functor.
+class RSequence (m :: * -> *) (xs :: [*]) where
+  rsequence :: forall f. (Traversable f, Applicative m) =>
+    Rec f xs -> Rec m (MapTyCon f (MapTyDeCon m xs))
+
+instance RSequence m '[] where
+  rsequence RNil = RNil
+
+instance (RSequence m xs) => RSequence m ((m x) ': xs) where
+  rsequence (a :& as) =
+    sequenceA a :& rsequence @m as
+
+-- | If a record has an applicative interpretation functor, that functor
+-- can extracted from the record, and replaced with @Identity@. This acts
+-- in a similar fashion to a special case of @rtraverse@ but an alternative
+-- @pure@ and @liftA2@ can be passed. For example, extracting the list functor
+-- with `repeat` and `zipWith` gives zipped unnesting similar to dplyr in the
+-- R programming language, where @pure@ and @liftA2@ give the usual cartesian
+-- product unnesting.
+class RJoin (m :: * -> *) (xs :: [*]) where
+  rjoin :: (Applicative m) =>
+           (Rec Identity '[] -> m (Rec Identity '[])) ->
+           (forall a b c. (a -> b -> c) -> m a -> m b -> m c) ->
+           Rec m xs ->
+           m (Rec Identity xs)
+
+instance RJoin m '[] where
+  rjoin f _ RNil = f RNil
+
+instance (RJoin m xs) => RJoin m (x ': xs) where
+  rjoin f j (a :& as) = (j (:&)) (fmap Identity a) (rjoin @m f j as)
+
+
 -- | 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
diff --git a/Data/Vinyl/TypeLevel.hs b/Data/Vinyl/TypeLevel.hs
index 710b46e..810d81b 100644
--- a/Data/Vinyl/TypeLevel.hs
+++ b/Data/Vinyl/TypeLevel.hs
@@ -115,3 +115,8 @@ type family ApplyToField (t :: Type -> Type) (a :: k1) = (r :: k1) | r -> t a wh
 type family MapTyCon t xs = r | r -> xs where
   MapTyCon t '[] = '[]
   MapTyCon t (x ': xs) = ApplyToField t x ': MapTyCon t xs
+
+-- | Remove a type constructor from each element of a type level list
+type family MapTyDeCon t xs where
+  MapTyDeCon t '[] = '[]
+  MapTyDeCon t ((t x) ': xs) = x ': MapTyDeCon t xs