{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}

{-|
Module      : Data.HKD.Records
Description : Make higher kinded records great again
Copyright   : (c) Kristof Bastiaensen, 2022
License     : BSD-3
Maintainer  : kristof@resonata.be
Stability   : stable
Portability : ghc

This module contains additions for the hkd package to making it easier
for working with higher kinded records.  In particular, it gives
access to the fieldNames of a records using the `fieldNames` function,
allows you to zip many records together using `fzipManyWith`, and
allows functions with constraints by using the `fdicts` function.
This makes it possible to implement many generic functions using these
functions rather than having to implement complicated typeclasses for
Generics.  As an example, here is a (poor mans) url encoding function:

@
zipShow :: (FFoldable t, FRepeat t, FieldNames t, FDicts Show t, FZip t) =>
            t Identity -> Text
zipShow t =
   Text.concat $
   intersperse "&" $
   ftoList $ 
   fzipManyWith
   (\(Identity y :> Const lbl :> Dict :> End) ->
       Const $ lbl <> "=" <> Text.pack (show y))
   (t :~> fieldNames :~> fdicts @Show :~> End)
@

-}

module Data.HKD.Records (
  FieldNames(..),
  Dict(..), FDicts(..),
  RecordCons(..), FieldCons(..), End(..),
  fzipManyWith, ftoList, Lens', FLens(..),
  FLenses(..)) where
import Data.HKD
import Data.Text (Text)
import Data.Functor.Const
import GHC.Generics
import GHC.TypeLits
import Data.Coerce
import qualified Data.Text as Text
import Data.Proxy
import Data.Monoid

class FieldNames t where
  -- | get the fieldNames from each field as a (Const Text).  Can be
  -- auto derived for records with a Generic instance.
  default fieldNames :: (Generic (t (Const Text)),
                       GFieldNames (Rep (t (Const Text)) ()))
                  => t (Const Text)
  fieldNames = forall a x. Generic a => Rep a x -> a
to (forall t. GFieldNames t => t
genFieldNames :: Rep (t (Const Text)) ())                  
  fieldNames :: t (Const Text)

class GFieldNames t where
  genFieldNames :: t
  
instance (GFieldNames (f ()), GFieldNames (g ())) => GFieldNames ((f :*: g) ()) where
  genFieldNames :: (:*:) f g ()
genFieldNames = forall t. GFieldNames t => t
genFieldNames forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall t. GFieldNames t => t
genFieldNames
  {-# INLINE genFieldNames #-}

instance KnownSymbol fieldName =>
         (GFieldNames (S1 ('MetaSel ('Just fieldName) _x _x2 _x3)
                    (Rec0 (Const Text b))
                    ())) where
  genFieldNames :: S1 ('MetaSel ('Just fieldName) _x _x2 _x3) (Rec0 (Const Text b)) ()
genFieldNames = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @fieldName))
  {-# INLINE genFieldNames #-}
  
instance GFieldNames (b ()) => (GFieldNames ((D1 meta (C1 meta2 b)) ())) where
  genFieldNames :: D1 meta (C1 meta2 b) ()
genFieldNames = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall t. GFieldNames t => t
genFieldNames
  {-# INLINE genFieldNames #-}

data Dict c (t :: k) where
  -- | reified type class dictionary. You can use the contained
  -- typeclass by putting the `Dict` constructor somewhere within
  -- scope. Can be auto derived with a Generic instance.
  Dict :: c t => Dict c t

class FDicts c t where
  -- | hkd record containing the reified type class dictionaries for
  -- each field.  This allows you to use functions with constraints by
  -- combining `fdicts` with `fzipWith` or `fzipManyWith`.  Can be
  -- auto derived with a Generic instance.
  default fdicts :: (Generic (t (Dict c)),
                     GFDicts (Rep (t (Dict c)) ()))
                 => t (Dict c)
  fdicts = forall a x. Generic a => Rep a x -> a
to (forall t. GFDicts t => t
genFdict :: Rep (t (Dict c)) ())
  fdicts :: t (Dict c)

class GFDicts t where
  genFdict :: t

instance (GFDicts (f ()), GFDicts (g ())) => GFDicts ((f :*: g) ()) where
  genFdict :: (:*:) f g ()
genFdict = forall t. GFDicts t => t
genFdict forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall t. GFDicts t => t
genFdict
  {-# INLINE genFdict #-}

instance c b =>
         GFDicts (S1 ('MetaSel _x1 _x2 _x3 _x4)
                   (Rec0 (Dict c b))
                   ()) where
  genFdict :: S1 ('MetaSel _x1 _x2 _x3 _x4) (Rec0 (Dict c b)) ()
genFdict = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k -> Constraint) (t :: k). c t => Dict c t
Dict
  {-# INLINE genFdict #-}

instance GFDicts (b ()) => (GFDicts ((D1 meta (C1 meta2 b)) ())) where
  genFdict :: D1 meta (C1 meta2 b) ()
genFdict = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall t. GFDicts t => t
genFdict
  {-# INLINE genFdict #-}

infixr 5 :>
infixr 5 :~>

-- | A heterogenous list of higher kinded records.  Use `:~>` to
-- separate the items, and `End` to terminate them.
data RecordCons (f :: a -> *) g t = t f :~> g t
-- | A heterogenous list of fields.  Use `:>` to separate the items,
-- and `End` to terminate them.
data FieldCons f g (x :: a) = f x :> g x
-- | The terminator.
data End (t :: k) = End

class GFTranspose x t (f :: a -> *) | x -> f where
  gftranspose :: x t -> t f

instance FRepeat t => GFTranspose End t End where
  gftranspose :: End t -> t End
gftranspose End t
End = forall {k} (t :: (k -> *) -> *) (f :: k -> *).
FRepeat t =>
(forall (x :: k). f x) -> t f
frepeat forall k (t :: k). End t
End

instance (FZip t, GFTranspose g t g') => 
  GFTranspose (RecordCons f g) t (FieldCons f g') where
  gftranspose :: RecordCons f g t -> t (FieldCons f g')
gftranspose (t f
tf :~> g t
tg) = forall {k} (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *).
FZip t =>
(forall (x :: k). f x -> g x -> h x) -> t f -> t g -> t h
fzipWith forall a (f :: a -> *) (g :: a -> *) (x :: a).
f x -> g x -> FieldCons f g x
(:>) t f
tf forall a b. (a -> b) -> a -> b
$ forall a (x :: ((a -> *) -> *) -> *) (t :: (a -> *) -> *)
       (f :: a -> *).
GFTranspose x t f =>
x t -> t f
gftranspose g t
tg

-- | zip over many arguments.  The function must take a heterogenous
-- list of fields, separated using `:>` and terminated by `End`,
-- while the argument must be a heterogenous list of records,
-- separated by `:~>`, end terminated by `End`.
--
-- For example:
--
-- @
--   fzipManyWith
--   (\(Identity y :> Const lbl :> Dict :> End) ->
--       Const $ lbl <> "=" <> Text.pack (show y))
--   (t :~> fieldNames :~> fdicts @Show :~> End)
-- @

fzipManyWith :: ( FFunctor t, GFTranspose x t f) =>
                 (forall a. f a -> i a) ->
                 (x t -> t i)
fzipManyWith :: forall {a} (t :: (a -> *) -> *) (x :: ((a -> *) -> *) -> *)
       (f :: a -> *) (i :: a -> *).
(FFunctor t, GFTranspose x t f) =>
(forall (a :: a). f a -> i a) -> x t -> t i
fzipManyWith forall (a :: a). f a -> i a
f x t
tuple = forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap forall (a :: a). f a -> i a
f forall a b. (a -> b) -> a -> b
$ forall a (x :: ((a -> *) -> *) -> *) (t :: (a -> *) -> *)
       (f :: a -> *).
GFTranspose x t f =>
x t -> t f
gftranspose x t
tuple

type Lens' a s = forall f . Functor f => (a -> f a) -> s -> f s

-- | A lens for targetting a field of a higher kinded structure.  This
-- must be a newtype in order to be partially applied.
newtype FLens g s a = FLens (Lens' (g a) (s g))

iso :: (a -> s) -> (s -> a) -> Lens' a s
iso :: forall a s. (a -> s) -> (s -> a) -> Lens' a s
iso a -> s
wrap s -> a
unwrap a -> f a
f s
g =  a -> s
wrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f (s -> a
unwrap s
g)
{-# INLINE iso #-}

compFLens :: Lens' (s g) (t g) -> FLens g s a -> FLens g t a
compFLens :: forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
Lens' (s g) (t g) -> FLens g s a -> FLens g t a
compFLens Lens' (s g) (t g)
l (FLens Lens' (g a) (s g)
m) = forall {k} (g :: k -> *) (s :: (k -> *) -> *) (a :: k).
Lens' (g a) (s g) -> FLens g s a
FLens (Lens' (s g) (t g)
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' (g a) (s g)
m)
{-# INLINE compFLens #-}

compIsoFLens :: (s g -> t g) -> (t g -> s g) -> FLens g s a -> FLens g t a
compIsoFLens :: forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
(s g -> t g) -> (t g -> s g) -> FLens g s a -> FLens g t a
compIsoFLens s g -> t g
wrap t g -> s g
unwrap = forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
Lens' (s g) (t g) -> FLens g s a -> FLens g t a
compFLens (forall a s. (a -> s) -> (s -> a) -> Lens' a s
iso s g -> t g
wrap t g -> s g
unwrap)
{-# INLINE compIsoFLens #-}

class FLenses (t :: (k -> *) -> *) where
  -- A record of lenses into the record.  Can be auto derived with a
  -- Generic instance.
  default flenses :: forall r g . GFlensesMachinery k t r g
                  => t (FLens g t)
  flenses = forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap (forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
(s g -> t g) -> (t g -> s g) -> FLens g s a -> FLens g t a
compIsoFLens forall {k} (t :: k -> *) (g :: k) (r :: k -> * -> *).
(Generic (t g), Coercible (r g ()) (Rep (t g) ())) =>
Tupled r g -> t g
toHkd forall {k} (t :: k -> *) (g :: k) (r :: k -> * -> *).
(Generic (t g), Coercible (r g ()) (Rep (t g) ())) =>
t g -> Tupled r g
fromHkd) forall a b. (a -> b) -> a -> b
$
            forall {k} (t :: k -> *) (g :: k) (r :: k -> * -> *).
(Generic (t g), Coercible (r g ()) (Rep (t g) ())) =>
Tupled r g -> t g
toHkd (forall (x :: * -> *) k (r :: (k -> *) -> * -> *) (g :: k -> *).
GFLenses x k r g =>
Tupled r (FLens g (Tupled r))
genflenses @(Rep (t g)) @k @r)
  {-# INLINE flenses #-}
  flenses :: t (FLens g t)

-- newtype to get rid of the extra type variable
newtype Tupled f (a :: k) = Tupled {forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled :: f a ()}

-- these newtypes just rearrange the type variables so they 
newtype FunctorS1 fieldName _x _x2 _x3 a g k =
  FunctorS1 { forall {k} {k} (fieldName :: Maybe Symbol)
       (_x :: SourceUnpackedness) (_x2 :: SourceStrictness)
       (_x3 :: DecidedStrictness) (a :: k) (g :: k -> *) (k :: k).
FunctorS1 fieldName _x _x2 _x3 a g k
-> S1 ('MetaSel fieldName _x _x2 _x3) (Rec0 (g a)) k
getFunctorS1 :: (S1 ('MetaSel fieldName _x _x2 _x3)
                               (Rec0 (g a))
                               k)}

newtype FunctorD1 meta meta2 f l k =
  FunctorD1 { forall {k} {k} (meta :: Meta) (meta2 :: Meta) (f :: k -> k -> *)
       (l :: k) (k :: k).
FunctorD1 meta meta2 f l k -> D1 meta (C1 meta2 (f l)) k
getFunctorD1 ::D1 meta (C1 meta2 (f l)) k }

newtype FunctorProd f g a k = FunctorProd ((f a :*: g a) k)

instance FFunctor (Tupled (FunctorS1 fieldName _x _x2 _x3 a)) where
  ffmap :: forall (f :: k -> *) (g :: k -> *).
(f ~> g)
-> Tupled (FunctorS1 fieldName _x _x2 _x3 a) f
-> Tupled (FunctorS1 fieldName _x _x2 _x3 a) g
ffmap f ~> g
f (Tupled (FunctorS1 (M1 (K1 f a
x))))
    = forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (fieldName :: Maybe Symbol)
       (_x :: SourceUnpackedness) (_x2 :: SourceStrictness)
       (_x3 :: DecidedStrictness) (a :: k) (g :: k -> *) (k :: k).
S1 ('MetaSel fieldName _x _x2 _x3) (Rec0 (g a)) k
-> FunctorS1 fieldName _x _x2 _x3 a g k
FunctorS1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ f ~> g
f f a
x
  {-# INLINE ffmap #-}

instance FFunctor (Tupled f)
         => FFunctor (Tupled (FunctorD1 meta meta2 f)) where
  ffmap :: forall (f :: k -> *) (g :: k -> *).
(f ~> g)
-> Tupled (FunctorD1 meta meta2 f) f
-> Tupled (FunctorD1 meta meta2 f) g
ffmap f ~> g
f (Tupled (FunctorD1 (M1 (M1 f f ()
x)))) =
    forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (meta :: Meta) (meta2 :: Meta) (f :: k -> k -> *)
       (l :: k) (k :: k).
D1 meta (C1 meta2 (f l)) k -> FunctorD1 meta meta2 f l k
FunctorD1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled forall a b. (a -> b) -> a -> b
$ forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap f ~> g
f forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled f f ()
x
  {-# INLINE ffmap #-}

instance ( FFunctor (Tupled f)
         , FFunctor (Tupled g)
         ) =>
         FFunctor (Tupled (FunctorProd f g)) where
  ffmap :: forall (f :: k -> *) (g :: k -> *).
(f ~> g)
-> Tupled (FunctorProd f g) f -> Tupled (FunctorProd f g) g
ffmap f ~> g
f (Tupled (FunctorProd (f f ()
x :*: g f ()
y))) =
    forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (f :: k -> k -> *) (g :: k -> k -> *) (a :: k)
       (k :: k).
(:*:) (f a) (g a) k -> FunctorProd f g a k
FunctorProd forall a b. (a -> b) -> a -> b
$
    forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled (forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap f ~> g
f (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled f f ()
x)) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:
    forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled (forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap f ~> g
f (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled g f ()
y))
  {-# INLINE ffmap #-}

class Coercible (x ()) (Tupled r g) =>
  GFLenses (x :: * -> *) k (r :: (k -> *) -> * -> *) g | x -> k, x -> r where
  genflenses :: Tupled r (FLens g (Tupled r))
  
instance GFLenses ((S1 ('MetaSel fieldName _x _x2 _x3)
                    (Rec0 (g (a :: k))) :: * -> *))
                   k
                  (FunctorS1 fieldName _x _x2 _x3 a)
                  g where
  genflenses :: Tupled
  (FunctorS1 fieldName _x _x2 _x3 a)
  (FLens g (Tupled (FunctorS1 fieldName _x _x2 _x3 a)))
genflenses = forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (fieldName :: Maybe Symbol)
       (_x :: SourceUnpackedness) (_x2 :: SourceStrictness)
       (_x3 :: DecidedStrictness) (a :: k) (g :: k -> *) (k :: k).
S1 ('MetaSel fieldName _x _x2 _x3) (Rec0 (g a)) k
-> FunctorS1 fieldName _x _x2 _x3 a g k
FunctorS1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall {k} (g :: k -> *) (s :: (k -> *) -> *) (a :: k).
Lens' (g a) (s g) -> FLens g s a
FLens forall a b. (a -> b) -> a -> b
$ \g a -> f (g a)
f Tupled (FunctorS1 fieldName _x _x2 _x3 a) g
g ->
    ( forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (fieldName :: Maybe Symbol)
       (_x :: SourceUnpackedness) (_x2 :: SourceStrictness)
       (_x3 :: DecidedStrictness) (a :: k) (g :: k -> *) (k :: k).
S1 ('MetaSel fieldName _x _x2 _x3) (Rec0 (g a)) k
-> FunctorS1 fieldName _x _x2 _x3 a g k
FunctorS1  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    g a -> f (g a)
f (forall k i c (p :: k). K1 i c p -> c
unK1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (fieldName :: Maybe Symbol)
       (_x :: SourceUnpackedness) (_x2 :: SourceStrictness)
       (_x3 :: DecidedStrictness) (a :: k) (g :: k -> *) (k :: k).
FunctorS1 fieldName _x _x2 _x3 a g k
-> S1 ('MetaSel fieldName _x _x2 _x3) (Rec0 (g a)) k
getFunctorS1 forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled forall a b. (a -> b) -> a -> b
$ Tupled (FunctorS1 fieldName _x _x2 _x3 a) g
g)
  {-# INLINE genflenses #-}

instance
  ( FFunctor (Tupled r)
  , GFLenses x k r g
  ) =>
  GFLenses (D1 meta (C1 meta2 x)) k (FunctorD1 meta meta2 r) g where
  genflenses :: Tupled
  (FunctorD1 meta meta2 r)
  (FLens g (Tupled (FunctorD1 meta meta2 r)))
genflenses = forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (meta :: Meta) (meta2 :: Meta) (f :: k -> k -> *)
       (l :: k) (k :: k).
D1 meta (C1 meta2 (f l)) k -> FunctorD1 meta meta2 f l k
FunctorD1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$
               forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled forall a b. (a -> b) -> a -> b
$
               forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap (forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
(s g -> t g) -> (t g -> s g) -> FLens g s a -> FLens g t a
compIsoFLens
                      (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (meta :: Meta) (meta2 :: Meta) (f :: k -> k -> *)
       (l :: k) (k :: k).
D1 meta (C1 meta2 (f l)) k -> FunctorD1 meta meta2 f l k
FunctorD1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled)
                      (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (meta :: Meta) (meta2 :: Meta) (f :: k -> k -> *)
       (l :: k) (k :: k).
FunctorD1 meta meta2 f l k -> D1 meta (C1 meta2 (f l)) k
getFunctorD1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled)) forall a b. (a -> b) -> a -> b
$
               (forall (x :: * -> *) k (r :: (k -> *) -> * -> *) (g :: k -> *).
GFLenses x k r g =>
Tupled r (FLens g (Tupled r))
genflenses @x)
  {-# INLINE genflenses #-}

instance ( FFunctor (Tupled r1)
         , FFunctor (Tupled r2)
         , Coercible ((x :*: y) ())  (Tupled (FunctorProd r1 r2) g)
         , GFLenses x k r1 g
         , GFLenses y k r2 g
         ) =>
         GFLenses (x :*: y) k (FunctorProd r1 r2) g
         where
  genflenses :: Tupled (FunctorProd r1 r2) (FLens g (Tupled (FunctorProd r1 r2)))
genflenses = forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall a b. (a -> b) -> a -> b
$ forall {k} {k} (f :: k -> k -> *) (g :: k -> k -> *) (a :: k)
       (k :: k).
(:*:) (f a) (g a) k -> FunctorProd f g a k
FunctorProd forall a b. (a -> b) -> a -> b
$
               forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled (forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap (forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
Lens' (s g) (t g) -> FLens g s a -> FLens g t a
compFLens forall a b. (a -> b) -> a -> b
$
                                \Tupled r1 g -> f (Tupled r1 g)
f (Tupled (FunctorProd (r1 g ()
a :*: r2 g ()
b))) ->
                                  (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (f :: k -> k -> *) (g :: k -> k -> *) (a :: k)
       (k :: k).
(:*:) (f a) (g a) k -> FunctorProd f g a k
FunctorProd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: r2 g ()
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled)
                                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tupled r1 g -> f (Tupled r1 g)
f (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled r1 g ()
a))
                         (forall (x :: * -> *) k (r :: (k -> *) -> * -> *) (g :: k -> *).
GFLenses x k r g =>
Tupled r (FLens g (Tupled r))
genflenses @x)) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:
               forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled (forall k (t :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FFunctor t =>
(f ~> g) -> t f -> t g
ffmap (forall {k} (s :: (k -> *) -> *) (g :: k -> *) (t :: (k -> *) -> *)
       (a :: k).
Lens' (s g) (t g) -> FLens g s a -> FLens g t a
compFLens forall a b. (a -> b) -> a -> b
$
                                \Tupled r2 g -> f (Tupled r2 g)
f (Tupled (FunctorProd (r1 g ()
a :*: r2 g ()
b))) ->
                                  (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (f :: k -> k -> *) (g :: k -> k -> *) (a :: k)
       (k :: k).
(:*:) (f a) (g a) k -> FunctorProd f g a k
FunctorProd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r1 g ()
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> * -> *) (a :: k). Tupled f a -> f a ()
unTupled)
                                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tupled r2 g -> f (Tupled r2 g)
f (forall k (f :: k -> * -> *) (a :: k). f a () -> Tupled f a
Tupled r2 g ()
b))
                         (forall (x :: * -> *) k (r :: (k -> *) -> * -> *) (g :: k -> *).
GFLenses x k r g =>
Tupled r (FLens g (Tupled r))
genflenses @y))
        
  {-# INLINE genflenses #-}

type GFlensesMachinery k t r g =
  ( Generic (t g)
  , Generic (t (FLens g (Tupled r)))
  , Coercible (r (FLens g (Tupled r)) ())
    (Rep (t (FLens g (Tupled r))) ())
  , FFunctor (t :: (k -> *) -> *)
  , FFunctor (Tupled r)
  , GFLenses (Rep (t g)) k (r :: (k -> *) -> * -> *) g
  )

toHkd :: forall t g r.
         ( Generic (t g)
         , Coercible (r g ()) (Rep (t g) ())
         ) =>
         Tupled r g -> t g
toHkd :: forall {k} (t :: k -> *) (g :: k) (r :: k -> * -> *).
(Generic (t g), Coercible (r g ()) (Rep (t g) ())) =>
Tupled r g -> t g
toHkd Tupled r g
t = forall a x. Generic a => Rep a x -> a
to (coerce :: forall a b. Coercible a b => a -> b
coerce Tupled r g
t :: Rep (t g) ())
{-# INLINE toHkd #-}          

fromHkd :: forall t g r.
         ( Generic (t g)
         , Coercible (r g ()) (Rep (t g) ())
         ) =>
         t g -> Tupled r g
fromHkd :: forall {k} (t :: k -> *) (g :: k) (r :: k -> * -> *).
(Generic (t g), Coercible (r g ()) (Rep (t g) ())) =>
t g -> Tupled r g
fromHkd t g
r = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a x. Generic a => a -> Rep a x
from t g
r :: Rep (t g) ())
{-# INLINE fromHkd #-}

-- | collect `Const` elements into a list efficiently.
ftoList :: FFoldable t => t (Const a) -> [a]
ftoList :: forall {k} (t :: (k -> *) -> *) a.
FFoldable t =>
t (Const a) -> [a]
ftoList = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Endo a -> a -> a
appEndo [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (t :: (k -> *) -> *) m (f :: k -> *).
(FFoldable t, Monoid m) =>
(forall (a :: k). f a -> m) -> t f -> m
ffoldMap (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst)