Skip to content

Instantly share code, notes, and snippets.

@Lysxia Lysxia/Y.lhs
Created Apr 22, 2017

Embed
What would you like to do?
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.