{-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.Record
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Bidirectional conversion from/to records
------------------------------------------------------------------------
module Data.Extensible.Record (IsRecord(..), toRecord, fromRecord, record) where

import Data.Extensible.Internal.Rig
import Data.Extensible.Product
import Data.Extensible.Field
import Data.Functor.Identity
import Data.Kind (Type)
import Data.Profunctor
import GHC.Generics
import GHC.TypeLits
import Type.Membership
import Type.Membership.HList

-- | The class of types that can be converted to/from a 'Record'.
class IsRecord a where
  type RecFields a :: [Assoc Symbol Type]
  recordFromList :: HList (Field Identity) (RecFields a) -> a
  recordToList :: a -> HList (Field Identity) (RecFields a)

  type RecFields a = GRecFields (Rep a) '[]
  default recordFromList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)
    => HList (Field Identity) (RecFields a) -> a
  recordFromList HList (Field Identity) (RecFields a)
xs = HList (Field Identity) (GRecFields (Rep a) '[])
-> (Rep a Any -> HList (Field Identity) '[] -> a) -> a
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k) cont.
GIsRecord f r =>
HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields (Rep a) '[])
HList (Field Identity) (RecFields a)
xs (\Rep a Any
x (HList (Field Identity) '[]
HNil :: HList (Field Identity) '[]) -> Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
x)

  default recordToList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)
    => a -> HList (Field Identity) (RecFields a)
  recordToList a
x = Rep a Any
-> HList (Field Identity) '[]
-> HList (Field Identity) (GRecFields (Rep a) '[])
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k).
GIsRecord f r =>
f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
recordToList' (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
x) HList (Field Identity) '[]
forall k (h :: k -> Type). HList h '[]
HNil

instance IsRecord () where
  type RecFields () = '[]
  recordFromList :: HList (Field Identity) (RecFields ()) -> ()
recordFromList HList (Field Identity) (RecFields ())
_ = ()
  recordToList :: () -> HList (Field Identity) (RecFields ())
recordToList ()
_ = HList (Field Identity) (RecFields ())
forall k (h :: k -> Type). HList h '[]
HNil

-- | The class of types that can be converted to/from a 'Record'.
class GIsRecord f r where
  type GRecFields f (r :: [Assoc Symbol Type]) :: [Assoc Symbol Type]
  recordFromList' :: HList (Field Identity) (GRecFields f r) -> (f x -> HList (Field Identity) r -> cont) -> cont
  recordToList' :: f x -> HList (Field Identity) r -> HList (Field Identity) (GRecFields f r)

instance (GIsRecord f (GRecFields g r), GIsRecord g r) => GIsRecord (f :*: g) r where
  type GRecFields (f :*: g) r = GRecFields f (GRecFields g r)
  recordFromList' :: HList (Field Identity) (GRecFields (f :*: g) r)
-> ((:*:) f g x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields (f :*: g) r)
xs (:*:) f g x -> HList (Field Identity) r -> cont
cont = HList (Field Identity) (GRecFields f (GRecFields g r))
-> (f x -> HList (Field Identity) (GRecFields g r) -> cont) -> cont
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k) cont.
GIsRecord f r =>
HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields f (GRecFields g r))
HList (Field Identity) (GRecFields (f :*: g) r)
xs ((f x -> HList (Field Identity) (GRecFields g r) -> cont) -> cont)
-> (f x -> HList (Field Identity) (GRecFields g r) -> cont) -> cont
forall a b. (a -> b) -> a -> b
$ \f x
l HList (Field Identity) (GRecFields g r)
ys -> HList (Field Identity) (GRecFields g r)
-> (g x -> HList (Field Identity) r -> cont) -> cont
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k) cont.
GIsRecord f r =>
HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields g r)
ys ((g x -> HList (Field Identity) r -> cont) -> cont)
-> (g x -> HList (Field Identity) r -> cont) -> cont
forall a b. (a -> b) -> a -> b
$ \g x
r HList (Field Identity) r
zs -> (:*:) f g x -> HList (Field Identity) r -> cont
cont (f x
l f x -> g x -> (:*:) f g x
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> g p -> (:*:) f g p
:*: g x
r) HList (Field Identity) r
zs
  {-# INLINE recordFromList' #-}
  recordToList' :: (:*:) f g x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields (f :*: g) r)
recordToList' (f x
f :*: g x
g) = f x
-> HList (Field Identity) (GRecFields g r)
-> HList (Field Identity) (GRecFields f (GRecFields g r))
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k).
GIsRecord f r =>
f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
recordToList' f x
f (HList (Field Identity) (GRecFields g r)
 -> HList (Field Identity) (GRecFields f (GRecFields g r)))
-> (HList (Field Identity) r
    -> HList (Field Identity) (GRecFields g r))
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f (GRecFields g r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields g r)
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k).
GIsRecord f r =>
f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
recordToList' g x
g
  {-# INLINE recordToList' #-}

instance GIsRecord (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r where
  type GRecFields (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r = (name >: a) ': r
  recordFromList' :: HList
  (Field Identity)
  (GRecFields (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r)
-> (S1 ('MetaSel ('Just name) su ss ds) (K1 i a) x
    -> HList (Field Identity) r -> cont)
-> cont
recordFromList' (HCons (Field (Identity TargetOf x
a)) HList (Field Identity) xs1
xs) S1 ('MetaSel ('Just name) su ss ds) (K1 i a) x
-> HList (Field Identity) r -> cont
cont = S1 ('MetaSel ('Just name) su ss ds) (K1 i a) x
-> HList (Field Identity) r -> cont
cont (K1 i a x -> S1 ('MetaSel ('Just name) su ss ds) (K1 i a) x
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1 a
TargetOf x
a)) HList (Field Identity) r
HList (Field Identity) xs1
xs
  {-# INLINE recordFromList' #-}
  recordToList' :: S1 ('MetaSel ('Just name) su ss ds) (K1 i a) x
-> HList (Field Identity) r
-> HList
     (Field Identity)
     (GRecFields (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r)
recordToList' (M1 (K1 a
a)) = Field Identity (name >: a)
-> HList (Field Identity) r
-> HList (Field Identity) ((name >: a) : r)
forall k (h :: k -> Type) (x :: k) (xs1 :: [k]).
h x -> HList h xs1 -> HList h (x : xs1)
HCons (Identity (TargetOf (name >: a)) -> Field Identity (name >: a)
forall v k (h :: v -> Type) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (a -> Identity a
forall a. a -> Identity a
Identity a
a))
  {-# INLINE recordToList' #-}

instance GIsRecord f r => GIsRecord (C1 i f) r where
  type GRecFields (C1 i f) r = GRecFields f r
  recordFromList' :: HList (Field Identity) (GRecFields (C1 i f) r)
-> (C1 i f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields (C1 i f) r)
xs C1 i f x -> HList (Field Identity) r -> cont
cont = HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k) cont.
GIsRecord f r =>
HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields f r)
HList (Field Identity) (GRecFields (C1 i f) r)
xs ((f x -> HList (Field Identity) r -> cont) -> cont)
-> (f x -> HList (Field Identity) r -> cont) -> cont
forall a b. (a -> b) -> a -> b
$ C1 i f x -> HList (Field Identity) r -> cont
cont (C1 i f x -> HList (Field Identity) r -> cont)
-> (f x -> C1 i f x) -> f x -> HList (Field Identity) r -> cont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> C1 i f x
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1
  {-# INLINE recordFromList' #-}
  recordToList' :: C1 i f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields (C1 i f) r)
recordToList' (M1 f x
f) = f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k).
GIsRecord f r =>
f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
recordToList' f x
f
  {-# INLINE recordToList' #-}

instance GIsRecord f r => GIsRecord (D1 i f) r where
  type GRecFields (D1 i f) r = GRecFields f r
  recordFromList' :: HList (Field Identity) (GRecFields (D1 i f) r)
-> (D1 i f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields (D1 i f) r)
xs D1 i f x -> HList (Field Identity) r -> cont
cont = HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k) cont.
GIsRecord f r =>
HList (Field Identity) (GRecFields f r)
-> (f x -> HList (Field Identity) r -> cont) -> cont
recordFromList' HList (Field Identity) (GRecFields f r)
HList (Field Identity) (GRecFields (D1 i f) r)
xs ((f x -> HList (Field Identity) r -> cont) -> cont)
-> (f x -> HList (Field Identity) r -> cont) -> cont
forall a b. (a -> b) -> a -> b
$ D1 i f x -> HList (Field Identity) r -> cont
cont (D1 i f x -> HList (Field Identity) r -> cont)
-> (f x -> D1 i f x) -> f x -> HList (Field Identity) r -> cont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> D1 i f x
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1
  {-# INLINE recordFromList' #-}
  recordToList' :: D1 i f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields (D1 i f) r)
recordToList' (M1 f x
f) = f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
forall k (f :: k -> Type) (r :: [Assoc Symbol Type]) (x :: k).
GIsRecord f r =>
f x
-> HList (Field Identity) r
-> HList (Field Identity) (GRecFields f r)
recordToList' f x
f
  {-# INLINE recordToList' #-}

-- | Convert a value into a 'Record'.
toRecord :: IsRecord a => a -> Record (RecFields a)
toRecord :: a -> Record (RecFields a)
toRecord = HList (Field Identity) (RecFields a) -> Record (RecFields a)
forall k (h :: k -> Type) (xs :: [k]). HList h xs -> xs :& h
fromHList (HList (Field Identity) (RecFields a) -> Record (RecFields a))
-> (a -> HList (Field Identity) (RecFields a))
-> a
-> Record (RecFields a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HList (Field Identity) (RecFields a)
forall a. IsRecord a => a -> HList (Field Identity) (RecFields a)
recordToList
{-# INLINE toRecord #-}

-- | Convert a 'Record' to a value.
fromRecord :: IsRecord a => Record (RecFields a) -> a
fromRecord :: Record (RecFields a) -> a
fromRecord = HList (Field Identity) (RecFields a) -> a
forall a. IsRecord a => HList (Field Identity) (RecFields a) -> a
recordFromList (HList (Field Identity) (RecFields a) -> a)
-> (Record (RecFields a) -> HList (Field Identity) (RecFields a))
-> Record (RecFields a)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record (RecFields a) -> HList (Field Identity) (RecFields a)
forall k (h :: k -> Type) (xs :: [k]). (xs :& h) -> HList h xs
toHList
{-# INLINE fromRecord #-}

-- | @record :: IsRecord a => Iso' a (Record (RecFields a)) @
record :: (IsRecord a, Functor f, Profunctor p)
  => Optic' p f a (Record (RecFields a))
record :: Optic' p f a (Record (RecFields a))
record = (a -> Record (RecFields a))
-> (f (Record (RecFields a)) -> f a)
-> Optic' p f a (Record (RecFields a))
forall (p :: Type -> Type -> Type) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> Record (RecFields a)
forall a. IsRecord a => a -> Record (RecFields a)
toRecord ((Record (RecFields a) -> a) -> f (Record (RecFields a)) -> f a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Record (RecFields a) -> a
forall a. IsRecord a => Record (RecFields a) -> a
fromRecord)
{-# INLINE record #-}