A tutorial in record manipulation.

Record.hs

{-# 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)


-------------------------------------------------------------------------------
-- INTRODUCTION / DEMO

-- 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.


-------------------------------------------------------------------------------
-- NOTATION

-- 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


-------------------------------------------------------------------------------
-- RENAME A FIELD

-- 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 product, 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


-------------------------------------------------------------------------------
-- REPREFIX A RECORD

-- 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*.
--
-- * http://hackage.haskell.org/package/symbols
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 product.
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


-------------------------------------------------------------------------------
-- ADDING A FIELD

-- 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!
--
-- * http://hackage.haskell.org/package/generic-lens

add
  :: 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!
--
-- * http://hackage.haskell.org/package/generic-data-surgery

surgically
  :: 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

Yes! Thank you :)