{-# language DataKinds              #-}
{-# language DefaultSignatures      #-}
{-# language FlexibleContexts       #-}
{-# language FlexibleInstances      #-}
{-# language FunctionalDependencies #-}
{-# language GADTs                  #-}
{-# language PolyKinds              #-}
{-# language QuantifiedConstraints  #-}
{-# language RankNTypes             #-}
{-# language ScopedTypeVariables    #-}
{-# language TypeApplications       #-}
{-# language TypeFamilies           #-}
{-# language TypeOperators          #-}
{-# language UndecidableInstances   #-}
{-|
Description : Conversion from types to schemas

This module defines a couple of type classes
'ToSchema' and 'FromSchema' to turn Haskell
types back and forth @mu-haskell@ 'Term's.

In most cases, the instances can be automatically
derived. If you enable the extensions
@DeriveGeneric@ and @DeriveAnyClass@, you can do:

> data MyHaskellType = ...
>   deriving ( ToSchema   f MySchema "MySchemaType" MyHaskellType
>            , FromSchema f MySchema "MySchemaType" MyHaskellType)

If the default mapping which required identical
names for fields in the Haskell and schema types
does not suit you, use 'CustomFieldMapping'.
-}
module Mu.Schema.Class (
  WithSchema(..), unWithSchema
, FromSchema(..), fromSchema'
, ToSchema(..), toSchema'
, CustomFieldMapping(..)
, Mapping(..), Mappings, MappingRight, MappingLeft
, transSchema
  -- * Internal use only
, GToSchemaRecord(..)
) where

import           Data.Functor.Identity
import           Data.Kind
import           Data.Map                 as M
import           Data.SOP
import           GHC.Generics
import           GHC.TypeLits

import           Mu.Schema.Definition
import           Mu.Schema.Interpretation

-- | Tags a value with its schema.
--   For usage with @deriving via@.
newtype WithSchema (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a where
  WithSchema :: forall tn fn (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a.
                a -> WithSchema w sch sty a

unWithSchema :: forall tn fn (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a.
                WithSchema w sch sty a -> a
unWithSchema :: WithSchema w sch sty a -> a
unWithSchema (WithSchema x :: a
x) = a
x

-- | Defines the conversion of a type @t@ into a 'Term'
--   which follows the schema @sch@.
--   You can give an optional mapping between the
--   field names of @t@ and that of @sty@
--   by means of 'CustomFieldMapping'.
class ToSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)
      | sch t -> sty where
  -- | Conversion from Haskell type to schema term.
  toSchema   :: t -> Term w sch (sch :/: sty)

  default
    toSchema :: (Generic t, GToSchemaTypeDef w sch '[] (sch :/: sty) (Rep t))
              => t -> Term w sch (sch :/: sty)
  toSchema x :: t
x = Proxy '[] -> Rep t Any -> Term w sch (sch :/: sty)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef w sch fmap t f =>
Proxy fmap -> f a -> Term w sch t
toSchemaTypeDef (Proxy '[]
forall k (t :: k). Proxy t
Proxy @'[]) (t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x)

-- | Defines the conversion from a 'Term'
--   which follows the schema @sch@ into a type @t@.
--   You can give an optional mapping between the
--   field names of @t@ and that of @sty@
--   by means of 'CustomFieldMapping'.
class FromSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)
      | sch t -> sty where
  -- | Conversion from schema term to Haskell type.
  fromSchema :: Term w sch (sch :/: sty) -> t

  default
    fromSchema :: (Generic t, GFromSchemaTypeDef w sch '[] (sch :/: sty) (Rep t) )
               => Term w sch (sch :/: sty) -> t
  fromSchema x :: Term w sch (sch :/: sty)
x = Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Proxy '[] -> Term w sch (sch :/: sty) -> Rep t Any
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef w sch fmap t f =>
Proxy fmap -> Term w sch t -> f a
fromSchemaTypeDef (Proxy '[]
forall k (t :: k). Proxy t
Proxy @'[]) Term w sch (sch :/: sty)
x)

instance (sch :/: sty ~ 'DRecord sty fields)
         => ToSchema w sch sty (Term w sch ('DRecord sty fields)) where
  toSchema :: Term w sch ('DRecord sty fields) -> Term w sch (sch :/: sty)
toSchema = Term w sch ('DRecord sty fields) -> Term w sch (sch :/: sty)
forall a. a -> a
id
instance (sch :/: sty ~ 'DEnum sty choices)
         => ToSchema w sch sty (Term w sch ('DEnum sty choices)) where
  toSchema :: Term w sch ('DEnum sty choices) -> Term w sch (sch :/: sty)
toSchema = Term w sch ('DEnum sty choices) -> Term w sch (sch :/: sty)
forall a. a -> a
id
instance (sch :/: sty ~ 'DRecord sty fields)
         => FromSchema w sch sty (Term w sch ('DRecord sty fields)) where
  fromSchema :: Term w sch (sch :/: sty) -> Term w sch ('DRecord sty fields)
fromSchema = Term w sch (sch :/: sty) -> Term w sch ('DRecord sty fields)
forall a. a -> a
id
instance (sch :/: sty ~ 'DEnum sty choices)
         => FromSchema w sch sty (Term w sch ('DEnum sty choices)) where
  fromSchema :: Term w sch (sch :/: sty) -> Term w sch ('DEnum sty choices)
fromSchema = Term w sch (sch :/: sty) -> Term w sch ('DEnum sty choices)
forall a. a -> a
id

-- | Conversion from Haskell type to schema term.
--   This version is intended for usage with @TypeApplications@:
--   > toSchema' @MySchema myValue
toSchema' :: forall fn tn (sch :: Schema tn fn) w t sty.
             ToSchema w sch sty t => t -> Term w sch (sch :/: sty)
toSchema' :: t -> Term w sch (sch :/: sty)
toSchema' = t -> Term w sch (sch :/: sty)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
ToSchema w sch sty t =>
t -> Term w sch (sch :/: sty)
toSchema
-- | Conversion from schema term to Haskell type.
--   This version is intended for usage with @TypeApplications@:
--   > fromSchema' @MySchema mySchemaTerm
fromSchema' :: forall fn tn (sch :: Schema tn fn) w t sty.
               FromSchema w sch sty t => Term w sch (sch :/: sty) -> t
fromSchema' :: Term w sch (sch :/: sty) -> t
fromSchema' = Term w sch (sch :/: sty) -> t
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
FromSchema w sch sty t =>
Term w sch (sch :/: sty) -> t
fromSchema

-- | By default, the names of the fields in the Haskell type
--   and those of the schema types must coincide. By using
--   this wrapper you can override this default setting.
--
--   This type should be used with @DerivingVia@, as follows:
--
--   > type MyCustomFieldMapping = '[ "A" ':-> "a", ...]
--   > data MyHaskellType = ...
--   >   deriving ( ToSchema   f MySchema "MySchemaType" MyHaskellType
--   >            , FromSchema f MySchema "MySchemaType" MyHaskellType)
--   >     via (CustomFieldMapping "MySchemaType" MyCustomFieldMapping MyHaskellType)
newtype CustomFieldMapping (sty :: typeName) (fmap :: [Mapping Symbol fieldName])  a
  = CustomFieldMapping a

instance (Generic t, GToSchemaTypeDef w sch fmap (sch :/: sty) (Rep t))
         => ToSchema w sch sty (CustomFieldMapping sty fmap t) where
  toSchema :: CustomFieldMapping sty fmap t -> Term w sch (sch :/: sty)
toSchema (CustomFieldMapping x :: t
x) = Proxy fmap -> Rep t Any -> Term w sch (sch :/: sty)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef w sch fmap t f =>
Proxy fmap -> f a -> Term w sch t
toSchemaTypeDef (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) (t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x)

instance (Generic t, GFromSchemaTypeDef w sch fmap (sch :/: sty) (Rep t))
         => FromSchema w sch sty (CustomFieldMapping sty fmap t) where
  fromSchema :: Term w sch (sch :/: sty) -> CustomFieldMapping sty fmap t
fromSchema x :: Term w sch (sch :/: sty)
x = t -> CustomFieldMapping sty fmap t
forall typeName fieldName (sty :: typeName)
       (fmap :: [Mapping Symbol fieldName]) a.
a -> CustomFieldMapping sty fmap a
CustomFieldMapping (t -> CustomFieldMapping sty fmap t)
-> t -> CustomFieldMapping sty fmap t
forall a b. (a -> b) -> a -> b
$ Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Proxy fmap -> Term w sch (sch :/: sty) -> Rep t Any
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef w sch fmap t f =>
Proxy fmap -> Term w sch t -> f a
fromSchemaTypeDef (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) Term w sch (sch :/: sty)
x)

-- | Changes the underlying wrapper of a Haskell type,
--   by converting back and forth 'Term's with those wrappers.
transSchema
  :: forall fn tn (sch :: Schema tn fn) sty u v a b.
     ( ToSchema u sch sty a, FromSchema v sch sty b
     , Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k) )
  => (forall x. u x -> v x) -> Proxy sch -> a -> b
transSchema :: (forall x. u x -> v x) -> Proxy sch -> a -> b
transSchema f :: forall x. u x -> v x
f _ = forall t. FromSchema v sch sty t => Term v sch (sch :/: sty) -> t
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
FromSchema w sch sty t =>
Term w sch (sch :/: sty) -> t
fromSchema @_ @_ @v @sch @sty (Term v sch (sch :/: sty) -> b)
-> (a -> Term v sch (sch :/: sty)) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. u x -> v x)
-> Term u sch (sch :/: sty) -> Term v sch (sch :/: sty)
forall tn fn (sch :: Schema tn fn) (t :: TypeDef tn fn)
       (u :: * -> *) (v :: * -> *).
(Functor u,
 forall (k :: FieldType tn).
 Ord (FieldValue u sch k) =>
 Ord (FieldValue v sch k)) =>
(forall a. u a -> v a) -> Term u sch t -> Term v sch t
transWrap forall x. u x -> v x
f (Term u sch (sch :/: sty) -> Term v sch (sch :/: sty))
-> (a -> Term u sch (sch :/: sty)) -> a -> Term v sch (sch :/: sty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ToSchema u sch sty t => t -> Term u sch (sch :/: sty)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
ToSchema w sch sty t =>
t -> Term w sch (sch :/: sty)
toSchema @_ @_ @u @sch @sty

-- ======================
-- CRAZY GENERICS SECTION
-- ======================

-- Auxiliary type families to find elements in lists
-- They return an indication of where the thing was found
--
-- Note: it turns out that GHC.Generics generates some weird
-- instances for records in the form (x :*: y) :*: z
-- and we cover them with the special HereLeft and HereRight
data Where = Here | HereLeft | HereRight | There Where

type family Find (xs :: [k]) (x :: k) :: Where where
  Find '[]       y = TypeError ('Text "Could not find " ':<>: 'ShowType y)
  Find (y ': xs) y = 'Here
  Find (x ': xs) y = 'There (Find xs y)

type family FindCon (xs :: * -> *) (x :: Symbol) :: Where where
  FindCon (C1 ('MetaCons x p s) f) x = 'Here
  FindCon (C1 ('MetaCons x p s) f :+: rest) x = 'Here
  FindCon (other :+: rest) x = 'There (FindCon rest x)
  FindCon nothing          x = TypeError ('Text "Could not find constructor " ':<>: 'ShowType x)

type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where
  FindSel (S1 ('MetaSel ('Just x) u ss ds) f) x = 'Here
  FindSel (S1 ('MetaSel ('Just x) u ss ds) f :*: rest) x = 'Here
  FindSel ((S1 ('MetaSel ('Just x) u ss ds) f :*: other) :*: rest) x = 'HereLeft
  FindSel ((other :*: S1 ('MetaSel ('Just x) u ss ds) f) :*: rest) x = 'HereRight
  FindSel (other :*: rest) x = 'There (FindSel rest x)
  FindSel nothing          x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x)

type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where
  FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x)
  FindEnumChoice ('ChoiceDef name ': xs) name = 'Here
  FindEnumChoice (other           ': xs) name = 'There (FindEnumChoice xs name)

type family FindField (xs :: [FieldDef ts fs]) (x :: fs) :: Where where
  FindField '[] x = TypeError ('Text "Could not find field " ':<>: 'ShowType x)
  FindField ('FieldDef name t ': xs) name = 'Here
  FindField (other            ': xs) name = 'There (FindField xs name)

-- Generic type definitions
class GToSchemaTypeDef
        (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
        (t :: TypeDef ts fs) (f :: * -> *) where
  toSchemaTypeDef   :: Proxy fmap -> f a -> Term w sch t
class GFromSchemaTypeDef
        (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
        (t :: TypeDef ts fs) (f :: * -> *) where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch t -> f a

-- ------------------
-- TYPES OF FIELDS --
-- ------------------

instance GToSchemaFieldTypeWrap w sch t f
         => GToSchemaTypeDef w sch fmap ('DSimple t) f where
  toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch ('DSimple t)
toSchemaTypeDef _ x :: f a
x = FieldValue w sch t -> Term w sch ('DSimple t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
FieldValue w sch t -> Term w sch ('DSimple t)
TSimple (f a -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW f a
x)
instance GFromSchemaFieldTypeWrap w sch t f
         => GFromSchemaTypeDef w sch fmap ('DSimple t) f where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DSimple t) -> f a
fromSchemaTypeDef _ (TSimple x :: FieldValue w sch t
x) = FieldValue w sch t -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch t
x

class GToSchemaFieldTypeWrap
        (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where
  toSchemaFieldTypeW   :: f a -> FieldValue w sch t
class GFromSchemaFieldTypeWrap
        (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where
  fromSchemaFieldTypeW :: FieldValue w sch t -> f a

instance GToSchemaFieldType w sch t f
         => GToSchemaFieldTypeWrap w sch t (K1 i f) where
  toSchemaFieldTypeW :: K1 i f a -> FieldValue w sch t
toSchemaFieldTypeW (K1 x :: f
x) = f -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType f
x
instance GFromSchemaFieldType w sch t f
         => GFromSchemaFieldTypeWrap w sch t (K1 i f) where
  fromSchemaFieldTypeW :: FieldValue w sch t -> K1 i f a
fromSchemaFieldTypeW x :: FieldValue w sch t
x = f -> K1 i f a
forall k i c (p :: k). c -> K1 i c p
K1 (FieldValue w sch t -> f
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType FieldValue w sch t
x)
instance GToSchemaFieldTypeWrap w sch t f
         => GToSchemaFieldTypeWrap w sch t (M1 s m f) where
  toSchemaFieldTypeW :: M1 s m f a -> FieldValue w sch t
toSchemaFieldTypeW (M1 x :: f a
x) = f a -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW f a
x
instance GFromSchemaFieldTypeWrap w sch t f
         => GFromSchemaFieldTypeWrap w sch t (M1 s m f) where
  fromSchemaFieldTypeW :: FieldValue w sch t -> M1 s m f a
fromSchemaFieldTypeW x :: FieldValue w sch t
x = f a -> M1 s m f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (FieldValue w sch t -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch t
x)

class GToSchemaFieldType
        (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where
  toSchemaFieldType   :: f -> FieldValue w sch t
class GFromSchemaFieldType
        (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where
  fromSchemaFieldType :: FieldValue w sch t -> f

class GToSchemaFieldTypeUnion
        (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where
  toSchemaFieldTypeUnion   :: f a -> NS (FieldValue w sch) t
class GFromSchemaFieldTypeUnion
        (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) t -> f a

-- These instances are straightforward,
-- just turn the "real types" into their
-- schema correspondants.
instance GToSchemaFieldType w sch 'TNull () where
  toSchemaFieldType :: () -> FieldValue w sch 'TNull
toSchemaFieldType _   = FieldValue w sch 'TNull
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName).
FieldValue w sch 'TNull
FNull
instance GFromSchemaFieldType w sch 'TNull () where
  fromSchemaFieldType :: FieldValue w sch 'TNull -> ()
fromSchemaFieldType _ = ()
instance GToSchemaFieldType w sch ('TPrimitive t) t where
  toSchemaFieldType :: t -> FieldValue w sch ('TPrimitive t)
toSchemaFieldType = t -> FieldValue w sch ('TPrimitive t)
forall typeName fieldName t (w :: * -> *)
       (sch :: Schema typeName fieldName).
t -> FieldValue w sch ('TPrimitive t)
FPrimitive
instance GFromSchemaFieldType w sch ('TPrimitive t) t where
  fromSchemaFieldType :: FieldValue w sch ('TPrimitive t) -> t
fromSchemaFieldType (FPrimitive x :: t
x) = t
t
x
-- These instances "tie the loop" with the whole schema,
-- and they are the reason why we need to thread the @sch@
-- type throghout the whole implementation.
instance ToSchema w sch t v
         => GToSchemaFieldType w sch ('TSchematic t) v where
  toSchemaFieldType :: v -> FieldValue w sch ('TSchematic t)
toSchemaFieldType x :: v
x = Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: typeName).
Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t)
FSchematic (Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t))
-> Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t)
forall a b. (a -> b) -> a -> b
$ v -> Term w sch (sch :/: t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
ToSchema w sch sty t =>
t -> Term w sch (sch :/: sty)
toSchema v
x
instance FromSchema w sch t v
         => GFromSchemaFieldType w sch ('TSchematic t) v where
  fromSchemaFieldType :: FieldValue w sch ('TSchematic t) -> v
fromSchemaFieldType (FSchematic x :: Term w sch (sch :/: t)
x) = Term w sch (sch :/: t) -> v
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
FromSchema w sch sty t =>
Term w sch (sch :/: sty) -> t
fromSchema Term w sch (sch :/: t)
Term w sch (sch :/: t)
x
instance GToSchemaFieldType w sch t v
         => GToSchemaFieldType w sch ('TOption t) (Maybe v) where
  toSchemaFieldType :: Maybe v -> FieldValue w sch ('TOption t)
toSchemaFieldType x :: Maybe v
x = Maybe (FieldValue w sch t) -> FieldValue w sch ('TOption t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
Maybe (FieldValue w sch t) -> FieldValue w sch ('TOption t)
FOption (v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> Maybe v -> Maybe (FieldValue w sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v
x)
instance GFromSchemaFieldType w sch t v
         => GFromSchemaFieldType w sch ('TOption t) (Maybe v) where
  fromSchemaFieldType :: FieldValue w sch ('TOption t) -> Maybe v
fromSchemaFieldType (FOption x :: Maybe (FieldValue w sch t)
x) = FieldValue w sch t -> v
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType (FieldValue w sch t -> v) -> Maybe (FieldValue w sch t) -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FieldValue w sch t)
x
instance GToSchemaFieldType w sch t v
         => GToSchemaFieldType w sch ('TList t) [v] where
  toSchemaFieldType :: [v] -> FieldValue w sch ('TList t)
toSchemaFieldType x :: [v]
x = [FieldValue w sch t] -> FieldValue w sch ('TList t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
[FieldValue w sch t] -> FieldValue w sch ('TList t)
FList (v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> [v] -> [FieldValue w sch t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
x)
instance GFromSchemaFieldType w sch t v
         => GFromSchemaFieldType w sch ('TList t) [v] where
  fromSchemaFieldType :: FieldValue w sch ('TList t) -> [v]
fromSchemaFieldType (FList x :: [FieldValue w sch t]
x) = FieldValue w sch t -> v
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType (FieldValue w sch t -> v) -> [FieldValue w sch t] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldValue w sch t]
x
instance (GToSchemaFieldType w sch sk hk, GToSchemaFieldType w sch sv hv,
          Ord (FieldValue w sch sk))  -- Ord is required to build a map
         => GToSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where
  toSchemaFieldType :: Map hk hv -> FieldValue w sch ('TMap sk sv)
toSchemaFieldType x :: Map hk hv
x = Map (FieldValue w sch sk) (FieldValue w sch sv)
-> FieldValue w sch ('TMap sk sv)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (k :: FieldType typeName)
       (v :: FieldType typeName).
Ord (FieldValue w sch k) =>
Map (FieldValue w sch k) (FieldValue w sch v)
-> FieldValue w sch ('TMap k v)
FMap ((hk -> FieldValue w sch sk)
-> Map hk (FieldValue w sch sv)
-> Map (FieldValue w sch sk) (FieldValue w sch sv)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys hk -> FieldValue w sch sk
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType ((hv -> FieldValue w sch sv)
-> Map hk hv -> Map hk (FieldValue w sch sv)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map hv -> FieldValue w sch sv
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType Map hk hv
x))
instance (GFromSchemaFieldType w sch sk hk, GFromSchemaFieldType w sch sv hv, Ord hk)
         => GFromSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where
  fromSchemaFieldType :: FieldValue w sch ('TMap sk sv) -> Map hk hv
fromSchemaFieldType (FMap x :: Map (FieldValue w sch k) (FieldValue w sch v)
x) = (FieldValue w sch k -> hk)
-> Map (FieldValue w sch k) hv -> Map hk hv
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys FieldValue w sch k -> hk
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType ((FieldValue w sch v -> hv)
-> Map (FieldValue w sch k) (FieldValue w sch v)
-> Map (FieldValue w sch k) hv
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FieldValue w sch v -> hv
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType Map (FieldValue w sch k) (FieldValue w sch v)
x)
-- This assumes that a union is represented by
-- a value of type 'NS', where types are in
-- the same order.
instance {-# OVERLAPS #-}
         AllZip (GToSchemaFieldType w sch) ts vs
         => GToSchemaFieldType w sch ('TUnion ts) (NS I vs) where
  toSchemaFieldType :: NS I vs -> FieldValue w sch ('TUnion ts)
toSchemaFieldType t :: NS I vs
t = NS (FieldValue w sch) ts -> FieldValue w sch ('TUnion ts)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue w sch) choices -> FieldValue w sch ('TUnion choices)
FUnion (NS I vs -> NS (FieldValue w sch) ts
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GToSchemaFieldType w sch) tss vss =>
NS I vss -> NS (FieldValue w sch) tss
go NS I vs
t)
    where go :: AllZip (GToSchemaFieldType w sch) tss vss
             => NS I vss -> NS (FieldValue w sch) tss
          go :: NS I vss -> NS (FieldValue w sch) tss
go (Z (I x :: x
x)) = FieldValue w sch (Head tss)
-> NS (FieldValue w sch) (Head tss : Tail tss)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (x -> FieldValue w sch (Head tss)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType x
x)
          go (S n :: NS I xs
n)     = NS (FieldValue w sch) (Tail tss)
-> NS (FieldValue w sch) (Head tss : Tail tss)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS I xs -> NS (FieldValue w sch) (Tail tss)
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GToSchemaFieldType w sch) tss vss =>
NS I vss -> NS (FieldValue w sch) tss
go NS I xs
n)
instance {-# OVERLAPS #-}
         AllZip (GFromSchemaFieldType w sch) ts vs
         => GFromSchemaFieldType w sch ('TUnion ts) (NS I vs) where
  fromSchemaFieldType :: FieldValue w sch ('TUnion ts) -> NS I vs
fromSchemaFieldType (FUnion t :: NS (FieldValue w sch) choices
t) = NS (FieldValue w sch) choices -> NS I vs
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GFromSchemaFieldType w sch) tss vss =>
NS (FieldValue w sch) tss -> NS I vss
go NS (FieldValue w sch) choices
t
    where go :: AllZip (GFromSchemaFieldType w sch) tss vss
             => NS (FieldValue w sch) tss -> NS I vss
          go :: NS (FieldValue w sch) tss -> NS I vss
go (Z x :: FieldValue w sch x
x) = I (Head vss) -> NS I (Head vss : Tail vss)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (Head vss -> I (Head vss)
forall a. a -> I a
I (FieldValue w sch x -> Head vss
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType FieldValue w sch x
x))
          go (S n :: NS (FieldValue w sch) xs
n) = NS I (Tail vss) -> NS I (Head vss : Tail vss)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (FieldValue w sch) xs -> NS I (Tail vss)
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GFromSchemaFieldType w sch) tss vss =>
NS (FieldValue w sch) tss -> NS I vss
go NS (FieldValue w sch) xs
n)
-- But we can also use any other if it has
-- the right structure
instance {-# OVERLAPPABLE #-}
         (Generic f, GToSchemaFieldTypeUnion w sch ts (Rep f))
         => GToSchemaFieldType w sch ('TUnion ts) f where
  toSchemaFieldType :: f -> FieldValue w sch ('TUnion ts)
toSchemaFieldType x :: f
x = NS (FieldValue w sch) ts -> FieldValue w sch ('TUnion ts)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue w sch) choices -> FieldValue w sch ('TUnion choices)
FUnion (Rep f Any -> NS (FieldValue w sch) ts
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GToSchemaFieldTypeUnion w sch t f =>
f a -> NS (FieldValue w sch) t
toSchemaFieldTypeUnion (f -> Rep f Any
forall a x. Generic a => a -> Rep a x
from f
x))
instance {-# OVERLAPPABLE #-}
         (Generic f, GFromSchemaFieldTypeUnion w sch ts (Rep f))
         => GFromSchemaFieldType w sch ('TUnion ts) f where
  fromSchemaFieldType :: FieldValue w sch ('TUnion ts) -> f
fromSchemaFieldType (FUnion x :: NS (FieldValue w sch) choices
x) = Rep f Any -> f
forall a x. Generic a => Rep a x -> a
to (NS (FieldValue w sch) choices -> Rep f Any
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GFromSchemaFieldTypeUnion w sch t f =>
NS (FieldValue w sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue w sch) choices
x)

instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion w sch '[] U1 where
  toSchemaFieldTypeUnion :: U1 a -> NS (FieldValue w sch) '[]
toSchemaFieldTypeUnion U1 = [Char] -> NS (FieldValue w sch) '[]
forall a. HasCallStack => [Char] -> a
error "this should never happen"
instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion w sch '[] U1 where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) '[] -> U1 a
fromSchemaFieldTypeUnion _ = U1 a
forall k (p :: k). U1 p
U1
instance {-# OVERLAPPABLE #-}
         TypeError ('Text "the type does not match the union")
         => GToSchemaFieldTypeUnion w sch '[] f where
  toSchemaFieldTypeUnion :: f a -> NS (FieldValue w sch) '[]
toSchemaFieldTypeUnion = [Char] -> f a -> NS (FieldValue w sch) '[]
forall a. HasCallStack => [Char] -> a
error "this should never happen"
instance {-# OVERLAPPABLE #-}
         TypeError ('Text "the type does not match the union")
         => GFromSchemaFieldTypeUnion w sch '[] f where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) '[] -> f a
fromSchemaFieldTypeUnion = [Char] -> NS (FieldValue w sch) '[] -> f a
forall a. HasCallStack => [Char] -> a
error "this should never happen"

instance (GToSchemaFieldTypeWrap w sch t v)
         => GToSchemaFieldTypeUnion w sch '[t] v where
  toSchemaFieldTypeUnion :: v a -> NS (FieldValue w sch) '[t]
toSchemaFieldTypeUnion   x :: v a
x     = FieldValue w sch t -> NS (FieldValue w sch) '[t]
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v a -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW v a
x)
instance (GFromSchemaFieldTypeWrap w sch t v)
         => GFromSchemaFieldTypeUnion w sch '[t] v where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) '[t] -> v a
fromSchemaFieldTypeUnion (Z x :: FieldValue w sch x
x) = FieldValue w sch x -> v a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch x
x
  fromSchemaFieldTypeUnion (S _) = [Char] -> v a
forall a. HasCallStack => [Char] -> a
error "this should never happen"
instance (GToSchemaFieldTypeWrap w sch t v, GToSchemaFieldTypeUnion w sch ts vs)
         => GToSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where
  toSchemaFieldTypeUnion :: (:+:) v vs a -> NS (FieldValue w sch) (t : ts)
toSchemaFieldTypeUnion (L1 x :: v a
x) = FieldValue w sch t -> NS (FieldValue w sch) (t : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v a -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW v a
x)
  toSchemaFieldTypeUnion (R1 r :: vs a
r) = NS (FieldValue w sch) ts -> NS (FieldValue w sch) (t : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (vs a -> NS (FieldValue w sch) ts
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GToSchemaFieldTypeUnion w sch t f =>
f a -> NS (FieldValue w sch) t
toSchemaFieldTypeUnion vs a
r)
instance (GFromSchemaFieldTypeWrap w sch t v, GFromSchemaFieldTypeUnion w sch ts vs)
         => GFromSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) (t : ts) -> (:+:) v vs a
fromSchemaFieldTypeUnion (Z x :: FieldValue w sch x
x) = v a -> (:+:) v vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (FieldValue w sch x -> v a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch x
x)
  fromSchemaFieldTypeUnion (S r :: NS (FieldValue w sch) xs
r) = vs a -> (:+:) v vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (NS (FieldValue w sch) xs -> vs a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GFromSchemaFieldTypeUnion w sch t f =>
NS (FieldValue w sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue w sch) xs
r)
-- Weird nested instance produced by GHC
instance ( GToSchemaFieldTypeWrap w sch t1 v1
         , GToSchemaFieldTypeWrap w sch t2 v2
         , GToSchemaFieldTypeUnion w sch ts vs )
         => GToSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
  toSchemaFieldTypeUnion :: (:+:) (v1 :+: v2) vs a -> NS (FieldValue w sch) (t1 : t2 : ts)
toSchemaFieldTypeUnion (L1 (L1 x :: v1 a
x)) = FieldValue w sch t1 -> NS (FieldValue w sch) (t1 : t2 : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v1 a -> FieldValue w sch t1
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW v1 a
x)
  toSchemaFieldTypeUnion (L1 (R1 x :: v2 a
x)) = NS (FieldValue w sch) (t2 : ts)
-> NS (FieldValue w sch) (t1 : t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (FieldValue w sch t2 -> NS (FieldValue w sch) (t2 : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v2 a -> FieldValue w sch t2
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GToSchemaFieldTypeWrap w sch t f =>
f a -> FieldValue w sch t
toSchemaFieldTypeW v2 a
x))
  toSchemaFieldTypeUnion (R1 r :: vs a
r)      = NS (FieldValue w sch) (t2 : ts)
-> NS (FieldValue w sch) (t1 : t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (FieldValue w sch) ts -> NS (FieldValue w sch) (t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (vs a -> NS (FieldValue w sch) ts
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GToSchemaFieldTypeUnion w sch t f =>
f a -> NS (FieldValue w sch) t
toSchemaFieldTypeUnion vs a
r))
instance ( GFromSchemaFieldTypeWrap w sch t1 v1
         , GFromSchemaFieldTypeWrap w sch t2 v2
         , GFromSchemaFieldTypeUnion w sch ts vs )
         => GFromSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
  fromSchemaFieldTypeUnion :: NS (FieldValue w sch) (t1 : t2 : ts) -> (:+:) (v1 :+: v2) vs a
fromSchemaFieldTypeUnion (Z x :: FieldValue w sch x
x)     = (:+:) v1 v2 a -> (:+:) (v1 :+: v2) vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (v1 a -> (:+:) v1 v2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (FieldValue w sch x -> v1 a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch x
x))
  fromSchemaFieldTypeUnion (S (Z x :: FieldValue w sch x
x)) = (:+:) v1 v2 a -> (:+:) (v1 :+: v2) vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (v2 a -> (:+:) v1 v2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (FieldValue w sch x -> v2 a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) a.
GFromSchemaFieldTypeWrap w sch t f =>
FieldValue w sch t -> f a
fromSchemaFieldTypeW FieldValue w sch x
x))
  fromSchemaFieldTypeUnion (S (S r :: NS (FieldValue w sch) xs
r)) = vs a -> (:+:) (v1 :+: v2) vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (NS (FieldValue w sch) xs -> vs a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: [FieldType ts]) (f :: * -> *) a.
GFromSchemaFieldTypeUnion w sch t f =>
NS (FieldValue w sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue w sch) xs
r)


-- ---------------
-- ENUMERATIONS --
------------------

instance {-# OVERLAPPABLE #-}
         (GToSchemaEnumDecompose fmap choices f)
         => GToSchemaTypeDef w sch fmap ('DEnum name choices) f where
  toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch ('DEnum name choices)
toSchemaTypeDef p :: Proxy fmap
p x :: f a
x = NS Proxy choices -> Term w sch ('DEnum name choices)
forall fieldName typeName (name :: [ChoiceDef fieldName])
       (w :: * -> *) (sch :: Schema typeName fieldName)
       (name :: typeName).
NS Proxy name -> Term w sch ('DEnum name name)
TEnum (Proxy fmap -> f a -> NS Proxy choices
forall fs (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs])
       (f :: * -> *) a.
GToSchemaEnumDecompose fmap choices f =>
Proxy fmap -> f a -> NS Proxy choices
toSchemaEnumDecomp Proxy fmap
p f a
x)
instance {-# OVERLAPPABLE #-}
         (GFromSchemaEnumDecompose fmap choices f)
         => GFromSchemaTypeDef w sch fmap ('DEnum name choices) f where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DEnum name choices) -> f a
fromSchemaTypeDef p :: Proxy fmap
p (TEnum x :: NS Proxy choices
x) = Proxy fmap -> NS Proxy choices -> f a
forall fs (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs])
       (f :: * -> *) a.
GFromSchemaEnumDecompose fmap choices f =>
Proxy fmap -> NS Proxy choices -> f a
fromSchemaEnumDecomp Proxy fmap
p NS Proxy choices
x
-- This instance removes unneeded metadata from the
-- top of the type.
instance {-# OVERLAPS #-}
         GToSchemaTypeDef w sch fmap ('DEnum name choices) f
         => GToSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> D1 meta f a -> Term w sch ('DEnum name choices)
toSchemaTypeDef p :: Proxy fmap
p (M1 x :: f a
x) = Proxy fmap -> f a -> Term w sch ('DEnum name choices)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef w sch fmap t f =>
Proxy fmap -> f a -> Term w sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef w sch fmap ('DEnum name choices) f
         => GFromSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DEnum name choices) -> D1 meta f a
fromSchemaTypeDef p :: Proxy fmap
p x :: Term w sch ('DEnum name choices)
x = f a -> D1 meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy fmap -> Term w sch ('DEnum name choices) -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef w sch fmap t f =>
Proxy fmap -> Term w sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term w sch ('DEnum name choices)
x)

-- 'toSchema' for enumerations:
-- 1. recursively decompose the (:+:)s into their atomic components
--    this is done by 'GToSchemaEnumSymbol'
-- 2. for each atomic component, figure out which is the element
--    in the schema's enumeration that it corresponds to
--    this is done by 'MappingRight' and 'Find'
-- 3. from that location, build a 'Proxy' value
--    this is done by 'GToSchemaEnumProxy'
class GToSchemaEnumDecompose (fmap :: Mappings Symbol fs)
                             (choices :: [ChoiceDef fs]) (f :: * -> *) where
  toSchemaEnumDecomp :: Proxy fmap -> f a -> NS Proxy choices
instance (GToSchemaEnumDecompose fmap choices oneway, GToSchemaEnumDecompose fmap choices oranother)
         => GToSchemaEnumDecompose fmap choices (oneway :+: oranother) where
  toSchemaEnumDecomp :: Proxy fmap -> (:+:) oneway oranother a -> NS Proxy choices
toSchemaEnumDecomp p :: Proxy fmap
p (L1 x :: oneway a
x) = Proxy fmap -> oneway a -> NS Proxy choices
forall fs (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs])
       (f :: * -> *) a.
GToSchemaEnumDecompose fmap choices f =>
Proxy fmap -> f a -> NS Proxy choices
toSchemaEnumDecomp Proxy fmap
p oneway a
x
  toSchemaEnumDecomp p :: Proxy fmap
p (R1 x :: oranother a
x) = Proxy fmap -> oranother a -> NS Proxy choices
forall fs (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs])
       (f :: * -> *) a.
GToSchemaEnumDecompose fmap choices f =>
Proxy fmap -> f a -> NS Proxy choices
toSchemaEnumDecomp Proxy fmap
p oranother a
x
instance GToSchemaEnumProxy choices (FindEnumChoice choices (MappingRight fmap c))
         => GToSchemaEnumDecompose fmap choices (C1 ('MetaCons c p s) f) where
  toSchemaEnumDecomp :: Proxy fmap -> C1 ('MetaCons c p s) f a -> NS Proxy choices
toSchemaEnumDecomp _ _
    = Proxy choices
-> Proxy (FindEnumChoice choices (MappingRight fmap c))
-> NS Proxy choices
forall k (choices :: [k]) (w :: Where).
GToSchemaEnumProxy choices w =>
Proxy choices -> Proxy w -> NS Proxy choices
toSchemaEnumProxy (Proxy choices
forall k (t :: k). Proxy t
Proxy @choices) (Proxy (FindEnumChoice choices (MappingRight fmap c))
forall k (t :: k). Proxy t
Proxy @(FindEnumChoice choices (MappingRight fmap c)))
-- Types which have no constructor information cannot be used here

class GToSchemaEnumProxy (choices :: [k]) (w :: Where) where
  toSchemaEnumProxy :: Proxy choices -> Proxy w -> NS Proxy choices
instance GToSchemaEnumProxy (c ': cs) 'Here where
  toSchemaEnumProxy :: Proxy (c : cs) -> Proxy 'Here -> NS Proxy (c : cs)
toSchemaEnumProxy _ _ = Proxy c -> NS Proxy (c : cs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z Proxy c
forall k (t :: k). Proxy t
Proxy
instance forall c cs w. GToSchemaEnumProxy cs w
         => GToSchemaEnumProxy (c ': cs) ('There w) where
  toSchemaEnumProxy :: Proxy (c : cs) -> Proxy ('There w) -> NS Proxy (c : cs)
toSchemaEnumProxy _ _ = NS Proxy cs -> NS Proxy (c : cs)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (Proxy cs -> Proxy w -> NS Proxy cs
forall k (choices :: [k]) (w :: Where).
GToSchemaEnumProxy choices w =>
Proxy choices -> Proxy w -> NS Proxy choices
toSchemaEnumProxy (Proxy cs
forall k (t :: k). Proxy t
Proxy @cs) (Proxy w
forall k (t :: k). Proxy t
Proxy @w))

-- 'fromSchema' for enumerations:
-- 1. for each element in the list of choices
--    (this iteration is done by 'GFromSchemaEnumDecomp')
--    figure out the constructor it corresponds to
--    this is done by 'MappingLeft' and 'FindCon'
-- 2. from that location, build a 'U1' value wrapped
--    in as many 'L1' and 'R1' required.
--    this is done by 'GFromSchemaEnumU1'
class GFromSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs]) (f :: * -> *) where
  fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy choices -> f a
instance GFromSchemaEnumDecompose fmap '[] f where
  fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy '[] -> f a
fromSchemaEnumDecomp _ _ = [Char] -> f a
forall a. HasCallStack => [Char] -> a
error "This should never happen"
instance (GFromSchemaEnumU1 f (FindCon f (MappingLeft fmap c)), GFromSchemaEnumDecompose fmap cs f)
         => GFromSchemaEnumDecompose fmap ('ChoiceDef c ': cs) f where
  fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy ('ChoiceDef c : cs) -> f a
fromSchemaEnumDecomp _ (Z _) = Proxy f -> Proxy (FindCon f (MappingLeft fmap c)) -> f a
forall (f :: * -> *) (w :: Where) a.
GFromSchemaEnumU1 f w =>
Proxy f -> Proxy w -> f a
fromSchemaEnumU1 (Proxy f
forall k (t :: k). Proxy t
Proxy @f) (Proxy (FindCon f (MappingLeft fmap c))
forall k (t :: k). Proxy t
Proxy @(FindCon f (MappingLeft fmap c)))
  fromSchemaEnumDecomp p :: Proxy fmap
p (S x :: NS Proxy xs
x) = Proxy fmap -> NS Proxy xs -> f a
forall fs (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs])
       (f :: * -> *) a.
GFromSchemaEnumDecompose fmap choices f =>
Proxy fmap -> NS Proxy choices -> f a
fromSchemaEnumDecomp Proxy fmap
p NS Proxy xs
x

class GFromSchemaEnumU1 (f :: * -> *) (w :: Where) where
  fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a
instance GFromSchemaEnumU1 (C1 m U1 :+: rest) 'Here where
  fromSchemaEnumU1 :: Proxy (C1 m U1 :+: rest) -> Proxy 'Here -> (:+:) (C1 m U1) rest a
fromSchemaEnumU1 _ _ = M1 C m U1 a -> (:+:) (C1 m U1) rest a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (U1 a -> M1 C m U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1)
instance GFromSchemaEnumU1 (C1 m U1) 'Here where
  fromSchemaEnumU1 :: Proxy (C1 m U1) -> Proxy 'Here -> C1 m U1 a
fromSchemaEnumU1 _ _ = U1 a -> C1 m U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1
instance forall other rest w. GFromSchemaEnumU1 rest w
         => GFromSchemaEnumU1 (other :+: rest) ('There w) where
  fromSchemaEnumU1 :: Proxy (other :+: rest) -> Proxy ('There w) -> (:+:) other rest a
fromSchemaEnumU1 _ _ = rest a -> (:+:) other rest a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Proxy rest -> Proxy w -> rest a
forall (f :: * -> *) (w :: Where) a.
GFromSchemaEnumU1 f w =>
Proxy f -> Proxy w -> f a
fromSchemaEnumU1 (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest) (Proxy w
forall k (t :: k). Proxy t
Proxy @w))

-- ----------
-- RECORDS --
-------------

instance {-# OVERLAPPABLE #-}
         (GToSchemaRecord w sch fmap args f)
         => GToSchemaTypeDef w sch fmap ('DRecord name args) f where
  toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch ('DRecord name args)
toSchemaTypeDef p :: Proxy fmap
p x :: f a
x = NP (Field w sch) args -> Term w sch ('DRecord name args)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field w sch) args -> Term w sch ('DRecord name args)
TRecord (Proxy fmap -> f a -> NP (Field w sch) args
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
       (f :: * -> *) a.
GToSchemaRecord w sch fmap args f =>
Proxy fmap -> f a -> NP (Field w sch) args
toSchemaRecord Proxy fmap
p f a
x)
instance {-# OVERLAPPABLE #-}
         (GFromSchemaRecord w sch fmap args f)
         => GFromSchemaTypeDef w sch fmap ('DRecord name args) f where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DRecord name args) -> f a
fromSchemaTypeDef p :: Proxy fmap
p (TRecord x :: NP (Field w sch) args
x) = Proxy fmap -> NP (Field w sch) args -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
       (f :: * -> *) a.
GFromSchemaRecord w sch fmap args f =>
Proxy fmap -> NP (Field w sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field w sch) args
x
-- This instance removes unneeded metadata from the
-- top of the type.
instance {-# OVERLAPS #-}
         GToSchemaTypeDef w sch fmap ('DRecord name args) f
         => GToSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> D1 meta f a -> Term w sch ('DRecord name args)
toSchemaTypeDef p :: Proxy fmap
p (M1 x :: f a
x) = Proxy fmap -> f a -> Term w sch ('DRecord name args)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef w sch fmap t f =>
Proxy fmap -> f a -> Term w sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef w sch fmap ('DRecord name args) f
         => GFromSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DRecord name args) -> D1 meta f a
fromSchemaTypeDef p :: Proxy fmap
p x :: Term w sch ('DRecord name args)
x = f a -> D1 meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy fmap -> Term w sch ('DRecord name args) -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef w sch fmap t f =>
Proxy fmap -> Term w sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term w sch ('DRecord name args)
x)
instance {-# OVERLAPS #-}
         GToSchemaTypeDef w sch fmap ('DRecord name args) f
         => GToSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> C1 meta f a -> Term w sch ('DRecord name args)
toSchemaTypeDef p :: Proxy fmap
p (M1 x :: f a
x) = Proxy fmap -> f a -> Term w sch ('DRecord name args)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef w sch fmap t f =>
Proxy fmap -> f a -> Term w sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef w sch fmap ('DRecord name args) f
         => GFromSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term w sch ('DRecord name args) -> C1 meta f a
fromSchemaTypeDef p :: Proxy fmap
p x :: Term w sch ('DRecord name args)
x = f a -> C1 meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy fmap -> Term w sch ('DRecord name args) -> f a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef w sch fmap t f =>
Proxy fmap -> Term w sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term w sch ('DRecord name args)
x)

-- 'toSchema' for records:
-- 1. iterate over each field in the schema of the record
--    this is done by 'GToSchemaRecord'
-- 2. figure out the selector (field) in the Haskell type
--    to which that record corresponds to
--    this is done by 'MappingLeft' and 'FindSel'
-- 3. using that location, obtain the value of the field
--    this is done by 'GToSchemaRecordSearch'
--
-- Due to some glitch in 'GHC.Generics', sometimes products
-- are not represented by a linear sequence of ':*:',
-- so we need to handle some cases in a special way
-- (see 'HereLeft' and 'HereRight' instances)

-- | For internal use only: generic conversion of a list of fields.
class GToSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
                      (args :: [FieldDef ts fs]) (f :: * -> *) where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) args
instance GToSchemaRecord w sch fmap '[] f where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) '[]
toSchemaRecord _ _ = NP (Field w sch) '[]
forall k (a :: k -> *). NP a '[]
Nil
instance ( GToSchemaRecord w sch fmap cs f
         , GToSchemaRecordSearch w sch t f (FindSel f (MappingLeft fmap name)) )
         => GToSchemaRecord w sch fmap ('FieldDef name t ': cs) f where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) ('FieldDef name t : cs)
toSchemaRecord p :: Proxy fmap
p x :: f a
x = Field w sch ('FieldDef name t)
this  Field w sch ('FieldDef name t)
-> NP (Field w sch) cs -> NP (Field w sch) ('FieldDef name t : cs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* Proxy fmap -> f a -> NP (Field w sch) cs
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
       (f :: * -> *) a.
GToSchemaRecord w sch fmap args f =>
Proxy fmap -> f a -> NP (Field w sch) args
toSchemaRecord Proxy fmap
p f a
x
    where this :: Field w sch ('FieldDef name t)
this = w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName)
       (name :: fieldName).
w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
Field (Proxy (FindSel f (MappingLeft fmap name))
-> f a -> w (FieldValue w sch t)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) (wh :: Where) a.
GToSchemaRecordSearch w sch t f wh =>
Proxy wh -> f a -> w (FieldValue w sch t)
toSchemaRecordSearch (Proxy (FindSel f (MappingLeft fmap name))
forall k (t :: k). Proxy t
Proxy @(FindSel f (MappingLeft fmap name))) f a
x)

class GToSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs)
                            (t :: FieldType ts) (f :: * -> *) (wh :: Where) where
  toSchemaRecordSearch :: Proxy wh -> f a -> w (FieldValue w sch t)
instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v
         => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v)) 'Here where
  toSchemaRecordSearch :: Proxy 'Here
-> S1 m (K1 i v) a -> Identity (FieldValue Identity sch t)
toSchemaRecordSearch _ (M1 (K1 x :: v
x)) = FieldValue Identity sch t -> Identity (FieldValue Identity sch t)
forall a. a -> Identity a
Identity (v -> FieldValue Identity sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType v
x)
instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)
         => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v))) 'Here where
  toSchemaRecordSearch :: Proxy 'Here -> S1 m (K1 i (w v)) a -> w (FieldValue w sch t)
toSchemaRecordSearch _ (M1 (K1 x :: w v
x)) = v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> w v -> w (FieldValue w sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w v
x
instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v
         => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v) :*: rest) 'Here where
  toSchemaRecordSearch :: Proxy 'Here
-> (:*:) (S1 m (K1 i v)) rest a
-> Identity (FieldValue Identity sch t)
toSchemaRecordSearch _ (M1 (K1 x :: v
x) :*: _) = FieldValue Identity sch t -> Identity (FieldValue Identity sch t)
forall a. a -> Identity a
Identity (v -> FieldValue Identity sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType v
x)
instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)
         => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v)) :*: rest) 'Here where
  toSchemaRecordSearch :: Proxy 'Here
-> (:*:) (S1 m (K1 i (w v))) rest a -> w (FieldValue w sch t)
toSchemaRecordSearch _ (M1 (K1 x :: w v
x) :*: _) = v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> w v -> w (FieldValue w sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w v
x
instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v
         => GToSchemaRecordSearch Identity sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where
  toSchemaRecordSearch :: Proxy 'HereLeft
-> (:*:) (S1 m (K1 i v) :*: other) rest a
-> Identity (FieldValue Identity sch t)
toSchemaRecordSearch _ ((M1 (K1 x :: v
x) :*: _) :*: _) = FieldValue Identity sch t -> Identity (FieldValue Identity sch t)
forall a. a -> Identity a
Identity (v -> FieldValue Identity sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType v
x)
instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)
         => GToSchemaRecordSearch w sch t ((S1 m (K1 i (w v)) :*: other) :*: rest) 'HereLeft where
  toSchemaRecordSearch :: Proxy 'HereLeft
-> (:*:) (S1 m (K1 i (w v)) :*: other) rest a
-> w (FieldValue w sch t)
toSchemaRecordSearch _ ((M1 (K1 x :: w v
x) :*: _) :*: _) = v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> w v -> w (FieldValue w sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w v
x
instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v
         => GToSchemaRecordSearch Identity sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where
  toSchemaRecordSearch :: Proxy 'HereRight
-> (:*:) (other :*: S1 m (K1 i v)) rest a
-> Identity (FieldValue Identity sch t)
toSchemaRecordSearch _ ((_ :*: M1 (K1 x :: v
x)) :*: _) = FieldValue Identity sch t -> Identity (FieldValue Identity sch t)
forall a. a -> Identity a
Identity (v -> FieldValue Identity sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType v
x)
instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)
         => GToSchemaRecordSearch w sch t ((other :*: S1 m (K1 i (w v))) :*: rest) 'HereRight where
  toSchemaRecordSearch :: Proxy 'HereRight
-> (:*:) (other :*: S1 m (K1 i (w v))) rest a
-> w (FieldValue w sch t)
toSchemaRecordSearch _ ((_ :*: M1 (K1 x :: w v
x)) :*: _) = v -> FieldValue w sch t
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GToSchemaFieldType w sch t f =>
f -> FieldValue w sch t
toSchemaFieldType (v -> FieldValue w sch t) -> w v -> w (FieldValue w sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w v
x
instance forall sch t other rest n w.
         GToSchemaRecordSearch w sch t rest n
         => GToSchemaRecordSearch w sch t (other :*: rest) ('There n) where
  toSchemaRecordSearch :: Proxy ('There n) -> (:*:) other rest a -> w (FieldValue w sch t)
toSchemaRecordSearch _ (_ :*: xs :: rest a
xs) = Proxy n -> rest a -> w (FieldValue w sch t)
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) (f :: * -> *) (wh :: Where) a.
GToSchemaRecordSearch w sch t f wh =>
Proxy wh -> f a -> w (FieldValue w sch t)
toSchemaRecordSearch (Proxy n
forall k (t :: k). Proxy t
Proxy @n) rest a
xs

-- 'fromSchema' for records
-- 1. decompose the sequence of products into atomic components
--    until we arrive to the selector metadata 'S1'
--    this is done by 'GFromSchemaRecord'
-- 2. figure out the field in the schema it corresponds to
--    this is done by 'MappingRight' and 'FindField'
-- 3. using that location, obtain the value of the field
--    this is done by 'GFromSchemaRecordSearch'
class GFromSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
                        (args :: [FieldDef ts fs]) (f :: * -> *) where
  fromSchemaRecord :: Proxy fmap -> NP (Field w sch) args -> f a
instance {-# OVERLAPS #-}
         (GFromSchemaRecordSearch Identity sch v args (FindField args (MappingRight fmap name)))
         => GFromSchemaRecord Identity sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where
  fromSchemaRecord :: Proxy fmap
-> NP (Field Identity sch) args
-> S1 ('MetaSel ('Just name) u ss ds) (K1 i v) a
fromSchemaRecord _ x :: NP (Field Identity sch) args
x = K1 i v a -> S1 ('MetaSel ('Just name) u ss ds) (K1 i v) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i v a -> S1 ('MetaSel ('Just name) u ss ds) (K1 i v) a)
-> K1 i v a -> S1 ('MetaSel ('Just name) u ss ds) (K1 i v) a
forall a b. (a -> b) -> a -> b
$ v -> K1 i v a
forall k i c (p :: k). c -> K1 i c p
K1 (v -> K1 i v a) -> v -> K1 i v a
forall a b. (a -> b) -> a -> b
$ Identity v -> v
forall a. Identity a -> a
runIdentity (Identity v -> v) -> Identity v -> v
forall a b. (a -> b) -> a -> b
$ Proxy (FindField args (MappingRight fmap name))
-> NP (Field Identity sch) args -> Identity v
forall ts fs (w :: * -> *) (sch :: Schema ts fs) v
       (args :: [FieldDef ts fs]) (wh :: Where).
GFromSchemaRecordSearch w sch v args wh =>
Proxy wh -> NP (Field w sch) args -> w v
fromSchemaRecordSearch (Proxy (FindField args (MappingRight fmap name))
forall k (t :: k). Proxy t
Proxy @(FindField args (MappingRight fmap name))) NP (Field Identity sch) args
x
instance {-# OVERLAPPABLE #-}
         (GFromSchemaRecordSearch w sch v args (FindField args (MappingRight fmap name)))
         => GFromSchemaRecord w sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v))) where
  fromSchemaRecord :: Proxy fmap
-> NP (Field w sch) args
-> S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v)) a
fromSchemaRecord _ x :: NP (Field w sch) args
x = K1 i (w v) a -> S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i (w v) a -> S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v)) a)
-> K1 i (w v) a
-> S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v)) a
forall a b. (a -> b) -> a -> b
$ w v -> K1 i (w v) a
forall k i c (p :: k). c -> K1 i c p
K1 (w v -> K1 i (w v) a) -> w v -> K1 i (w v) a
forall a b. (a -> b) -> a -> b
$ Proxy (FindField args (MappingRight fmap name))
-> NP (Field w sch) args -> w v
forall ts fs (w :: * -> *) (sch :: Schema ts fs) v
       (args :: [FieldDef ts fs]) (wh :: Where).
GFromSchemaRecordSearch w sch v args wh =>
Proxy wh -> NP (Field w sch) args -> w v
fromSchemaRecordSearch (Proxy (FindField args (MappingRight fmap name))
forall k (t :: k). Proxy t
Proxy @(FindField args (MappingRight fmap name))) NP (Field w sch) args
x
instance ( GFromSchemaRecord w sch fmap args oneway
         , GFromSchemaRecord w sch fmap args oranother )
         => GFromSchemaRecord w sch fmap args (oneway :*: oranother) where
  fromSchemaRecord :: Proxy fmap -> NP (Field w sch) args -> (:*:) oneway oranother a
fromSchemaRecord p :: Proxy fmap
p x :: NP (Field w sch) args
x =  Proxy fmap -> NP (Field w sch) args -> oneway a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
       (f :: * -> *) a.
GFromSchemaRecord w sch fmap args f =>
Proxy fmap -> NP (Field w sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field w sch) args
x oneway a -> oranother a -> (:*:) oneway oranother a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Proxy fmap -> NP (Field w sch) args -> oranother a
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
       (f :: * -> *) a.
GFromSchemaRecord w sch fmap args f =>
Proxy fmap -> NP (Field w sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field w sch) args
x
instance GFromSchemaRecord w sch fmap args U1 where
  fromSchemaRecord :: Proxy fmap -> NP (Field w sch) args -> U1 a
fromSchemaRecord _ _ = U1 a
forall k (p :: k). U1 p
U1

class GFromSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs)
                              (v :: *) (args :: [FieldDef ts fs]) (wh :: Where) where
  fromSchemaRecordSearch :: Proxy wh -> NP (Field w sch) args -> w v
instance (Functor w, GFromSchemaFieldType w sch t v)
         => GFromSchemaRecordSearch w sch v ('FieldDef name t ': rest) 'Here where
  fromSchemaRecordSearch :: Proxy 'Here -> NP (Field w sch) ('FieldDef name t : rest) -> w v
fromSchemaRecordSearch _ (Field x :: w (FieldValue w sch t)
x :* _) = FieldValue w sch t -> v
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
       (t :: FieldType ts) f.
GFromSchemaFieldType w sch t f =>
FieldValue w sch t -> f
fromSchemaFieldType (FieldValue w sch t -> v) -> w (FieldValue w sch t) -> w v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (FieldValue w sch t)
x
instance forall sch v other rest n w.
         GFromSchemaRecordSearch w sch v rest n
         => GFromSchemaRecordSearch w sch v (other ': rest) ('There n) where
  fromSchemaRecordSearch :: Proxy ('There n) -> NP (Field w sch) (other : rest) -> w v
fromSchemaRecordSearch _ (_ :* xs :: NP (Field w sch) xs
xs) = Proxy n -> NP (Field w sch) xs -> w v
forall ts fs (w :: * -> *) (sch :: Schema ts fs) v
       (args :: [FieldDef ts fs]) (wh :: Where).
GFromSchemaRecordSearch w sch v args wh =>
Proxy wh -> NP (Field w sch) args -> w v
fromSchemaRecordSearch (Proxy n
forall k (t :: k). Proxy t
Proxy @n) NP (Field w sch) xs
xs