{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Generic.Fields
  ( DecoderFun (..),
    DecodeFields,
    decodeFields,
    CountFields (..),
  )
where

import Data.Morpheus.Generic.Proxy
  ( selNameP,
  )
import Data.Morpheus.Types.Internal.AST (FieldName)
import GHC.Generics
import Relude

class CountFields (f :: Type -> Type) where
  countFields :: Proxy f -> Int

instance (CountFields f, CountFields g) => CountFields (f :*: g) where
  countFields :: Proxy (f :*: g) -> Int
countFields Proxy (f :*: g)
_ = Proxy f -> Int
forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @f) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy g -> Int
forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @g)

instance (Selector s) => CountFields (M1 S s (K1 i a)) where
  countFields :: Proxy (M1 S s (K1 i a)) -> Int
countFields Proxy (M1 S s (K1 i a))
_ = Int
1

instance CountFields U1 where
  countFields :: Proxy U1 -> Int
countFields Proxy U1
_ = Int
0

newtype DecoderFun con m = DecoderFun {forall (con :: * -> Constraint) (m :: * -> *).
DecoderFun con m -> forall a. con a => FieldName -> m a
decoderFun :: forall a. (con a) => FieldName -> m a}

decodeFields :: (Monad m, DecodeFields con f) => DecoderFun con m -> m (f a)
decodeFields :: forall (m :: * -> *) (con :: * -> Constraint) (f :: * -> *) a.
(Monad m, DecodeFields con f) =>
DecoderFun con m -> m (f a)
decodeFields DecoderFun con m
ctx = DecoderFun con m -> Int -> m (f a)
forall (m :: * -> *) a.
Monad m =>
DecoderFun con m -> Int -> m (f a)
forall (con :: * -> Constraint) (f :: * -> *) (m :: * -> *) a.
(DecodeFields con f, Monad m) =>
DecoderFun con m -> Int -> m (f a)
decodeFieldsWith DecoderFun con m
ctx Int
0

class DecodeFields con (f :: Type -> Type) where
  decodeFieldsWith :: (Monad m) => DecoderFun con m -> Int -> m (f a)

instance (DecodeFields val f, DecodeFields val g, CountFields g) => DecodeFields val (f :*: g) where
  decodeFieldsWith :: forall (m :: * -> *) a.
Monad m =>
DecoderFun val m -> Int -> m ((:*:) f g a)
decodeFieldsWith DecoderFun val m
ctx Int
index =
    f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
      (f a -> g a -> (:*:) f g a) -> m (f a) -> m (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecoderFun val m -> Int -> m (f a)
forall (m :: * -> *) a.
Monad m =>
DecoderFun val m -> Int -> m (f a)
forall (con :: * -> Constraint) (f :: * -> *) (m :: * -> *) a.
(DecodeFields con f, Monad m) =>
DecoderFun con m -> Int -> m (f a)
decodeFieldsWith DecoderFun val m
ctx Int
index
      m (g a -> (:*:) f g a) -> m (g a) -> m ((:*:) f g a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DecoderFun val m -> Int -> m (g a)
forall (m :: * -> *) a.
Monad m =>
DecoderFun val m -> Int -> m (g a)
forall (con :: * -> Constraint) (f :: * -> *) (m :: * -> *) a.
(DecodeFields con f, Monad m) =>
DecoderFun con m -> Int -> m (f a)
decodeFieldsWith DecoderFun val m
ctx (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy g -> Int
forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @g))

instance (Selector s, con a) => DecodeFields con (M1 S s (K1 i a)) where
  decodeFieldsWith :: forall (m :: * -> *) a.
Monad m =>
DecoderFun con m -> Int -> m (M1 S s (K1 i a) a)
decodeFieldsWith DecoderFun con m
ctx Int
index = K1 i a a -> M1 S s (K1 i a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a a -> M1 S s (K1 i a) a)
-> (a -> K1 i a a) -> a -> M1 S s (K1 i a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 i a) a) -> m a -> m (M1 S s (K1 i a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecoderFun con m -> forall a. con a => FieldName -> m a
forall (con :: * -> Constraint) (m :: * -> *).
DecoderFun con m -> forall a. con a => FieldName -> m a
decoderFun DecoderFun con m
ctx (FieldName -> Int -> FieldName
getFieldName (Proxy s -> FieldName
forall (f :: Meta -> *) t (s :: Meta).
(Selector s, IsString t) =>
f s -> t
selNameP (forall {k} (t :: k). Proxy t
forall (t :: Meta). Proxy t
Proxy @s)) Int
index)

instance DecodeFields val U1 where
  decodeFieldsWith :: forall (m :: * -> *) a.
Monad m =>
DecoderFun val m -> Int -> m (U1 a)
decodeFieldsWith DecoderFun val m
_ Int
_ = U1 a -> m (U1 a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1

getFieldName :: FieldName -> Int -> FieldName
getFieldName :: FieldName -> Int -> FieldName
getFieldName FieldName
"" Int
index = FieldName
"_" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> Int -> FieldName
forall b a. (Show a, IsString b) => a -> b
show Int
index
getFieldName FieldName
label Int
_ = FieldName
label