Y.lhs

Applicative style record composition with Vinyl.

> {-# LANGUAGE AllowAmbiguousTypes #-}
> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE FlexibleInstances #-}
> {-# LANGUAGE MultiParamTypeClasses #-}
> {-# LANGUAGE RankNTypes #-}
> {-# LANGUAGE ScopedTypeVariables #-}
> {-# LANGUAGE TypeApplications #-}
> {-# LANGUAGE TypeFamilies #-}
> {-# LANGUAGE UndecidableInstances #-}

> module Y where

> import Data.Vinyl hiding (Dict)
> import Data.Vinyl.Functor (Lift(..))
> import GHC.TypeLits (Symbol)

Our records have three fields.

> type Fields = '[ "firstName", "lastName", "age" ]

We start with a simple record whose fields are populated with Strings.
'F' provides a uniform wrapper of fields.

> newtype F x u = F (F_ x u)

> type family F_ x (u :: Symbol)

> data Raw
> type instance F_ Raw    u = String

> stringRecord :: Rec (F Raw) Fields
> stringRecord = F "Bob" :& F "Bill" :& F "55" :& RNil

Now, we want to be able to parse these fields, so we define the type
associated with each field name.

> type family TypeOf_ (a :: Symbol) where
>   TypeOf_ "firstName" = String
>   TypeOf_ "lastName" = String
>   TypeOf_ "age" = Int

This gives us a type of parsers and a type of final, typed fields.

> data Parser
> type instance F_ Parser u = String -> TypeOf_ u

> data TypeOf
> type instance F_ TypeOf u = TypeOf_ u

Here's a record of parsers associated with every field.

> parserRecord :: Rec (F Parser) Fields
> parserRecord = F id :& F id :& F read :& RNil

We define a polymorphic function applying a wrapped parser to a wrapped string.
Currying must be made explicit through the 'Lift' type.

> -- morally     String -> (String -> TypeOf_ x) -> TypeOf_ x
> applyParser :: F Raw x -> Lift (->) (F Parser) (F TypeOf) x
> applyParser (F s) = Lift (\(F f) -> F (f s))

We can now zip records in applicative style, pretty much.

> myRecord :: Rec (F TypeOf) Fields
> myRecord = applyParser <<$>> stringRecord <<*>> parserRecord

The explicit handling of 'Lift' is quite unwieldly.
So let's automate it.

We define a type function mapping types with 'Lift' to types with simple
arrows, and a type class to convert from an unlifted function to a lifted one.

> type family Unlift x u where
>   Unlift (Lift (->) (F x) g) u = F_ x u -> Unlift g u
>   Unlift (F x) u = F_ x u

> class Lifting f where
>   lifting :: Unlift f u -> f u

> instance {-# OVERLAPPABLE #-} Lifting (F u) where
>   lifting = F

> instance Lifting g => Lifting (Lift (->) (F f) g) where
>   lifting p = Lift (\(F f) -> lifting (p f))

Package it up to avoid lifting the first arrow.

> lifty :: forall f x u. Lifting f => (forall u. F_ x u -> Unlift f u) -> F x u -> f u
> lifty f (F a) = (lifting . f @u) a

Here we go.

> myRecord' :: Rec (F TypeOf) Fields
> myRecord' =
>   lifty (\s f -> f s)
>     <<$>> stringRecord
>     <<*>> parserRecord

I didn't manage to torture RebindableSyntax and ApplicativeDo enough to
use do-notation.