{-# 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 ConstraintKinds #-}

module RecordOperations (Mapped(..),
                         MapRecord,
                         MapField(..),
                         mapRecord,
                         RecordSubSet,
                         recordSubSet) where
import GHC.Records
import GHC.Generics

class MapField a where
  -- | The type mapping for the type of a record field.
  type Mapped a :: *
  -- | The mapping operation on the record field.
  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 :: (forall c. c -> f c)
-> a -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 d) ()
genMapRecord forall c. c -> f c
f a
a = K1 R d () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 d) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R d () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 d) ())
-> K1 R d () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 d) ()
forall a b. (a -> b) -> a -> b
$ d -> K1 R d ()
forall k i c (p :: k). c -> K1 i c p
K1 (d -> K1 R d ()) -> d -> K1 R d ()
forall a b. (a -> b) -> a -> b
$ f b -> Mapped (f b)
forall a. MapField a => a -> Mapped a
mapField (f b -> Mapped (f b)) -> f b -> Mapped (f b)
forall a b. (a -> b) -> a -> b
$ b -> f b
forall c. c -> f c
f ((a -> b
forall k (x :: k) r a. HasField x r a => r -> a
getField @label) a
a :: b)

instance ( GenMapRecord f a (b ())
         , GenMapRecord f a (c ())) =>
         GenMapRecord f a ((b :*: c) ())
  where
  genMapRecord :: (forall c. c -> f c) -> a -> (:*:) b c ()
genMapRecord forall c. c -> f c
f a
a = (forall c. c -> f c) -> a -> b ()
forall (f :: * -> *) a b.
GenMapRecord f a b =>
(forall c. c -> f c) -> a -> b
genMapRecord forall c. c -> f c
f a
a b () -> c () -> (:*:) b c ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (forall c. c -> f c) -> a -> c ()
forall (f :: * -> *) a b.
GenMapRecord f a b =>
(forall c. c -> f c) -> a -> b
genMapRecord forall c. c -> f c
f a
a

instance ( GenMapRecord f a (b ())) =>
         GenMapRecord f a (D1 meta (C1 meta2 b) ())
  where
  genMapRecord :: (forall c. c -> f c) -> a -> D1 meta (C1 meta2 b) ()
genMapRecord forall c. c -> f c
f a
a = M1 C meta2 b () -> D1 meta (C1 meta2 b) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 C meta2 b () -> D1 meta (C1 meta2 b) ())
-> M1 C meta2 b () -> D1 meta (C1 meta2 b) ()
forall a b. (a -> b) -> a -> b
$ b () -> M1 C meta2 b ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (b () -> M1 C meta2 b ()) -> b () -> M1 C meta2 b ()
forall a b. (a -> b) -> a -> b
$ (forall c. c -> f c) -> a -> b ()
forall (f :: * -> *) a b.
GenMapRecord f a b =>
(forall c. c -> f c) -> a -> b
genMapRecord forall c. c -> f c
f a
a

-- | the constraint @`MapRecord` f a b@ determines that @a@ can be
-- converted into @b@, using the newtype @f@.
type MapRecord f a b = GenMapRecord f a (Rep b ())

-- | map a polymorphic function over a record.  The function should be
-- implemented as a newtype which is an instance of the `MapField`
-- class, with corresponding type family `Mapped`.  Pass the newtype
-- constructor to the mapRecord function.  For example to "functorize" all fields:
--
-- @
-- data Foo = Foo
--   { foo :: Int
--   , bar :: String
--   } deriving (Show, Generic)
--
-- data FunctorFoo f = FunctorFoo
--   { foo :: f Int
--   , bar :: f String
--   } deriving (Generic)
--
-- newtype ToFunctor (f :: * -> *) a = ToFunctor a
--
-- instance Applicative f => MapField (ToFunctor f a) where
--   type Mapped (ToFunctor f a) = f a
--   mapField (ToFunctor x) = pure x
--
-- functorize :: Applicative f => Foo -> FunctorFoo f
-- functorize = mapRecord ToFunctor
-- @

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

class GenRecordSubSet a b where
  genRecordSubSet :: a -> b

instance (HasField label a b) =>
         GenRecordSubSet a
         (S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 b) ())
  where
  genRecordSubSet :: a -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 b) ()
genRecordSubSet a
a = K1 R b () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 b) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R b () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 b) ())
-> K1 R b () -> S1 ('MetaSel ('Just label) _x _x2 _x3) (Rec0 b) ()
forall a b. (a -> b) -> a -> b
$ b -> K1 R b ()
forall k i c (p :: k). c -> K1 i c p
K1 ((a -> b
forall k (x :: k) r a. HasField x r a => r -> a
getField @label) a
a :: b)

instance ( GenRecordSubSet a (b ())
         , GenRecordSubSet a (c ())) =>
         GenRecordSubSet a ((b :*: c) ())
  where
  genRecordSubSet :: a -> (:*:) b c ()
genRecordSubSet a
a = a -> b ()
forall a b. GenRecordSubSet a b => a -> b
genRecordSubSet a
a b () -> c () -> (:*:) b c ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: a -> c ()
forall a b. GenRecordSubSet a b => a -> b
genRecordSubSet a
a

instance (GenRecordSubSet a (b ())) =>
         GenRecordSubSet a (D1 meta (C1 meta2 b) ())
  where
  genRecordSubSet :: a -> D1 meta (C1 meta2 b) ()
genRecordSubSet a
a = M1 C meta2 b () -> D1 meta (C1 meta2 b) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 C meta2 b () -> D1 meta (C1 meta2 b) ())
-> M1 C meta2 b () -> D1 meta (C1 meta2 b) ()
forall a b. (a -> b) -> a -> b
$ b () -> M1 C meta2 b ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (b () -> M1 C meta2 b ()) -> b () -> M1 C meta2 b ()
forall a b. (a -> b) -> a -> b
$ a -> b ()
forall a b. GenRecordSubSet a b => a -> b
genRecordSubSet a
a

-- | The constraint @`RecordSubSet` a b@ determines that the fields of
-- `b` are a subset of the fields of `a`.
type RecordSubSet a b = GenRecordSubSet a (Rep b ())

-- | get subset of a record.  For example:
--
-- @  
-- data Foo = Foo
--   { foo :: Int
--   , bar :: String
--   } deriving (Show, Generic)
--
-- data Bar = Bar
--   { bar :: String
--   } deriving (Show, Generic)
--
-- subFoo :: Foo -> Bar
-- subFoo = recordSubSet
-- @

recordSubSet :: forall b a.(Generic b, RecordSubSet a b)
             => a -> b
recordSubSet :: a -> b
recordSubSet a
x = Rep b () -> b
forall a x. Generic a => Rep a x -> a
to (a -> Rep b ()
forall a b. GenRecordSubSet a b => a -> b
genRecordSubSet a
x :: Rep b ())