Unpacking applicative records

unpack.hs

import Data.Vinyl.TypeLevel
import Data.Vinyl
import Data.Vinyl.Functor
import Control.Applicative (liftA2)

type family MapTyCon m xs where
  MapTyCon m '[] = '[]
  MapTyCon m (x ': xs) = m x ': MapTyCon m xs

type family MapTyDeCon (m :: * -> *) (xs :: [*]) where
  MapTyDeCon m '[] = '[]
  MapTyDeCon m ((m x) ': xs) = x ': MapTyDeCon m xs

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

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)

unpack :: (ys ~ MapTyCon Identity (MapTyDeCon [] xs)
         , RSequence [] xs)  =>
  Rec Identity xs -> Rec [] ys
unpack r = rsequence r

zipped :: (RJoin [] ys) => Rec [] ys -> [Rec Identity ys]
zipped r = rjoin repeat zipWith r

crossed :: (RJoin [] ys) => Rec [] ys -> [Rec Identity ys]
crossed r = rjoin pure liftA2 r

tr :: Rec Identity '[[Int], [Double], [String]]
tr = Identity [1,2,3] :& Identity [4,5] :& Identity ["hey", "yeah", "you"] :& RNil

main :: IO ()
main = do
  putStrLn "Cartesian product version"
  (print . crossed . unpack) tr
  putStrLn "Zipped version"
  (print . zipped . unpack) tr