-- Copyright 2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Provides 'Generic1' derivation of 'Representable' based on 'Field'.
--
-- This relies on the observation that a parametric function
-- @forall a. f a -> a@ is isomorphic to the set of "indices" of @f@, i.e.
-- @'Rep' f@.  With the appropriate instances, we can do anything with it that
-- we could with a hand-written ADT 'Rep' type.  So, this module provides a way
-- to use exactly that type as 'Rep', and the needed instances to make it
-- convenient to use.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Functor.Field
         ( Field(..)
         , FieldRep(..), FieldPaths(..), GFieldPaths(..), GTabulate(..)
         ) where

import Control.Monad.Trans.State (state, evalState)
import Data.Coerce (coerce)
import Data.Proxy (Proxy(..))
import qualified Data.Text as T
import GHC.Generics
         ( Generic1(..)
         , (:*:)(..), (:.:)(..)
         , M1(..), Rec1(..), U1(..), Par1(..)
         , Meta(..), S, C, D
         )
import GHC.TypeLits (KnownSymbol, symbolVal)

import Data.Distributive (Distributive(..))
import Data.Hashable (Hashable(..))
import Data.Functor.Rep (Representable(..), distributeRep, collectRep)
import Data.Portray (Portray(..), Portrayal(..))
import Data.Portray.Diff (Diff(..), diffVs)
import Data.Wrapped (Wrapped1(..))

import Data.Ten.Internal
         ( PathComponent(..), dropUnderscore, showsPath, starFst, starSnd
         , portrayPath
         )

-- | A 'Rep' type in the form of a parametric accessor function.
newtype Field f = Field { Field f -> forall a. f a -> a
getField :: forall a. f a -> a }

fieldNumbers :: (Traversable f, Applicative f) => f Int
fieldNumbers :: f Int
fieldNumbers = (State Int (f Int) -> Int -> f Int)
-> Int -> State Int (f Int) -> f Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (f Int) -> Int -> f Int
forall s a. State s a -> s -> a
evalState Int
0 (State Int (f Int) -> f Int) -> State Int (f Int) -> f Int
forall a b. (a -> b) -> a -> b
$ f (StateT Int Identity Int) -> State Int (f Int)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (f (StateT Int Identity Int) -> State Int (f Int))
-> f (StateT Int Identity Int) -> State Int (f Int)
forall a b. (a -> b) -> a -> b
$ StateT Int Identity Int -> f (StateT Int Identity Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT Int Identity Int -> f (StateT Int Identity Int))
-> StateT Int Identity Int -> f (StateT Int Identity Int)
forall a b. (a -> b) -> a -> b
$ (Int -> (Int, Int)) -> StateT Int Identity Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int -> (Int, Int)) -> StateT Int Identity Int)
-> (Int -> (Int, Int)) -> StateT Int Identity Int
forall a b. (a -> b) -> a -> b
$ \Int
i -> (Int
i, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

instance (Traversable f, Applicative f) => Eq (Field f) where
  Field forall a. f a -> a
f == :: Field f -> Field f -> Bool
== Field forall a. f a -> a
g = f Int -> Int
forall a. f a -> a
f f Int
forall (f :: * -> *). (Traversable f, Applicative f) => f Int
fieldNumbers Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== f Int -> Int
forall a. f a -> a
g f Int
forall (f :: * -> *). (Traversable f, Applicative f) => f Int
fieldNumbers

instance (Traversable f, Applicative f) => Ord (Field f) where
  Field forall a. f a -> a
f compare :: Field f -> Field f -> Ordering
`compare` Field forall a. f a -> a
g = f Int -> Int
forall a. f a -> a
f f Int
forall (f :: * -> *). (Traversable f, Applicative f) => f Int
fieldNumbers Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` f Int -> Int
forall a. f a -> a
g f Int
forall (f :: * -> *). (Traversable f, Applicative f) => f Int
fieldNumbers

instance (Traversable f, Applicative f) => Hashable (Field f) where
  hashWithSalt :: Int -> Field f -> Int
hashWithSalt Int
salt (Field forall a. f a -> a
f) = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ f Int -> Int
forall a. f a -> a
f f Int
forall (f :: * -> *). (Traversable f, Applicative f) => f Int
fieldNumbers

-- | Build a record where each field has a description of the field's location.
--
-- This primarily powers the 'Show' and 'Portray' instances of 'Field'.
class FieldPaths f where
  fieldPaths :: f [PathComponent]

instance FieldPaths f => Show (Field f) where
  showsPrec :: Int -> Field f -> ShowS
showsPrec Int
p (Field forall a. f a -> a
f) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Field " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [PathComponent] -> ShowS
showsPath Int
11 ([PathComponent] -> [PathComponent]
coerce ([PathComponent] -> [PathComponent])
-> [PathComponent] -> [PathComponent]
forall a b. (a -> b) -> a -> b
$ f [PathComponent] -> [PathComponent]
forall a. f a -> a
f f [PathComponent]
forall (f :: * -> *). FieldPaths f => f [PathComponent]
fieldPaths)

instance FieldPaths f => Portray (Field f) where
  portray :: Field f -> Portrayal
portray (Field forall a. f a -> a
f) = Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name Ident
"Field") [[PathComponent] -> Portrayal
portrayPath ([PathComponent] -> Portrayal) -> [PathComponent] -> Portrayal
forall a b. (a -> b) -> a -> b
$ f [PathComponent] -> [PathComponent]
forall a. f a -> a
f f [PathComponent]
forall (f :: * -> *). FieldPaths f => f [PathComponent]
fieldPaths]

instance (Traversable f, Applicative f, FieldPaths f) => Diff (Field f) where
  diff :: Field f -> Field f -> Maybe Portrayal
diff Field f
f Field f
g
    | Field f
f Field f -> Field f -> Bool
forall a. Eq a => a -> a -> Bool
== Field f
g    = Maybe Portrayal
forall a. Maybe a
Nothing
    | Bool
otherwise = Portrayal -> Maybe Portrayal
forall a. a -> Maybe a
Just (Portrayal -> Maybe Portrayal) -> Portrayal -> Maybe Portrayal
forall a b. (a -> b) -> a -> b
$ Field f -> Portrayal
forall a. Portray a => a -> Portrayal
portray Field f
f Portrayal -> Portrayal -> Portrayal
`diffVs` Field f -> Portrayal
forall a. Portray a => a -> Portrayal
portray Field f
g

instance (Generic1 rec, GFieldPaths (Rep1 rec))
      => FieldPaths (Wrapped1 Generic1 rec) where
  fieldPaths :: Wrapped1 Generic1 rec [PathComponent]
fieldPaths = rec [PathComponent] -> Wrapped1 Generic1 rec [PathComponent]
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
f a -> Wrapped1 c f a
Wrapped1 (rec [PathComponent] -> Wrapped1 Generic1 rec [PathComponent])
-> (Rep1 rec [PathComponent] -> rec [PathComponent])
-> Rep1 rec [PathComponent]
-> Wrapped1 Generic1 rec [PathComponent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep1 rec [PathComponent] -> rec [PathComponent]
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 rec [PathComponent] -> Wrapped1 Generic1 rec [PathComponent])
-> Rep1 rec [PathComponent]
-> Wrapped1 Generic1 rec [PathComponent]
forall a b. (a -> b) -> a -> b
$ ([PathComponent] -> [PathComponent]) -> Rep1 rec [PathComponent]
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths [PathComponent] -> [PathComponent]
forall a. a -> a
id
  {-# INLINE fieldPaths #-}

-- | The 'Generic1' implementation of 'FieldPaths'.
--
-- As with 'GTabulate', derive this only to enable using your type as a
-- sub-record; otherwise just derive 'FieldPaths' directly.
class GFieldPaths rec where
  gfieldPaths :: ([PathComponent] -> r) -> rec r

instance GFieldPaths U1 where
  gfieldPaths :: ([PathComponent] -> r) -> U1 r
gfieldPaths [PathComponent] -> r
_ = U1 r
forall k (p :: k). U1 p
U1
  {-# INLINE gfieldPaths #-}

instance GFieldPaths Par1 where
  gfieldPaths :: ([PathComponent] -> r) -> Par1 r
gfieldPaths [PathComponent] -> r
r = r -> Par1 r
forall p. p -> Par1 p
Par1 (r -> Par1 r) -> r -> Par1 r
forall a b. (a -> b) -> a -> b
$ [PathComponent] -> r
r []
  {-# INLINE gfieldPaths #-}

instance GFieldPaths rec => GFieldPaths (Rec1 rec) where
  gfieldPaths :: ([PathComponent] -> r) -> Rec1 rec r
gfieldPaths = rec r -> Rec1 rec r
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (rec r -> Rec1 rec r)
-> (([PathComponent] -> r) -> rec r)
-> ([PathComponent] -> r)
-> Rec1 rec r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PathComponent] -> r) -> rec r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths
  {-# INLINE gfieldPaths #-}

instance GFieldPaths rec => GFieldPaths (M1 C i rec) where
  gfieldPaths :: ([PathComponent] -> r) -> M1 C i rec r
gfieldPaths = rec r -> M1 C i rec r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rec r -> M1 C i rec r)
-> (([PathComponent] -> r) -> rec r)
-> ([PathComponent] -> r)
-> M1 C i rec r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PathComponent] -> r) -> rec r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths
  {-# INLINE gfieldPaths #-}

-- Non-newtype constructors: wait until we get to the fields to assign a path
-- component.
instance GFieldPaths rec
      => GFieldPaths (M1 D ('MetaData n m p 'False) rec) where
  gfieldPaths :: ([PathComponent] -> r) -> M1 D ('MetaData n m p 'False) rec r
gfieldPaths = rec r -> M1 D ('MetaData n m p 'False) rec r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rec r -> M1 D ('MetaData n m p 'False) rec r)
-> (([PathComponent] -> r) -> rec r)
-> ([PathComponent] -> r)
-> M1 D ('MetaData n m p 'False) rec r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PathComponent] -> r) -> rec r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths
  {-# INLINE gfieldPaths #-}

-- Newtype constructors: immediately decide to use 'NewtypeIso'.
instance GFieldPaths rec
      => GFieldPaths
           (M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec))) where
  gfieldPaths :: ([PathComponent] -> r)
-> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r
gfieldPaths [PathComponent] -> r
r = M1 C i (M1 S j rec) r
-> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 C i (M1 S j rec) r
 -> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r)
-> (rec r -> M1 C i (M1 S j rec) r)
-> rec r
-> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 S j rec r -> M1 C i (M1 S j rec) r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S j rec r -> M1 C i (M1 S j rec) r)
-> (rec r -> M1 S j rec r) -> rec r -> M1 C i (M1 S j rec) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. rec r -> M1 S j rec r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rec r -> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r)
-> rec r -> M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec)) r
forall a b. (a -> b) -> a -> b
$ ([PathComponent] -> r) -> rec r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths ([PathComponent] -> r
r ([PathComponent] -> r)
-> ([PathComponent] -> [PathComponent]) -> [PathComponent] -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathComponent
NewtypeIsoPathComponent -> [PathComponent] -> [PathComponent]
forall a. a -> [a] -> [a]
:))
  {-# INLINE gfieldPaths #-}

instance (KnownSymbol sym, GFieldPaths rec)
      => GFieldPaths (M1 S ('MetaSel ('Just sym) b c d) rec) where
  gfieldPaths :: ([PathComponent] -> r) -> M1 S ('MetaSel ('Just sym) b c d) rec r
gfieldPaths [PathComponent] -> r
r = rec r -> M1 S ('MetaSel ('Just sym) b c d) rec r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rec r -> M1 S ('MetaSel ('Just sym) b c d) rec r)
-> (([PathComponent] -> r) -> rec r)
-> ([PathComponent] -> r)
-> M1 S ('MetaSel ('Just sym) b c d) rec r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PathComponent] -> r) -> rec r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths (([PathComponent] -> r) -> M1 S ('MetaSel ('Just sym) b c d) rec r)
-> ([PathComponent] -> r)
-> M1 S ('MetaSel ('Just sym) b c d) rec r
forall a b. (a -> b) -> a -> b
$
    [PathComponent] -> r
r ([PathComponent] -> r)
-> ([PathComponent] -> [PathComponent]) -> [PathComponent] -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> PathComponent
NamedField (String -> Text
T.pack String
nm) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
dropUnderscore String
nm) PathComponent -> [PathComponent] -> [PathComponent]
forall a. a -> [a] -> [a]
:)
   where
    nm :: String
nm = Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @sym Proxy sym
forall k (t :: k). Proxy t
Proxy
  {-# INLINE gfieldPaths #-}

instance (GFieldPaths f, GFieldPaths g) => GFieldPaths (f :*: g) where
  gfieldPaths :: ([PathComponent] -> r) -> (:*:) f g r
gfieldPaths [PathComponent] -> r
r = ([PathComponent] -> r) -> f r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths [PathComponent] -> r
r f r -> g r -> (:*:) f g r
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ([PathComponent] -> r) -> g r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths [PathComponent] -> r
r
  {-# INLINE gfieldPaths #-}

instance (GFieldPaths f, GFieldPaths g) => GFieldPaths (f :.: g) where
  gfieldPaths :: ([PathComponent] -> r) -> (:.:) f g r
gfieldPaths [PathComponent] -> r
r = f (g r) -> (:.:) f g r
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g r) -> (:.:) f g r) -> f (g r) -> (:.:) f g r
forall a b. (a -> b) -> a -> b
$
    ([PathComponent] -> g r) -> f (g r)
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths (([PathComponent] -> g r) -> f (g r))
-> ([PathComponent] -> g r) -> f (g r)
forall a b. (a -> b) -> a -> b
$ \[PathComponent]
outer ->
    ([PathComponent] -> r) -> g r
forall (rec :: * -> *) r.
GFieldPaths rec =>
([PathComponent] -> r) -> rec r
gfieldPaths (([PathComponent] -> r) -> g r) -> ([PathComponent] -> r) -> g r
forall a b. (a -> b) -> a -> b
$ \[PathComponent]
inner ->
    [PathComponent] -> r
r ([PathComponent] -> r) -> [PathComponent] -> r
forall a b. (a -> b) -> a -> b
$ [PathComponent]
outer [PathComponent] -> [PathComponent] -> [PathComponent]
forall a. [a] -> [a] -> [a]
++ [PathComponent]
inner
  {-# INLINE gfieldPaths #-}

-- | The 'Generic1' implementation of 'tabulate' for 'Field'.
class GTabulate rec where
  gtabulate :: (Field rec -> r) -> rec r

-- | A newtype carrying instances for use with @DerivingVia@.
--
-- This provides 'Applicative', 'Monad', 'Representable', and
-- 'Data.Functor.Update.Update'.
newtype FieldRep f a = FieldRep (f a)
  deriving a -> FieldRep f b -> FieldRep f a
(a -> b) -> FieldRep f a -> FieldRep f b
(forall a b. (a -> b) -> FieldRep f a -> FieldRep f b)
-> (forall a b. a -> FieldRep f b -> FieldRep f a)
-> Functor (FieldRep f)
forall a b. a -> FieldRep f b -> FieldRep f a
forall a b. (a -> b) -> FieldRep f a -> FieldRep f b
forall (f :: * -> *) a b.
Functor f =>
a -> FieldRep f b -> FieldRep f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> FieldRep f a -> FieldRep f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FieldRep f b -> FieldRep f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> FieldRep f b -> FieldRep f a
fmap :: (a -> b) -> FieldRep f a -> FieldRep f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> FieldRep f a -> FieldRep f b
Functor

-- Only to satisfy the superclass constraint of Representable.
instance (Generic1 f, GTabulate (Rep1 f), Functor f)
      => Distributive (FieldRep f) where
  distribute :: f (FieldRep f a) -> FieldRep f (f a)
distribute = f (FieldRep f a) -> FieldRep f (f a)
forall (f :: * -> *) (w :: * -> *) a.
(Representable f, Functor w) =>
w (f a) -> f (w a)
distributeRep
  collect :: (a -> FieldRep f b) -> f a -> FieldRep f (f b)
collect = (a -> FieldRep f b) -> f a -> FieldRep f (f b)
forall (f :: * -> *) (w :: * -> *) a b.
(Representable f, Functor w) =>
(a -> f b) -> w a -> f (w b)
collectRep

instance (Generic1 f, GTabulate (Rep1 f), Functor f)
      => Applicative (FieldRep f) where
  pure :: a -> FieldRep f a
pure a
x = (Rep (FieldRep f) -> a) -> FieldRep f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (a -> Field f -> a
forall a b. a -> b -> a
const a
x)
  FieldRep f (a -> b)
f <*> :: FieldRep f (a -> b) -> FieldRep f a -> FieldRep f b
<*> FieldRep f a
x = (Rep (FieldRep f) -> b) -> FieldRep f b
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (FieldRep f (a -> b) -> Rep (FieldRep f) -> a -> b
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index FieldRep f (a -> b)
f (Field f -> a -> b) -> (Field f -> a) -> Field f -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldRep f a -> Rep (FieldRep f) -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index FieldRep f a
x)

instance (Generic1 f, GTabulate (Rep1 f), Functor f)
      => Monad (FieldRep f) where
  FieldRep f a
x >>= :: FieldRep f a -> (a -> FieldRep f b) -> FieldRep f b
>>= a -> FieldRep f b
f = (Rep (FieldRep f) -> b) -> FieldRep f b
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (FieldRep f a -> Rep (FieldRep f) -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index FieldRep f a
x (Field f -> a) -> (a -> Field f -> b) -> Field f -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FieldRep f b -> Field f -> b
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (FieldRep f b -> Field f -> b)
-> (a -> FieldRep f b) -> a -> Field f -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FieldRep f b
f)

instance (Generic1 f, GTabulate (Rep1 f), Functor f)
      => Representable (FieldRep f) where
  type Rep (FieldRep f) = Field f
  index :: FieldRep f a -> Rep (FieldRep f) -> a
index (FieldRep f a
f) (Field g) = f a -> a
forall a. f a -> a
g f a
f
  tabulate :: (Rep (FieldRep f) -> a) -> FieldRep f a
tabulate Rep (FieldRep f) -> a
f = f a -> FieldRep f a
forall (f :: * -> *) a. f a -> FieldRep f a
FieldRep (f a -> FieldRep f a) -> f a -> FieldRep f a
forall a b. (a -> b) -> a -> b
$ Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f a -> f a) -> Rep1 f a -> f a
forall a b. (a -> b) -> a -> b
$ (Field (Rep1 f) -> a) -> Rep1 f a
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field (Rep1 f) -> a) -> Rep1 f a)
-> (Field (Rep1 f) -> a) -> Rep1 f a
forall a b. (a -> b) -> a -> b
$ \Field (Rep1 f)
i -> Rep (FieldRep f) -> a
f (Rep (FieldRep f) -> a) -> Rep (FieldRep f) -> a
forall a b. (a -> b) -> a -> b
$ (forall a. f a -> a) -> Field f
forall (f :: * -> *). (forall a. f a -> a) -> Field f
Field ((forall a. f a -> a) -> Field f)
-> (forall a. f a -> a) -> Field f
forall a b. (a -> b) -> a -> b
$ Field (Rep1 f) -> forall a. Rep1 f a -> a
forall (f :: * -> *). Field f -> forall a. f a -> a
getField Field (Rep1 f)
i (Rep1 f a -> a) -> (f a -> Rep1 f a) -> f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

instance GTabulate U1 where
  gtabulate :: (Field U1 -> r) -> U1 r
gtabulate Field U1 -> r
_ = U1 r
forall k (p :: k). U1 p
U1
  {-# INLINE gtabulate #-}

instance GTabulate rec => GTabulate (Rec1 rec) where
  gtabulate :: (Field (Rec1 rec) -> r) -> Rec1 rec r
gtabulate Field (Rec1 rec) -> r
r = rec r -> Rec1 rec r
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (rec r -> Rec1 rec r) -> rec r -> Rec1 rec r
forall a b. (a -> b) -> a -> b
$ (Field rec -> r) -> rec r
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field (Rec1 rec) -> r) -> Field rec -> r
coerce Field (Rec1 rec) -> r
r)
  {-# INLINE gtabulate #-}

instance GTabulate rec => GTabulate (M1 k i rec) where
  gtabulate :: (Field (M1 k i rec) -> r) -> M1 k i rec r
gtabulate Field (M1 k i rec) -> r
r = rec r -> M1 k i rec r
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rec r -> M1 k i rec r) -> rec r -> M1 k i rec r
forall a b. (a -> b) -> a -> b
$ (Field rec -> r) -> rec r
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field (M1 k i rec) -> r) -> Field rec -> r
coerce Field (M1 k i rec) -> r
r)
  {-# INLINE gtabulate #-}

instance GTabulate Par1 where
  gtabulate :: (Field Par1 -> r) -> Par1 r
gtabulate Field Par1 -> r
r = r -> Par1 r
forall p. p -> Par1 p
Par1 (r -> Par1 r) -> r -> Par1 r
forall a b. (a -> b) -> a -> b
$ Field Par1 -> r
r ((forall a. Par1 a -> a) -> Field Par1
forall (f :: * -> *). (forall a. f a -> a) -> Field f
Field forall a. Par1 a -> a
coerce)
  {-# INLINE gtabulate #-}

instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where
  gtabulate :: (Field (f :*: g) -> r) -> (:*:) f g r
gtabulate Field (f :*: g) -> r
r = f r
ftab f r -> g r -> (:*:) f g r
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g r
gtab
   where
    ftab :: f r
ftab = (Field f -> r) -> f r
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field f -> r) -> f r) -> (Field f -> r) -> f r
forall a b. (a -> b) -> a -> b
$ \ (Field forall a. f a -> a
g) -> Field (f :*: g) -> r
r (Field (f :*: g) -> r) -> Field (f :*: g) -> r
forall a b. (a -> b) -> a -> b
$ (forall a. (:*:) f g a -> a) -> Field (f :*: g)
forall (f :: * -> *). (forall a. f a -> a) -> Field f
Field ((forall a. (:*:) f g a -> a) -> Field (f :*: g))
-> (forall a. (:*:) f g a -> a) -> Field (f :*: g)
forall a b. (a -> b) -> a -> b
$ f a -> a
forall a. f a -> a
g (f a -> a) -> ((:*:) f g a -> f a) -> (:*:) f g a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:*:) f g a -> f a
forall k (f :: k -> *) (g :: k -> *) (m :: k). (:*:) f g m -> f m
starFst
    gtab :: g r
gtab = (Field g -> r) -> g r
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field g -> r) -> g r) -> (Field g -> r) -> g r
forall a b. (a -> b) -> a -> b
$ \ (Field forall a. g a -> a
g) -> Field (f :*: g) -> r
r (Field (f :*: g) -> r) -> Field (f :*: g) -> r
forall a b. (a -> b) -> a -> b
$ (forall a. (:*:) f g a -> a) -> Field (f :*: g)
forall (f :: * -> *). (forall a. f a -> a) -> Field f
Field ((forall a. (:*:) f g a -> a) -> Field (f :*: g))
-> (forall a. (:*:) f g a -> a) -> Field (f :*: g)
forall a b. (a -> b) -> a -> b
$ g a -> a
forall a. g a -> a
g (g a -> a) -> ((:*:) f g a -> g a) -> (:*:) f g a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:*:) f g a -> g a
forall k (f :: k -> *) (g :: k -> *) (m :: k). (:*:) f g m -> g m
starSnd
  {-# INLINE gtabulate #-}

instance (GTabulate f, GTabulate g) => GTabulate (f :.: g) where
  gtabulate :: (Field (f :.: g) -> r) -> (:.:) f g r
gtabulate Field (f :.: g) -> r
r = f (g r) -> (:.:) f g r
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g r) -> (:.:) f g r) -> f (g r) -> (:.:) f g r
forall a b. (a -> b) -> a -> b
$
    (Field f -> g r) -> f (g r)
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field f -> g r) -> f (g r)) -> (Field f -> g r) -> f (g r)
forall a b. (a -> b) -> a -> b
$ \ (Field forall a. f a -> a
g0) ->
    (Field g -> r) -> g r
forall (rec :: * -> *) r.
GTabulate rec =>
(Field rec -> r) -> rec r
gtabulate ((Field g -> r) -> g r) -> (Field g -> r) -> g r
forall a b. (a -> b) -> a -> b
$ \ (Field forall a. g a -> a
g1) ->
    Field (f :.: g) -> r
r ((forall a. (:.:) f g a -> a) -> Field (f :.: g)
forall (f :: * -> *). (forall a. f a -> a) -> Field f
Field ((forall a. (:.:) f g a -> a) -> Field (f :.: g))
-> (forall a. (:.:) f g a -> a) -> Field (f :.: g)
forall a b. (a -> b) -> a -> b
$ g a -> a
forall a. g a -> a
g1 (g a -> a) -> ((:.:) f g a -> g a) -> (:.:) f g a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g a
forall a. f a -> a
g0 (f (g a) -> g a) -> ((:.:) f g a -> f (g a)) -> (:.:) f g a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) f g a -> f (g a)
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1)
  {-# INLINE gtabulate #-}

{-
instance KnownNat n => GTabulate (Vec n) where
  gtabulate r = tabulate $ \i -> r $ Field (Vec.! i)
  {-# INLINE gtabulate #-}
  -}