{-# 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   MySchema "MySchemaType" MyHaskellType
>            , FromSchema 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
, Underlying(..), UnderlyingConversion(..)
  -- * Internal use only
, GToSchemaRecord(..)
) where

import qualified Data.ByteString          as BS
import qualified Data.ByteString.Lazy     as BL
import           Data.Kind
import           Data.Map                 as M
import           Data.Maybe               (fromJust)
import           Data.SOP
import qualified Data.Text                as T
import qualified Data.UUID                as U
import           GHC.Generics
import           GHC.TypeLits

import           Fcf                      (Eval, Exp, Pure)
import           Fcf.Data.List            (Snoc)
import           Mu.Schema.Definition
import           Mu.Schema.Interpretation

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

-- | Accessor for 'WithSchema'.
--   Intended for usage with @TypeApplications@.
unWithSchema :: forall tn fn (sch :: Schema tn fn) (sty :: tn) a.
                WithSchema sch sty a -> a
unWithSchema :: WithSchema sch sty a -> a
unWithSchema (WithSchema 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 (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)
      | sch t -> sty where
  -- | Conversion from Haskell type to schema term.
  toSchema   :: t -> Term sch (sch :/: sty)

  default
    toSchema :: (Generic t, GToSchemaTypeDef sch '[] (sch :/: sty) (Rep t))
              => t -> Term sch (sch :/: sty)
  toSchema t
x = Proxy '[] -> Rep t Any -> Term sch (sch :/: sty)
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef sch fmap t f =>
Proxy fmap -> f a -> Term 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 (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)
      | sch t -> sty where
  -- | Conversion from schema term to Haskell type.
  fromSchema :: Term sch (sch :/: sty) -> t

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

instance (sch :/: sty ~ 'DRecord sty fields)
         => ToSchema sch sty (Term sch ('DRecord sty fields)) where
  toSchema :: Term sch ('DRecord sty fields) -> Term sch (sch :/: sty)
toSchema = Term sch ('DRecord sty fields) -> Term sch (sch :/: sty)
forall a. a -> a
id
instance (sch :/: sty ~ 'DEnum sty choices)
         => ToSchema sch sty (Term sch ('DEnum sty choices)) where
  toSchema :: Term sch ('DEnum sty choices) -> Term sch (sch :/: sty)
toSchema = Term sch ('DEnum sty choices) -> Term sch (sch :/: sty)
forall a. a -> a
id
instance (sch :/: sty ~ 'DRecord sty fields)
         => FromSchema sch sty (Term sch ('DRecord sty fields)) where
  fromSchema :: Term sch (sch :/: sty) -> Term sch ('DRecord sty fields)
fromSchema = Term sch (sch :/: sty) -> Term sch ('DRecord sty fields)
forall a. a -> a
id
instance (sch :/: sty ~ 'DEnum sty choices)
         => FromSchema sch sty (Term sch ('DEnum sty choices)) where
  fromSchema :: Term sch (sch :/: sty) -> Term sch ('DEnum sty choices)
fromSchema = Term sch (sch :/: sty) -> Term 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) t sty.
             ToSchema sch sty t => t -> Term sch (sch :/: sty)
toSchema' :: t -> Term sch (sch :/: sty)
toSchema' = t -> Term sch (sch :/: sty)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (sty :: typeName) t.
ToSchema sch sty t =>
t -> Term 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) t sty.
               FromSchema sch sty t => Term sch (sch :/: sty) -> t
fromSchema' :: Term sch (sch :/: sty) -> t
fromSchema' = Term sch (sch :/: sty) -> t
forall typeName fieldName (sch :: Schema typeName fieldName)
       (sty :: typeName) t.
FromSchema sch sty t =>
Term 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 sch fmap (sch :/: sty) (Rep t))
         => ToSchema sch sty (CustomFieldMapping sty fmap t) where
  toSchema :: CustomFieldMapping sty fmap t -> Term sch (sch :/: sty)
toSchema (CustomFieldMapping t
x) = Proxy fmap -> Rep t Any -> Term sch (sch :/: sty)
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef sch fmap t f =>
Proxy fmap -> f a -> Term 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 sch fmap (sch :/: sty) (Rep t))
         => FromSchema sch sty (CustomFieldMapping sty fmap t) where
  fromSchema :: Term sch (sch :/: sty) -> CustomFieldMapping sty fmap t
fromSchema Term 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 sch (sch :/: sty) -> Rep t Any
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef sch fmap t f =>
Proxy fmap -> Term sch t -> f a
fromSchemaTypeDef (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) Term sch (sch :/: sty)
x)

-- | This 'newtype' is used to wrap types for which
--   we want a "logical" representation as a Haskell
--   type, but the underlying representation is
--   lower level, like 'UUID's as 'ByteString's.
newtype Underlying basic logical
  = Underlying { Underlying basic logical -> logical
unUnderlying :: logical }
  deriving (Int -> Underlying basic logical -> ShowS
[Underlying basic logical] -> ShowS
Underlying basic logical -> String
(Int -> Underlying basic logical -> ShowS)
-> (Underlying basic logical -> String)
-> ([Underlying basic logical] -> ShowS)
-> Show (Underlying basic logical)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (basic :: k) logical.
Show logical =>
Int -> Underlying basic logical -> ShowS
forall k (basic :: k) logical.
Show logical =>
[Underlying basic logical] -> ShowS
forall k (basic :: k) logical.
Show logical =>
Underlying basic logical -> String
showList :: [Underlying basic logical] -> ShowS
$cshowList :: forall k (basic :: k) logical.
Show logical =>
[Underlying basic logical] -> ShowS
show :: Underlying basic logical -> String
$cshow :: forall k (basic :: k) logical.
Show logical =>
Underlying basic logical -> String
showsPrec :: Int -> Underlying basic logical -> ShowS
$cshowsPrec :: forall k (basic :: k) logical.
Show logical =>
Int -> Underlying basic logical -> ShowS
Show, Underlying basic logical -> Underlying basic logical -> Bool
(Underlying basic logical -> Underlying basic logical -> Bool)
-> (Underlying basic logical -> Underlying basic logical -> Bool)
-> Eq (Underlying basic logical)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (basic :: k) logical.
Eq logical =>
Underlying basic logical -> Underlying basic logical -> Bool
/= :: Underlying basic logical -> Underlying basic logical -> Bool
$c/= :: forall k (basic :: k) logical.
Eq logical =>
Underlying basic logical -> Underlying basic logical -> Bool
== :: Underlying basic logical -> Underlying basic logical -> Bool
$c== :: forall k (basic :: k) logical.
Eq logical =>
Underlying basic logical -> Underlying basic logical -> Bool
Eq)

-- | This class defines the actual conversion between
--   a "logical" type and its low-level representation.
class UnderlyingConversion basic logical where
  toUnderlying   :: logical -> basic
  fromUnderlying :: basic -> logical

instance UnderlyingConversion String U.UUID where
  toUnderlying :: UUID -> String
toUnderlying   = UUID -> String
U.toString
  fromUnderlying :: String -> UUID
fromUnderlying = Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> UUID) -> (String -> Maybe UUID) -> String -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe UUID
U.fromString
instance UnderlyingConversion T.Text U.UUID where
  toUnderlying :: UUID -> Text
toUnderlying   = UUID -> Text
U.toText
  fromUnderlying :: Text -> UUID
fromUnderlying = Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> UUID) -> (Text -> Maybe UUID) -> Text -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe UUID
U.fromText
instance UnderlyingConversion BL.ByteString U.UUID where
  toUnderlying :: UUID -> ByteString
toUnderlying   = UUID -> ByteString
U.toByteString
  fromUnderlying :: ByteString -> UUID
fromUnderlying = Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> UUID)
-> (ByteString -> Maybe UUID) -> ByteString -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
U.fromByteString
instance UnderlyingConversion BS.ByteString U.UUID where
  toUnderlying :: UUID -> ByteString
toUnderlying   = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (UUID -> ByteString) -> UUID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteString
U.toByteString
  fromUnderlying :: ByteString -> UUID
fromUnderlying = Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> UUID)
-> (ByteString -> Maybe UUID) -> ByteString -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
U.fromByteString (ByteString -> Maybe UUID)
-> (ByteString -> ByteString) -> ByteString -> Maybe UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict

-- ======================
-- 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 | There Where
data WhereStep = StepNoMore | StepLeft | StepRight

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) :: [WhereStep] where
  FindCon xs x = WhenEmpty
                    (FindCon' '[] xs x)
                    (TypeError ('Text "Could not find constructor " ':<>: 'ShowType x))

type family FindCon' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
  FindCon' acc (C1 ('MetaCons x p s) f) x = Eval (Snoc acc 'StepNoMore)
  FindCon' acc (left :+: right) x = WhenEmpty
                                      (FindCon' (Eval (Snoc acc 'StepLeft)) left x)
                                      (Pure (FindCon' (Eval (Snoc acc 'StepRight)) right x))
  FindCon' acc other x = '[]

type family WhenEmpty (left :: [a]) (right :: Exp [a]) :: [a] where
  WhenEmpty '[] b = Eval b
  WhenEmpty a _ = a

type family FindSel (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
  FindSel xs x = WhenEmpty
                    (FindSel' '[] xs x)
                    (TypeError ('Text "Could not find field " ':<>: 'ShowType x))

type family FindSel' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
  FindSel' acc (S1 ('MetaSel ('Just x) u ss ds) f) x = Eval (Snoc acc 'StepNoMore)
  FindSel' acc (left :*: right) x = WhenEmpty
                                      (FindSel' (Eval (Snoc acc 'StepLeft)) left x)
                                      (Pure (FindSel' (Eval (Snoc acc 'StepRight)) right x))
  FindSel' acc other 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
        (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
        (t :: TypeDef ts fs) (f :: * -> *) where
  toSchemaTypeDef   :: Proxy fmap -> f a -> Term sch t
class GFromSchemaTypeDef
        (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
        (t :: TypeDef ts fs) (f :: * -> *) where
  fromSchemaTypeDef :: Proxy fmap -> Term sch t -> f a

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

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

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

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

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

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

-- These instances are straightforward,
-- just turn the "real types" into their
-- schema correspondants.
instance GToSchemaFieldType sch 'TNull () where
  toSchemaFieldType :: () -> FieldValue sch 'TNull
toSchemaFieldType ()
_   = FieldValue sch 'TNull
forall typeName fieldName (sch :: Schema typeName fieldName).
FieldValue sch 'TNull
FNull
instance GFromSchemaFieldType sch 'TNull () where
  fromSchemaFieldType :: FieldValue sch 'TNull -> ()
fromSchemaFieldType FieldValue sch 'TNull
_ = ()
instance (UnderlyingConversion t l)
         => GToSchemaFieldType sch ('TPrimitive t) (Underlying t l) where
  toSchemaFieldType :: Underlying t l -> FieldValue sch ('TPrimitive t)
toSchemaFieldType = t -> FieldValue sch ('TPrimitive t)
forall typeName fieldName t (sch :: Schema typeName fieldName).
t -> FieldValue sch ('TPrimitive t)
FPrimitive (t -> FieldValue sch ('TPrimitive t))
-> (Underlying t l -> t)
-> Underlying t l
-> FieldValue sch ('TPrimitive t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> t
forall basic logical.
UnderlyingConversion basic logical =>
logical -> basic
toUnderlying (l -> t) -> (Underlying t l -> l) -> Underlying t l -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Underlying t l -> l
forall k (basic :: k) logical. Underlying basic logical -> logical
unUnderlying
instance (UnderlyingConversion t l)
         => GFromSchemaFieldType sch ('TPrimitive t) (Underlying t l) where
  fromSchemaFieldType :: FieldValue sch ('TPrimitive t) -> Underlying t l
fromSchemaFieldType (FPrimitive t
x) = l -> Underlying t l
forall k (basic :: k) logical. logical -> Underlying basic logical
Underlying (t -> l
forall basic logical.
UnderlyingConversion basic logical =>
basic -> logical
fromUnderlying t
x)
instance GToSchemaFieldType sch ('TPrimitive t) t where
  toSchemaFieldType :: t -> FieldValue sch ('TPrimitive t)
toSchemaFieldType = t -> FieldValue sch ('TPrimitive t)
forall typeName fieldName t (sch :: Schema typeName fieldName).
t -> FieldValue sch ('TPrimitive t)
FPrimitive
instance GFromSchemaFieldType sch ('TPrimitive t) t where
  fromSchemaFieldType :: FieldValue sch ('TPrimitive t) -> t
fromSchemaFieldType (FPrimitive 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 sch t v
         => GToSchemaFieldType sch ('TSchematic t) v where
  toSchemaFieldType :: v -> FieldValue sch ('TSchematic t)
toSchemaFieldType v
x = Term sch (sch :/: t) -> FieldValue sch ('TSchematic t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: typeName).
Term sch (sch :/: t) -> FieldValue sch ('TSchematic t)
FSchematic (Term sch (sch :/: t) -> FieldValue sch ('TSchematic t))
-> Term sch (sch :/: t) -> FieldValue sch ('TSchematic t)
forall a b. (a -> b) -> a -> b
$ v -> Term sch (sch :/: t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (sty :: typeName) t.
ToSchema sch sty t =>
t -> Term sch (sch :/: sty)
toSchema v
x
instance FromSchema sch t v
         => GFromSchemaFieldType sch ('TSchematic t) v where
  fromSchemaFieldType :: FieldValue sch ('TSchematic t) -> v
fromSchemaFieldType (FSchematic Term sch (sch :/: t)
x) = Term sch (sch :/: t) -> v
forall typeName fieldName (sch :: Schema typeName fieldName)
       (sty :: typeName) t.
FromSchema sch sty t =>
Term sch (sch :/: sty) -> t
fromSchema Term sch (sch :/: t)
Term sch (sch :/: t)
x
instance GToSchemaFieldType sch t v
         => GToSchemaFieldType sch ('TOption t) (Maybe v) where
  toSchemaFieldType :: Maybe v -> FieldValue sch ('TOption t)
toSchemaFieldType Maybe v
x = Maybe (FieldValue sch t) -> FieldValue sch ('TOption t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName).
Maybe (FieldValue sch t) -> FieldValue sch ('TOption t)
FOption (v -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType (v -> FieldValue sch t) -> Maybe v -> Maybe (FieldValue sch t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v
x)
instance GFromSchemaFieldType sch t v
         => GFromSchemaFieldType sch ('TOption t) (Maybe v) where
  fromSchemaFieldType :: FieldValue sch ('TOption t) -> Maybe v
fromSchemaFieldType (FOption Maybe (FieldValue sch t)
x) = FieldValue sch t -> v
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GFromSchemaFieldType sch t f =>
FieldValue sch t -> f
fromSchemaFieldType (FieldValue sch t -> v) -> Maybe (FieldValue sch t) -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FieldValue sch t)
x
instance GToSchemaFieldType sch t v
         => GToSchemaFieldType sch ('TList t) [v] where
  toSchemaFieldType :: [v] -> FieldValue sch ('TList t)
toSchemaFieldType [v]
x = [FieldValue sch t] -> FieldValue sch ('TList t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName).
[FieldValue sch t] -> FieldValue sch ('TList t)
FList (v -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType (v -> FieldValue sch t) -> [v] -> [FieldValue sch t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
x)
instance GFromSchemaFieldType sch t v
         => GFromSchemaFieldType sch ('TList t) [v] where
  fromSchemaFieldType :: FieldValue sch ('TList t) -> [v]
fromSchemaFieldType (FList [FieldValue sch t]
x) = FieldValue sch t -> v
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GFromSchemaFieldType sch t f =>
FieldValue sch t -> f
fromSchemaFieldType (FieldValue sch t -> v) -> [FieldValue sch t] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldValue sch t]
x
instance (GToSchemaFieldType sch sk hk, GToSchemaFieldType sch sv hv,
          Ord (FieldValue sch sk))  -- Ord is required to build a map
         => GToSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where
  toSchemaFieldType :: Map hk hv -> FieldValue sch ('TMap sk sv)
toSchemaFieldType Map hk hv
x = Map (FieldValue sch sk) (FieldValue sch sv)
-> FieldValue sch ('TMap sk sv)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (k :: FieldType typeName) (v :: FieldType typeName).
Ord (FieldValue sch k) =>
Map (FieldValue sch k) (FieldValue sch v)
-> FieldValue sch ('TMap k v)
FMap ((hk -> FieldValue sch sk)
-> Map hk (FieldValue sch sv)
-> Map (FieldValue sch sk) (FieldValue sch sv)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys hk -> FieldValue sch sk
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType ((hv -> FieldValue sch sv)
-> Map hk hv -> Map hk (FieldValue sch sv)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map hv -> FieldValue sch sv
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType Map hk hv
x))
instance (GFromSchemaFieldType sch sk hk, GFromSchemaFieldType sch sv hv, Ord hk)
         => GFromSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where
  fromSchemaFieldType :: FieldValue sch ('TMap sk sv) -> Map hk hv
fromSchemaFieldType (FMap Map (FieldValue sch k) (FieldValue sch v)
x) = (FieldValue sch k -> hk) -> Map (FieldValue sch k) hv -> Map hk hv
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys FieldValue sch k -> hk
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GFromSchemaFieldType sch t f =>
FieldValue sch t -> f
fromSchemaFieldType ((FieldValue sch v -> hv)
-> Map (FieldValue sch k) (FieldValue sch v)
-> Map (FieldValue sch k) hv
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FieldValue sch v -> hv
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GFromSchemaFieldType sch t f =>
FieldValue sch t -> f
fromSchemaFieldType Map (FieldValue sch k) (FieldValue 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 sch) ts vs
         => GToSchemaFieldType sch ('TUnion ts) (NS I vs) where
  toSchemaFieldType :: NS I vs -> FieldValue sch ('TUnion ts)
toSchemaFieldType NS I vs
t = NS (FieldValue sch) ts -> FieldValue sch ('TUnion ts)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue sch) choices -> FieldValue sch ('TUnion choices)
FUnion (NS I vs -> NS (FieldValue sch) ts
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GToSchemaFieldType sch) tss vss =>
NS I vss -> NS (FieldValue sch) tss
go NS I vs
t)
    where go :: AllZip (GToSchemaFieldType sch) tss vss
             => NS I vss -> NS (FieldValue sch) tss
          go :: NS I vss -> NS (FieldValue sch) tss
go (Z (I x
x)) = FieldValue sch (Head tss)
-> NS (FieldValue sch) (Head tss : Tail tss)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (x -> FieldValue sch (Head tss)
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType x
x)
          go (S NS I xs
n)     = NS (FieldValue sch) (Tail tss)
-> NS (FieldValue 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 sch) (Tail tss)
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GToSchemaFieldType sch) tss vss =>
NS I vss -> NS (FieldValue sch) tss
go NS I xs
n)
instance {-# OVERLAPS #-}
         AllZip (GFromSchemaFieldType sch) ts vs
         => GFromSchemaFieldType sch ('TUnion ts) (NS I vs) where
  fromSchemaFieldType :: FieldValue sch ('TUnion ts) -> NS I vs
fromSchemaFieldType (FUnion NS (FieldValue sch) choices
t) = NS (FieldValue sch) choices -> NS I vs
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GFromSchemaFieldType sch) tss vss =>
NS (FieldValue sch) tss -> NS I vss
go NS (FieldValue sch) choices
t
    where go :: AllZip (GFromSchemaFieldType sch) tss vss
             => NS (FieldValue sch) tss -> NS I vss
          go :: NS (FieldValue sch) tss -> NS I vss
go (Z FieldValue 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 sch x -> Head vss
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GFromSchemaFieldType sch t f =>
FieldValue sch t -> f
fromSchemaFieldType FieldValue sch x
x))
          go (S NS (FieldValue 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 sch) xs -> NS I (Tail vss)
forall (tss :: [FieldType typeName]) (vss :: [*]).
AllZip (GFromSchemaFieldType sch) tss vss =>
NS (FieldValue sch) tss -> NS I vss
go NS (FieldValue sch) xs
n)
-- But we can also use any other if it has
-- the right structure
instance {-# OVERLAPPABLE #-}
         (Generic f, GToSchemaFieldTypeUnion sch ts (Rep f))
         => GToSchemaFieldType sch ('TUnion ts) f where
  toSchemaFieldType :: f -> FieldValue sch ('TUnion ts)
toSchemaFieldType f
x = NS (FieldValue sch) ts -> FieldValue sch ('TUnion ts)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue sch) choices -> FieldValue sch ('TUnion choices)
FUnion (Rep f Any -> NS (FieldValue sch) ts
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GToSchemaFieldTypeUnion sch t f =>
f a -> NS (FieldValue sch) t
toSchemaFieldTypeUnion (f -> Rep f Any
forall a x. Generic a => a -> Rep a x
from f
x))
instance {-# OVERLAPPABLE #-}
         (Generic f, GFromSchemaFieldTypeUnion sch ts (Rep f))
         => GFromSchemaFieldType sch ('TUnion ts) f where
  fromSchemaFieldType :: FieldValue sch ('TUnion ts) -> f
fromSchemaFieldType (FUnion NS (FieldValue sch) choices
x) = Rep f Any -> f
forall a x. Generic a => Rep a x -> a
to (NS (FieldValue sch) choices -> Rep f Any
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GFromSchemaFieldTypeUnion sch t f =>
NS (FieldValue sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue sch) choices
x)

instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion sch '[] U1 where
  toSchemaFieldTypeUnion :: U1 a -> NS (FieldValue sch) '[]
toSchemaFieldTypeUnion U1 a
U1 = String -> NS (FieldValue sch) '[]
forall a. HasCallStack => String -> a
error String
"this should never happen"
instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion sch '[] U1 where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) '[] -> U1 a
fromSchemaFieldTypeUnion NS (FieldValue sch) '[]
_ = U1 a
forall k (p :: k). U1 p
U1
instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion sch '[] (M1 i t U1) where
  toSchemaFieldTypeUnion :: M1 i t U1 a -> NS (FieldValue sch) '[]
toSchemaFieldTypeUnion (M1 U1 a
U1) = String -> NS (FieldValue sch) '[]
forall a. HasCallStack => String -> a
error String
"this should never happen"
instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion sch '[] (M1 i t U1) where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) '[] -> M1 i t U1 a
fromSchemaFieldTypeUnion NS (FieldValue sch) '[]
_ = U1 a -> M1 i t 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 {-# OVERLAPPABLE #-}
         TypeError ('Text "the type does not match the union")
         => GToSchemaFieldTypeUnion sch '[] f where
  toSchemaFieldTypeUnion :: f a -> NS (FieldValue sch) '[]
toSchemaFieldTypeUnion = String -> f a -> NS (FieldValue sch) '[]
forall a. HasCallStack => String -> a
error String
"this should never happen"
instance {-# OVERLAPPABLE #-}
         TypeError ('Text "the type does not match the union")
         => GFromSchemaFieldTypeUnion sch '[] f where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) '[] -> f a
fromSchemaFieldTypeUnion = String -> NS (FieldValue sch) '[] -> f a
forall a. HasCallStack => String -> a
error String
"this should never happen"

instance (GToSchemaFieldTypeWrap sch t v)
         => GToSchemaFieldTypeUnion sch '[t] v where
  toSchemaFieldTypeUnion :: v a -> NS (FieldValue sch) '[t]
toSchemaFieldTypeUnion   v a
x     = FieldValue sch t -> NS (FieldValue sch) '[t]
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v a -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GToSchemaFieldTypeWrap sch t f =>
f a -> FieldValue sch t
toSchemaFieldTypeW v a
x)
instance (GFromSchemaFieldTypeWrap sch t v)
         => GFromSchemaFieldTypeUnion sch '[t] v where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) '[t] -> v a
fromSchemaFieldTypeUnion (Z FieldValue sch x
x) = FieldValue sch x -> v a
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GFromSchemaFieldTypeWrap sch t f =>
FieldValue sch t -> f a
fromSchemaFieldTypeW FieldValue sch x
x
  fromSchemaFieldTypeUnion (S NS (FieldValue sch) xs
_) = String -> v a
forall a. HasCallStack => String -> a
error String
"this should never happen"

-- remove M1 from thing with more than one element
instance {-# OVERLAPS #-} (GToSchemaFieldTypeUnion sch (a ': b ': rest) v)
         => GToSchemaFieldTypeUnion sch (a ': b ': rest) (M1 i t v) where
  toSchemaFieldTypeUnion :: M1 i t v a -> NS (FieldValue sch) (a : b : rest)
toSchemaFieldTypeUnion (M1 v a
x) = v a -> NS (FieldValue sch) (a : b : rest)
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GToSchemaFieldTypeUnion sch t f =>
f a -> NS (FieldValue sch) t
toSchemaFieldTypeUnion v a
x
instance {-# OVERLAPS #-} (GFromSchemaFieldTypeUnion sch (a ': b ': rest) v)
         => GFromSchemaFieldTypeUnion sch (a ': b ': rest) (M1 i t v) where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) (a : b : rest) -> M1 i t v a
fromSchemaFieldTypeUnion NS (FieldValue sch) (a : b : rest)
x = v a -> M1 i t v a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (NS (FieldValue sch) (a : b : rest) -> v a
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GFromSchemaFieldTypeUnion sch t f =>
NS (FieldValue sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue sch) (a : b : rest)
x)

instance (GToSchemaFieldTypeWrap sch t v, GToSchemaFieldTypeUnion sch ts vs)
         => GToSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where
  toSchemaFieldTypeUnion :: (:+:) v vs a -> NS (FieldValue sch) (t : ts)
toSchemaFieldTypeUnion (L1 v a
x) = FieldValue sch t -> NS (FieldValue sch) (t : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v a -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GToSchemaFieldTypeWrap sch t f =>
f a -> FieldValue sch t
toSchemaFieldTypeW v a
x)
  toSchemaFieldTypeUnion (R1 vs a
r) = NS (FieldValue sch) ts -> NS (FieldValue sch) (t : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (vs a -> NS (FieldValue sch) ts
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GToSchemaFieldTypeUnion sch t f =>
f a -> NS (FieldValue sch) t
toSchemaFieldTypeUnion vs a
r)
instance (GFromSchemaFieldTypeWrap sch t v, GFromSchemaFieldTypeUnion sch ts vs)
         => GFromSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) (t : ts) -> (:+:) v vs a
fromSchemaFieldTypeUnion (Z FieldValue sch x
x) = v a -> (:+:) v vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (FieldValue sch x -> v a
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GFromSchemaFieldTypeWrap sch t f =>
FieldValue sch t -> f a
fromSchemaFieldTypeW FieldValue sch x
x)
  fromSchemaFieldTypeUnion (S NS (FieldValue sch) xs
r) = vs a -> (:+:) v vs a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (NS (FieldValue sch) xs -> vs a
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GFromSchemaFieldTypeUnion sch t f =>
NS (FieldValue sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue sch) xs
r)
-- Weird nested instance produced by GHC
instance ( GToSchemaFieldTypeWrap sch t1 v1
         , GToSchemaFieldTypeWrap sch t2 v2
         , GToSchemaFieldTypeUnion sch ts vs )
         => GToSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
  toSchemaFieldTypeUnion :: (:+:) (v1 :+: v2) vs a -> NS (FieldValue sch) (t1 : t2 : ts)
toSchemaFieldTypeUnion (L1 (L1 v1 a
x)) = FieldValue sch t1 -> NS (FieldValue sch) (t1 : t2 : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v1 a -> FieldValue sch t1
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GToSchemaFieldTypeWrap sch t f =>
f a -> FieldValue sch t
toSchemaFieldTypeW v1 a
x)
  toSchemaFieldTypeUnion (L1 (R1 v2 a
x)) = NS (FieldValue sch) (t2 : ts) -> NS (FieldValue sch) (t1 : t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (FieldValue sch t2 -> NS (FieldValue sch) (t2 : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (v2 a -> FieldValue sch t2
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GToSchemaFieldTypeWrap sch t f =>
f a -> FieldValue sch t
toSchemaFieldTypeW v2 a
x))
  toSchemaFieldTypeUnion (R1 vs a
r)      = NS (FieldValue sch) (t2 : ts) -> NS (FieldValue sch) (t1 : t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (FieldValue sch) ts -> NS (FieldValue sch) (t2 : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (vs a -> NS (FieldValue sch) ts
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GToSchemaFieldTypeUnion sch t f =>
f a -> NS (FieldValue sch) t
toSchemaFieldTypeUnion vs a
r))
instance ( GFromSchemaFieldTypeWrap sch t1 v1
         , GFromSchemaFieldTypeWrap sch t2 v2
         , GFromSchemaFieldTypeUnion sch ts vs )
         => GFromSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
  fromSchemaFieldTypeUnion :: NS (FieldValue sch) (t1 : t2 : ts) -> (:+:) (v1 :+: v2) vs a
fromSchemaFieldTypeUnion (Z FieldValue 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 sch x -> v1 a
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GFromSchemaFieldTypeWrap sch t f =>
FieldValue sch t -> f a
fromSchemaFieldTypeW FieldValue sch x
x))
  fromSchemaFieldTypeUnion (S (Z FieldValue 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 sch x -> v2 a
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) a.
GFromSchemaFieldTypeWrap sch t f =>
FieldValue sch t -> f a
fromSchemaFieldTypeW FieldValue sch x
x))
  fromSchemaFieldTypeUnion (S (S NS (FieldValue 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 sch) xs -> vs a
forall ts fs (sch :: Schema ts fs) (t :: [FieldType ts])
       (f :: * -> *) a.
GFromSchemaFieldTypeUnion sch t f =>
NS (FieldValue sch) t -> f a
fromSchemaFieldTypeUnion NS (FieldValue sch) xs
r)


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

instance {-# OVERLAPPABLE #-}
         (GToSchemaEnumDecompose fmap choices f)
         => GToSchemaTypeDef sch fmap ('DEnum name choices) f where
  toSchemaTypeDef :: Proxy fmap -> f a -> Term sch ('DEnum name choices)
toSchemaTypeDef Proxy fmap
p f a
x = NS Proxy choices -> Term sch ('DEnum name choices)
forall fieldName typeName (name :: [ChoiceDef fieldName])
       (sch :: Schema typeName fieldName) (name :: typeName).
NS Proxy name -> Term 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 sch fmap ('DEnum name choices) f where
  fromSchemaTypeDef :: Proxy fmap -> Term sch ('DEnum name choices) -> f a
fromSchemaTypeDef Proxy fmap
p (TEnum 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 sch fmap ('DEnum name choices) f
         => GToSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> D1 meta f a -> Term sch ('DEnum name choices)
toSchemaTypeDef Proxy fmap
p (M1 f a
x) = Proxy fmap -> f a -> Term sch ('DEnum name choices)
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef sch fmap t f =>
Proxy fmap -> f a -> Term sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef sch fmap ('DEnum name choices) f
         => GFromSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term sch ('DEnum name choices) -> D1 meta f a
fromSchemaTypeDef Proxy fmap
p Term 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 sch ('DEnum name choices) -> f a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef sch fmap t f =>
Proxy fmap -> Term sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term 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 Proxy fmap
p (L1 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 Proxy fmap
p (R1 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 fmap
_ C1 ('MetaCons c p s) f a
_
    = 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 : cs)
_ Proxy 'Here
_ = 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 Proxy (c : cs)
_ Proxy ('There w)
_ = 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 Proxy fmap
_ NS Proxy '[]
_ = String -> f a
forall a. HasCallStack => String -> a
error String
"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 Proxy fmap
_ (Z Proxy x
_) = Proxy f
-> Proxy
     (WhenEmpty (FindCon' '[] f (MappingLeft fmap c)) (TypeError ...))
-> f a
forall (f :: * -> *) (w :: [WhereStep]) 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 Proxy fmap
p (S 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 :: [WhereStep]) where
  fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a
instance GFromSchemaEnumU1 (C1 m U1) '[ 'StepNoMore ] where
  fromSchemaEnumU1 :: Proxy (C1 m U1) -> Proxy '[ 'StepNoMore] -> C1 m U1 a
fromSchemaEnumU1 Proxy (C1 m U1)
_ Proxy '[ 'StepNoMore]
_ = 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 GFromSchemaEnumU1 left rest => GFromSchemaEnumU1 (left :+: right) ('StepLeft ': rest) where
  fromSchemaEnumU1 :: Proxy (left :+: right)
-> Proxy ('StepLeft : rest) -> (:+:) left right a
fromSchemaEnumU1 Proxy (left :+: right)
_ Proxy ('StepLeft : rest)
_ = left a -> (:+:) left right a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Proxy left -> Proxy rest -> left a
forall (f :: * -> *) (w :: [WhereStep]) a.
GFromSchemaEnumU1 f w =>
Proxy f -> Proxy w -> f a
fromSchemaEnumU1 (Proxy left
forall k (t :: k). Proxy t
Proxy @left) (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest))
instance GFromSchemaEnumU1 right rest => GFromSchemaEnumU1 (left :+: right) ('StepRight ': rest) where
  fromSchemaEnumU1 :: Proxy (left :+: right)
-> Proxy ('StepRight : rest) -> (:+:) left right a
fromSchemaEnumU1 Proxy (left :+: right)
_ Proxy ('StepRight : rest)
_ = right a -> (:+:) left right a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Proxy right -> Proxy rest -> right a
forall (f :: * -> *) (w :: [WhereStep]) a.
GFromSchemaEnumU1 f w =>
Proxy f -> Proxy w -> f a
fromSchemaEnumU1 (Proxy right
forall k (t :: k). Proxy t
Proxy @right) (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest))

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

instance {-# OVERLAPPABLE #-}
         (GToSchemaRecord sch fmap args f)
         => GToSchemaTypeDef sch fmap ('DRecord name args) f where
  toSchemaTypeDef :: Proxy fmap -> f a -> Term sch ('DRecord name args)
toSchemaTypeDef Proxy fmap
p f a
x = NP (Field sch) args -> Term sch ('DRecord name args)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (Proxy fmap -> f a -> NP (Field sch) args
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GToSchemaRecord sch fmap args f =>
Proxy fmap -> f a -> NP (Field sch) args
toSchemaRecord Proxy fmap
p f a
x)
instance {-# OVERLAPPABLE #-}
         (GFromSchemaRecord sch fmap args f)
         => GFromSchemaTypeDef sch fmap ('DRecord name args) f where
  fromSchemaTypeDef :: Proxy fmap -> Term sch ('DRecord name args) -> f a
fromSchemaTypeDef Proxy fmap
p (TRecord NP (Field sch) args
x) = Proxy fmap -> NP (Field sch) args -> f a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GFromSchemaRecord sch fmap args f =>
Proxy fmap -> NP (Field sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field sch) args
x
-- This instance removes unneeded metadata from the
-- top of the type.
instance {-# OVERLAPS #-}
         GToSchemaTypeDef sch fmap ('DRecord name args) f
         => GToSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> D1 meta f a -> Term sch ('DRecord name args)
toSchemaTypeDef Proxy fmap
p (M1 f a
x) = Proxy fmap -> f a -> Term sch ('DRecord name args)
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef sch fmap t f =>
Proxy fmap -> f a -> Term sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef sch fmap ('DRecord name args) f
         => GFromSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term sch ('DRecord name args) -> D1 meta f a
fromSchemaTypeDef Proxy fmap
p Term 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 sch ('DRecord name args) -> f a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef sch fmap t f =>
Proxy fmap -> Term sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term sch ('DRecord name args)
x)
instance {-# OVERLAPS #-}
         GToSchemaTypeDef sch fmap ('DRecord name args) f
         => GToSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where
  toSchemaTypeDef :: Proxy fmap -> C1 meta f a -> Term sch ('DRecord name args)
toSchemaTypeDef Proxy fmap
p (M1 f a
x) = Proxy fmap -> f a -> Term sch ('DRecord name args)
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GToSchemaTypeDef sch fmap t f =>
Proxy fmap -> f a -> Term sch t
toSchemaTypeDef Proxy fmap
p f a
x
instance {-# OVERLAPS #-}
         GFromSchemaTypeDef sch fmap ('DRecord name args) f
         => GFromSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where
  fromSchemaTypeDef :: Proxy fmap -> Term sch ('DRecord name args) -> C1 meta f a
fromSchemaTypeDef Proxy fmap
p Term 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 sch ('DRecord name args) -> f a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (t :: TypeDef ts fs) (f :: * -> *) a.
GFromSchemaTypeDef sch fmap t f =>
Proxy fmap -> Term sch t -> f a
fromSchemaTypeDef Proxy fmap
p Term 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 (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
                      (args :: [FieldDef ts fs]) (f :: * -> *) where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field sch) args
instance GToSchemaRecord sch fmap '[] f where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field sch) '[]
toSchemaRecord Proxy fmap
_ f a
_ = NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil
instance ( GToSchemaRecord sch fmap cs f
         , GToSchemaRecordSearch sch t f (FindSel f (MappingLeft fmap name)) )
         => GToSchemaRecord sch fmap ('FieldDef name t ': cs) f where
  toSchemaRecord :: Proxy fmap -> f a -> NP (Field sch) ('FieldDef name t : cs)
toSchemaRecord Proxy fmap
p f a
x = Field sch ('FieldDef name t)
this Field sch ('FieldDef name t)
-> NP (Field sch) cs -> NP (Field 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 sch) cs
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GToSchemaRecord sch fmap args f =>
Proxy fmap -> f a -> NP (Field sch) args
toSchemaRecord Proxy fmap
p f a
x
    where this :: Field sch ('FieldDef name t)
this = FieldValue sch t -> Field sch ('FieldDef name t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (Proxy
  (WhenEmpty
     (FindSel' '[] f (MappingLeft fmap name)) (TypeError ...))
-> f a -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) (wh :: [WhereStep]) a.
GToSchemaRecordSearch sch t f wh =>
Proxy wh -> f a -> FieldValue 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 (sch :: Schema ts fs)
                            (t :: FieldType ts) (f :: * -> *) (wh :: [WhereStep]) where
  toSchemaRecordSearch :: Proxy wh -> f a -> FieldValue sch t
instance GToSchemaFieldType sch t v
         => GToSchemaRecordSearch sch t (S1 m (K1 i v)) '[ 'StepNoMore ] where
  toSchemaRecordSearch :: Proxy '[ 'StepNoMore] -> S1 m (K1 i v) a -> FieldValue sch t
toSchemaRecordSearch Proxy '[ 'StepNoMore]
_ (M1 (K1 v
x)) = v -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts) f.
GToSchemaFieldType sch t f =>
f -> FieldValue sch t
toSchemaFieldType v
x
instance forall sch t left right n.
         GToSchemaRecordSearch sch t left n
         => GToSchemaRecordSearch sch t (left :*: right) ('StepLeft ': n) where
  toSchemaRecordSearch :: Proxy ('StepLeft : n) -> (:*:) left right a -> FieldValue sch t
toSchemaRecordSearch Proxy ('StepLeft : n)
_ (left a
xs :*: right a
_) = Proxy n -> left a -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) (wh :: [WhereStep]) a.
GToSchemaRecordSearch sch t f wh =>
Proxy wh -> f a -> FieldValue sch t
toSchemaRecordSearch (Proxy n
forall k (t :: k). Proxy t
Proxy @n) left a
xs
instance forall sch t left right n.
         GToSchemaRecordSearch sch t right n
         => GToSchemaRecordSearch sch t (left :*: right) ('StepRight ': n) where
  toSchemaRecordSearch :: Proxy ('StepRight : n) -> (:*:) left right a -> FieldValue sch t
toSchemaRecordSearch Proxy ('StepRight : n)
_ (left a
_ :*: right a
xs) = Proxy n -> right a -> FieldValue sch t
forall ts fs (sch :: Schema ts fs) (t :: FieldType ts)
       (f :: * -> *) (wh :: [WhereStep]) a.
GToSchemaRecordSearch sch t f wh =>
Proxy wh -> f a -> FieldValue sch t
toSchemaRecordSearch (Proxy n
forall k (t :: k). Proxy t
Proxy @n) right 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 (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
                        (args :: [FieldDef ts fs]) (f :: * -> *) where
  fromSchemaRecord :: Proxy fmap -> NP (Field sch) args -> f a
instance (GFromSchemaRecordSearch sch v args (FindField args (MappingRight fmap name)))
         => GFromSchemaRecord sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where
  fromSchemaRecord :: Proxy fmap
-> NP (Field sch) args
-> S1 ('MetaSel ('Just name) u ss ds) (K1 i v) a
fromSchemaRecord Proxy fmap
_ NP (Field 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
$ Proxy (FindField args (MappingRight fmap name))
-> NP (Field sch) args -> v
forall ts fs (sch :: Schema ts fs) v (args :: [FieldDef ts fs])
       (wh :: Where).
GFromSchemaRecordSearch sch v args wh =>
Proxy wh -> NP (Field sch) args -> v
fromSchemaRecordSearch (Proxy (FindField args (MappingRight fmap name))
forall k (t :: k). Proxy t
Proxy @(FindField args (MappingRight fmap name))) NP (Field sch) args
x
instance ( GFromSchemaRecord sch fmap args oneway
         , GFromSchemaRecord sch fmap args oranother )
         => GFromSchemaRecord sch fmap args (oneway :*: oranother) where
  fromSchemaRecord :: Proxy fmap -> NP (Field sch) args -> (:*:) oneway oranother a
fromSchemaRecord Proxy fmap
p NP (Field sch) args
x =  Proxy fmap -> NP (Field sch) args -> oneway a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GFromSchemaRecord sch fmap args f =>
Proxy fmap -> NP (Field sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field 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 sch) args -> oranother a
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GFromSchemaRecord sch fmap args f =>
Proxy fmap -> NP (Field sch) args -> f a
fromSchemaRecord Proxy fmap
p NP (Field sch) args
x
instance GFromSchemaRecord sch fmap args U1 where
  fromSchemaRecord :: Proxy fmap -> NP (Field sch) args -> U1 a
fromSchemaRecord Proxy fmap
_ NP (Field sch) args
_ = U1 a
forall k (p :: k). U1 p
U1

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