Declarative record migration.

Record.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Record where

import Data.Kind (Type)
import Data.Symbol.Ascii (type ToList)
import GHC.Generics
import GHC.TypeLits (AppendSymbol, ErrorMessage (..), Symbol, TypeError)
import Prelude hiding (drop)

type Row = [ (Symbol, Type) ]

data RList (xs :: Row) where
  RNil  :: RList '[]
  RCons :: v -> RList xs -> RList ( '(k, v) ': xs )

class Append (this :: Row) (that :: Row) (these :: Row)
    | this that -> these where
  append :: RList this -> RList that -> RList these

instance Append '[] ys ys where
  append _ = id

instance Append xs ys zs => Append (x ': xs) ys (x ': zs) where
  append (RCons x xs) ys = RCons x (append xs ys)

---

type family AppendSymbols (xs :: [Symbol]) :: Symbol where
  AppendSymbols '[] = ""
  AppendSymbols (s ': ss) = AppendSymbol s (AppendSymbols ss)

---

type family (full :: Symbol) `Sans` (prefix :: Symbol) :: Symbol where
  full `Sans` prefix = AppendSymbols (ToList full `Sans'` ToList prefix)

type family (full :: [k]) `Sans'` (prefix :: [k]) :: [k] where
  (x ': xs) `Sans'` (x ': ps) = xs `Sans'` ps
  xs `Sans'` '[] = xs

  _ `Sans'` _ = TypeError ('Text "This prefix isn't in your field name!")

---

class Reprefix (from :: Symbol) (to :: Symbol) (input :: Row) (output :: Row)
    | from to input -> output where
  reprefix :: RList input -> RList output

instance Reprefix from to '[] '[] where
  reprefix = id

instance
    ( pre `Sans` from ~ field
    , AppendSymbol to field ~ post
    , Reprefix from to before after
    )
    => Reprefix from to ( '(pre,  value) ': before )
                        ( '(post, value) ': after  ) where
  reprefix (RCons x xs) = RCons x (reprefix @from @to xs)

---

type family (xs :: [(Symbol, v)]) `HasNo` (x :: Symbol) :: Bool where
  ( '(k, v) ': xs) `HasNo` k = 'False
  ( '(j, v) ': xs) `HasNo` k = xs `HasNo` k

  '[] `HasNo` k = 'True

---

class Elem (k :: Symbol) (xs :: Row) (v :: Type) | xs k -> v where
  get :: RList xs -> v

instance Elem k ( '(k, v) ': xs ) v where
  get (RCons x _) = x

instance {-# OVERLAPPABLE #-} Elem k xs v
    => Elem k ( '(j, w) ': xs ) v where
  get (RCons _ xs) = get @k xs

---

class Add (key :: Symbol) (value :: Type) (input :: Row) (output :: Row)
    | key value input -> output, key output -> input where
  add :: value -> RList input -> RList output

instance input `HasNo` key ~ True
    => Add key value input ( '(key, value) ': input ) where
  add value = RCons value

---

class Rename (from :: Symbol) (to :: Symbol) (input :: Row) (output :: Row)
    | from to input -> output, from to output -> input where
  rename :: RList input -> RList output

instance xs `HasNo` to ~ True
    => Rename from to ( '(from, value) ': xs )
                      ( '(to,   value) ': xs ) where
  rename (RCons x xs) = RCons x xs

instance {-# INCOHERENT #-} Rename from to xs ys
    => Rename from to ( '(huh, value) ': xs) ( '(huh, value) ': ys) where
  rename (RCons x xs) = RCons x (rename @from @to xs)

---

class GScrubIn (s :: Type -> Type) (a :: Row) | s -> a where
  gscrubIn :: s p -> RList a

instance GScrubIn s a => GScrubIn (D1 meta s) a where
  gscrubIn = gscrubIn . unM1

instance GScrubIn s a => GScrubIn (C1 meta s) a where
  gscrubIn = gscrubIn . unM1

instance (GScrubIn left this, GScrubIn right that, Append this that these)
    => GScrubIn (left :*: right) these where
  gscrubIn (left :*: right) = append (gscrubIn left) (gscrubIn right)

instance GScrubIn (S1 ('MetaSel ('Just k) i d c) (Rec0 v)) '[ '(k, v) ] where
  gscrubIn (M1 (K1 v)) = RCons v RNil

class ScrubIn (s :: Type) (a :: Row) | s -> a where
  scrubIn :: s -> RList a

instance (Generic s, GScrubIn (Rep s) a) => ScrubIn s a where
  scrubIn = gscrubIn . from

---

class GScrubOut (s :: Type -> Type) (a :: Row) where
  gscrubOut :: RList a -> s p

instance GScrubOut s a => GScrubOut (D1 meta s) a where
  gscrubOut = M1 . gscrubOut

instance GScrubOut s a => GScrubOut (C1 meta s) a where
  gscrubOut = M1 . gscrubOut

instance (GScrubOut left a, GScrubOut right a)
    => GScrubOut (left :*: right) a where
  gscrubOut xs = gscrubOut xs :*: gscrubOut xs

instance Elem k xs v
    => GScrubOut (S1 ('MetaSel ('Just k) i d c) (Rec0 v)) xs where
  gscrubOut = M1 . K1 . get @k

class ScrubOut (s :: Type) (a :: Row) where
  scrubOut :: RList a -> s

instance (Generic s, GScrubOut (Rep s) a) => ScrubOut s a where
  scrubOut = to . gscrubOut

---

surgically :: (ScrubIn s a, ScrubOut t b) => (RList a -> RList b) -> (s -> t)
surgically f = scrubOut . f . scrubIn

data Foo = Foo { fA :: Int, fB :: String, fC :: Bool } deriving Generic
data Bar = Bar { bA :: Int, bB :: String } deriving Generic

f :: Bar -> Foo
f = surgically $ add @"fC" True . reprefix @"b" @"f"