i-am-tom · January 14, 2019 22:14 · Jan 14, 2019 · Jan 14, 2019
diff --git a/Record.hs b/Record.hs
@@ -0,0 +1,176 @@
+{-# 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"