Skip to content

Instantly share code, notes, and snippets.

@i-am-tom i-am-tom/Record.hs
Last active Apr 2, 2019

What would you like to do?
A tutorial in record manipulation.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Record where
import Data.Coerce (coerce)
import Data.GenericLens.Internal (GUpcast (..))
import Data.Kind (Type)
import Data.Symbol.Ascii (ToList)
import GHC.Generics
import GHC.TypeLits (AppendSymbol, Symbol)
-- This cheeky little number solves a real-world work problem. Let's say we
-- have two extraordinarily-contrived types:
data Command
= Command
{ cTime :: Int
, cData :: String
deriving Generic
data Event
= Event
{ eTime :: Int
, eData :: String
, eIsNew :: Bool
deriving Generic
-- We want to write a function to get from convert our @Command@ into an
-- @Event@ before we decide whether to persist it. So, we write a function:
convert :: Command -> Event
convert command = Event (cTime command) (cData command) True
-- Ok, fine. Kind of boilerplatey, though, right? This function will get less
-- and less manageable as the complexity of our types grow. However, the drill
-- is usually the same: we need to change the field prefixes, and probably add
-- some standard envelope of metadata. This module provides the machinery to
-- express this:
convert' :: Command -> Event
convert' = surgically (add @"eIsNew" True . reprefix @"c" @"e")
-- We've now concisely and declaratively expressed our intention! Thanks to
-- some generic wizardry, we safely jump from one to the other, without having
-- to write a single record accessor.
-- When we're talking about a field name, we'll use the @Key@ synonym.
-- Otherwise, we'll use @Symbol@.
type Key = Symbol
-- When we're talking about a generic representation, we'll use @TT@ (hat-tip
-- to @iceland_jack). Of course, @Rep@ would be a better choice, but it's
-- unfortunately already in use.
type TT = Type -> Type
-- Determine the new name of a field, given the requested replacement.
type family Rename' (from :: Key) (to :: Key) (key :: Key) :: Key where
Rename' from to from = to
Rename' _ _ item = item
-- This class is used via type application of the @from@ and @to@ keys.
class Rename (from :: Key) (to :: Key) (input :: TT) (output :: TT)
| from to input -> output where
rename :: input p -> output p
-- If we have a sum, we just apply the rename operation to both sides.
instance (Rename from to left left', Rename from to right right')
=> Rename from to (left :*: right) (left' :*: right') where
rename (left :*: right)
= rename @from @to left
:*: rename @from @to right
-- If we have a selector, we calculate the new name, and then coerce (S1 = M1,
-- and M1 is a newtype, thus any @S1 m x@ is coercible to any @S1 n y@.
instance after ~ Rename' from to before
=> Rename from to (S1 ('MetaSel ('Just before) i d c) x)
(S1 ('MetaSel ('Just after) i d c) x) where
rename = coerce
-- Concatenate a list of strings.
type family FromList (xs :: [Symbol]) :: Key where
FromList '[ ] = ""
FromList (x ': xs) = AppendSymbol x (FromList xs)
-- Assuming @ys@ is a prefix of @xs@, calculate the remainder after "removing"
-- this prefix.
type family (xs :: [k]) `Sans` (ys :: [k]) where
xs `Sans` '[ ] = xs
(x ': xs) `Sans` (x ': ys) = xs `Sans` ys
-- To reprefix a field, we convert its key to a list of characters, subtract
-- our old prefix, then add our new prefix! It turns out that converting a
-- symbol to a list of characters is non-trivial, so we must give thanks to
-- @kcsongor's @symbols@ package*.
-- *
type family Reprefix' (from :: Symbol) (to :: Symbol) (key :: Key) :: Key where
Reprefix' from to key
= AppendSymbol to (FromList (ToList key `Sans` ToList from))
-- Just as with 'Rename', type applications are required to set the @from@ and
-- @to@ prefixes, and all fields must have this prefix.
class Reprefix (pre :: Symbol) (post :: Symbol) (input :: TT) (output :: TT)
| pre post input -> output where
reprefix :: input p -> output p
-- As with 'Rename', we apply a 'Reprefix' operation to both branches of a sum.
instance (Reprefix from to left left', Reprefix from to right right')
=> Reprefix from to (left :*: right) (left' :*: right') where
reprefix (left :*: right)
= reprefix @from @to left
:*: reprefix @from @to right
-- We can similarly coerce between 'S1' wrappers once we know what the new key
-- should be.
instance after ~ Reprefix' from to before
=> Reprefix from to (S1 ('MetaSel ('Just before) i d c) x)
(S1 ('MetaSel ('Just after ) i d c) x) where
reprefix = coerce
-- This is actually relatively dull: we just pair our @rep@ with the new
-- field's selector. Why does this work? The magic of the 'GUpcast' class in
-- @Lowert's magnificent @generic-lens@ package* is that, as long as the
-- necessary fields are /present/, we can construct the output type from
-- anything - even our broken tree! This also means that we don't need any
-- special command to "drop" fields - they're just not carried across!
-- *
:: forall key value rep p we don't care
. value
-> rep p
-> (S1 ('MetaSel ('Just key) we don't care) (Rec0 value) :*: rep) p
add = (:*:) . M1 . K1
-- API
-- It's a scary type signature, but we can break it down: we actually don't
-- care about the 'D1' or 'C1' layers of our generic structure: all our
-- operations operate on products of selectors, and we can add and remove the
-- metadata layers outside at the beginning and end of our entire operation to
-- save some effort and unnecessary instances.
-- If we supply a function from the /input/'s selectors to something
-- upcast-able to the /output/'s selectors, 'surgically' will "lift" that to
-- work from out input to our output. Neat!
-- If you're wondering about the name, it's a nod to @lysxia's ingenious
-- @generic-data-surgery@ package*. I would love to say the upcasting was my
-- idea, but kudos goes to @jonathanlking for this one!
-- *
:: forall input output meta meta' before after p
. ( Generic input
, Generic output
, Rep input ~ D1 meta (C1 meta' before)
, GUpcast (D1 meta (C1 meta' after)) (Rep output)
=> (before p -> after p) -> (input -> output)
surgically f
= to -- Rep output p -> output
. gupcast @(D1 meta (C1 meta' _)) -- D1 meta (C1 meta' after) p -> Rep output p
. M1 . M1 -- after p -> D1 meta (C1 meta' after) p
. f -- before p -> after p
. unM1 . unM1 -- D1 meta (C1 meta' before) p -> before p
. from -- input -> D1 meta (C1 meta' before) p

This comment has been minimized.

Copy link

jmackie commented Jan 25, 2019

Very cooI! I think on lines 94 and 140 you meant s/sum/product/?


This comment has been minimized.

Copy link
Owner Author

i-am-tom commented Apr 2, 2019

Yes! Thank you :)

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.