recordoperations

recordoperations.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}

module RecordOperations where
import GHC.Records
import Data.Functor.Identity
import GHC.Generics

class MapField a where
  type Mapped a :: *
  mapField :: a -> Mapped a
  
class GenMapRecord f a b where
  genMapRecord :: (forall c.c -> f c) -> a -> b

instance ( MapField (f b)
         , HasField label a b
         , d ~ Mapped (f b)) =>
         GenMapRecord f a
         (S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 d) ())
  where
  genMapRecord f a = M1 $ K1 $ mapField $ f ((getField @label) a :: b)

instance ( GenMapRecord f a (b ())
         , GenMapRecord f a (c ())) =>
         GenMapRecord f a ((b :*: c) ())
  where
  genMapRecord f a = genMapRecord f a :*: genMapRecord f a

instance ( GenMapRecord f a (b ())) =>
         GenMapRecord f a (D1 meta (C1 meta2 b) ())
  where
  genMapRecord f a = M1 $ M1 $ genMapRecord f a

mapRecord :: forall b f a.(Generic b, GenMapRecord f a (Rep b ()))
          => (forall c.c -> f c) -> a -> b
mapRecord f x = to $ (genMapRecord f x :: Rep b ())

data Foo = Foo
  { foo :: Int
  , bar :: String
  } deriving (Show, Generic)

data IdFoo = IdFoo
  { foo :: Identity Int
  , bar :: Identity String
  } deriving (Show, Generic)

newtype ToIdentity a = ToIdentity a

instance MapField (ToIdentity a) where
  type Mapped (ToIdentity a) = Identity a
  mapField (ToIdentity x) = Identity x

convert :: Foo -> IdFoo
convert = mapRecord ToIdentity