Does rapply and rmap work with ElField?

[michaelmesser]

I had tried it and could not get it to work.

[acowley]

Can you give an example of what you'd like to do that isn't working?

[michaelmesser]

import Data.Vinyl
import Data.Vinyl.Derived

d1 = Field @"X" "5"
  :& Field @"Y" "Hi"
  :& RNil

d2 = Field @"X" (read :: String -> Int)
  :& Field @"Y" (id :: String -> String)
  :& RNil

d3 = d2 <<*>> d1

d4 :: FieldRec '[ '("X", String) , '("Y", String) ]
d4 = d1 <<&>> \(Field x) -> Field $ x ++ "Hi"

[michaelmesser]

d1 and d2 work but d3 and d4 error. Is that supposed to work? I was hoping it would but I understand that it would but hard to implement.

[acowley]

This was very challenging, and I'm not sure I broke it down as far as it can go, but I'm out of time.

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'

I spent way too much time trying to improve the d2' I have there, but the problem is that the functor must interpret the index into a value type. That is, for Rec f '[u], f has kind u -> *, which precludes use of a naked (->) a. We need to wrap the function type constructor with something else that deals with our '(Symbol,*) indices, and the ElField type constructor does just that.

[michaelmesser]

This is how I ended up using vinyl.

type Person
    = "firstname" =: String
    $ "lastname"  =: String
    $ "age"       =: Int
    $ GNone

person :: MyRec Person _
person
     = p @"firstname" "Bob"
    :& p @"lastname"  "Bill"
    :& p @"age"       35
    :& RNil

type IOPerson = FMap IO Person

ioperson :: MyRec IOPerson _
ioperson
    =  p @"firstname" (return "Bob")
    :& p @"lastname"  (return "Bill")
    :& p @"age"       (return 35)
    :& RNil

type StringPerson = FConst String

stringPerson :: MyRec (FConst String) _
     = p @"firstname" "Bob"
    :& p @"lastname"  "Bill"
    :& p @"age"       "35"
    :& RNil

type PersonParser = FApply (->) (FConst String) (Person)

personParser :: MyRec PersonParser _
personParser
     = p @"firstname" id
    :& p @"lastname"  id
    :& p @"age"       read
    :& RNil

-- parsedPerson :: MyRec Person '["firstname", "lastname", "age"]
parsedPerson = rapply2 personParser stringPerson

-- age :: Int
age = parsedPerson^.rlens2 @"age"

Code to make the above work. I think this could be made polykinded so that it worked with any type and not just symbol.

{-# LANGUAGE PolyKinds, AllowAmbiguousTypes #-}
module VinylHelper where
import Data.Vinyl
import Data.Vinyl.Functor
import Control.Lens hiding (Identity, Const, getConst, rmap)
import Data.Singletons.TH
import Data.Kind
import Data.Vinyl.TypeLevel
import GHC.TypeLits

type family MyFun (a :: k1) :: k2

p :: (f ~ g) => MyFun (a f) -> MyAttr a f
p = MyAttr

newtype MyAttr a (b :: Symbol) = MyAttr { _unMyAttr :: MyFun (a b) }
makeLenses ''MyAttr

(=::) :: sing f -> MyFun (a f) -> MyAttr a f
_ =:: x = MyAttr x

data FConst (a :: *) (b :: Symbol)
data FApply (a :: * -> * -> *) (b :: e -> *) (c :: e -> *) (d :: Symbol)
data FMap (a :: * -> *) (b :: e -> *) (d :: Symbol)
type MyRec a b = Rec (MyAttr a) b

rapply2
    :: MyRec (FApply (->) f g) rs
    -> MyRec f rs
    -> MyRec g rs

rapply2 RNil RNil = RNil
rapply2 (MyAttr f :& fs) (MyAttr x :& xs) = MyAttr (f x) :& (fs `rapply2` xs)

rlens2 :: forall r rs g a. (RElem r rs (RIndex r rs), Functor g) => (MyFun (a r) -> g (MyFun (a r))) -> Rec (MyAttr a) rs -> g (Rec (MyAttr a) rs)
rlens2 = rlens (Proxy @r) . unMyAttr

type instance MyFun (FConst a b) = a
type instance MyFun (FApply b c d a) = b (MyFun (c a)) (MyFun (d a))
type instance MyFun (FMap b c a) = b (MyFun (c a))

data GY (a :: k1) (b :: k2) (c :: k1 -> k3) (d :: k1)
data GNone (a :: k1)

type family GYTF a where
    GYTF (GY a b _ a) = b
    GYTF (GY _ _ c d) = MyFun (c d)

type instance MyFun (GY a b c d) = GYTF (GY a b c d)

type family GNoneTF (a :: k1) :: k2 where

type instance MyFun (GNone a) = GNoneTF a 

type (a :: k1) =: (b :: k2) = a `GY` b
type (a :: j1 -> j2) $ (b :: j1) = a b

infixr 0 $
infixr 9 =:

rzipWith
    :: (forall f. MyAttr a f -> MyAttr b f -> MyAttr c f)
    -> MyRec a rs
    -> MyRec b rs
    -> MyRec c rs

rzipWith _ RNil RNil = RNil
rzipWith f (x :& xs) (y :& ys) = f x y :& rzipWith f xs ys

rzipWithC
    :: (a -> b -> c)
    -> MyRec (FConst a) rs
    -> MyRec (FConst b) rs
    -> MyRec (FConst c) rs
rzipWithC f = rzipWith (\(MyAttr a) (MyAttr b) -> MyAttr $ f a b)

rmapC
    :: (a -> b)
    -> MyRec (FConst a) rs
    -> MyRec (FConst b) rs

rmapC f = rmap (\(MyAttr a) -> MyAttr $ f a)