{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Composite.Dhall.CoRecord () where

import Composite.CoRecord hiding (Op)
import Composite.Record
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Vinyl
import qualified Dhall as D
import GHC.TypeLits

class FromDhallUnion x where
  autoWithU :: D.InputNormalizer -> D.UnionDecoder x

instance (KnownSymbol s, D.FromDhall x) => FromDhallUnion (s :-> x) where
  autoWithU :: InputNormalizer -> UnionDecoder (s :-> x)
autoWithU InputNormalizer
opts =
    let nL :: (s :-> a)
        nL :: s :-> a
nL = s :-> a
forall a. HasCallStack => a
undefined
     in Text -> Decoder (s :-> x) -> UnionDecoder (s :-> x)
forall a. Text -> Decoder a -> UnionDecoder a
D.constructor ((s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName s :-> Any
forall a. s :-> a
nL) (forall a. a -> s :-> a
forall (s :: Symbol) a. a -> s :-> a
Val @s (x -> s :-> x) -> Decoder x -> Decoder (s :-> x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputNormalizer -> Decoder x
forall a. FromDhall a => InputNormalizer -> Decoder a
D.autoWith InputNormalizer
opts)

instance FromDhallUnion (Field '[]) where
  autoWithU :: InputNormalizer -> UnionDecoder (Field '[])
autoWithU = UnionDecoder (Field '[])
-> InputNormalizer -> UnionDecoder (Field '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnionDecoder (Field '[])
 -> InputNormalizer -> UnionDecoder (Field '[]))
-> UnionDecoder (Field '[])
-> InputNormalizer
-> UnionDecoder (Field '[])
forall a b. (a -> b) -> a -> b
$ Compose (Map Text) Decoder (Field '[]) -> UnionDecoder (Field '[])
forall a. Compose (Map Text) Decoder a -> UnionDecoder a
D.UnionDecoder (Compose (Map Text) Decoder (Field '[])
 -> UnionDecoder (Field '[]))
-> Compose (Map Text) Decoder (Field '[])
-> UnionDecoder (Field '[])
forall a b. (a -> b) -> a -> b
$ Map Text (Decoder (Field '[]))
-> Compose (Map Text) Decoder (Field '[])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Map Text (Decoder (Field '[]))
forall a. Monoid a => a
mempty

instance FromDhallUnion x => FromDhallUnion (Identity x) where
  autoWithU :: InputNormalizer -> UnionDecoder (Identity x)
autoWithU InputNormalizer
opts = x -> Identity x
forall a. a -> Identity a
Identity (x -> Identity x) -> UnionDecoder x -> UnionDecoder (Identity x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputNormalizer -> UnionDecoder x
forall x. FromDhallUnion x => InputNormalizer -> UnionDecoder x
autoWithU InputNormalizer
opts

instance (RMap xs, RecApplicative xs, FoldRec (s :-> x ': xs) (s :-> x ': xs), xs ⊆ (s :-> x ': xs), KnownSymbol s, FromDhallUnion (Field xs), D.FromDhall x) => D.FromDhall (Field (s :-> x ': xs)) where
  autoWith :: InputNormalizer -> Decoder (Field ((s :-> x) : xs))
autoWith InputNormalizer
opts = UnionDecoder (Field ((s :-> x) : xs))
-> Decoder (Field ((s :-> x) : xs))
forall a. UnionDecoder a -> Decoder a
D.union (UnionDecoder (Field ((s :-> x) : xs))
 -> Decoder (Field ((s :-> x) : xs)))
-> UnionDecoder (Field ((s :-> x) : xs))
-> Decoder (Field ((s :-> x) : xs))
forall a b. (a -> b) -> a -> b
$ InputNormalizer -> UnionDecoder (Field ((s :-> x) : xs))
forall x. FromDhallUnion x => InputNormalizer -> UnionDecoder x
autoWithU InputNormalizer
opts

instance (RMap xs, RecApplicative xs, KnownSymbol s, D.FromDhall x, xs ⊆ (s :-> x ': xs), FoldRec (s :-> x ': xs) (s :-> x ': xs), FromDhallUnion (Field xs)) => FromDhallUnion (Field (s :-> x ': xs)) where
  autoWithU :: InputNormalizer -> UnionDecoder (Field ((s :-> x) : xs))
autoWithU InputNormalizer
opts =
    let k :: Field xs -> Field (s :-> x ': xs)
        k :: Field xs -> Field ((s :-> x) : xs)
k = Field xs -> Field ((s :-> x) : xs)
forall (ss :: [*]) (rs :: [*]).
(FoldRec ss ss, RMap rs, RMap ss, RecApplicative rs,
 RecApplicative ss, rs ⊆ ss) =>
Field rs -> Field ss
widenField
        l :: Field '[s :-> x] -> Field (s :-> x ': xs)
        l :: Field '[s :-> x] -> Field ((s :-> x) : xs)
l = Field '[s :-> x] -> Field ((s :-> x) : xs)
forall (ss :: [*]) (rs :: [*]).
(FoldRec ss ss, RMap rs, RMap ss, RecApplicative rs,
 RecApplicative ss, rs ⊆ ss) =>
Field rs -> Field ss
widenField
        (UnionDecoder (Field ((s :-> x) : xs))
p :: D.UnionDecoder (Field (s :-> x ': xs))) = ((s :-> x) -> Field ((s :-> x) : xs))
-> UnionDecoder (s :-> x) -> UnionDecoder (Field ((s :-> x) : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Field '[s :-> x] -> Field ((s :-> x) : xs)
l (Field '[s :-> x] -> Field ((s :-> x) : xs))
-> ((s :-> x) -> Field '[s :-> x])
-> (s :-> x)
-> Field ((s :-> x) : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (s :-> x) -> Field '[s :-> x]
forall u (r :: u) (b :: [u]) (a :: u -> *).
(r ∈ b) =>
a r -> CoRec a b
CoVal (Identity (s :-> x) -> Field '[s :-> x])
-> ((s :-> x) -> Identity (s :-> x))
-> (s :-> x)
-> Field '[s :-> x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s :-> x) -> Identity (s :-> x)
forall a. a -> Identity a
Identity) (InputNormalizer -> UnionDecoder (s :-> x)
forall x. FromDhallUnion x => InputNormalizer -> UnionDecoder x
autoWithU @(s :-> x) InputNormalizer
opts)
        (UnionDecoder (Field ((s :-> x) : xs))
q :: D.UnionDecoder (Field (s :-> x ': xs))) = (Field xs -> Field ((s :-> x) : xs))
-> UnionDecoder (Field xs) -> UnionDecoder (Field ((s :-> x) : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field xs -> Field ((s :-> x) : xs)
k (InputNormalizer -> UnionDecoder (Field xs)
forall x. FromDhallUnion x => InputNormalizer -> UnionDecoder x
autoWithU @(Field xs) InputNormalizer
opts)
     in (UnionDecoder (Field ((s :-> x) : xs))
p UnionDecoder (Field ((s :-> x) : xs))
-> UnionDecoder (Field ((s :-> x) : xs))
-> UnionDecoder (Field ((s :-> x) : xs))
forall a. Semigroup a => a -> a -> a
<> UnionDecoder (Field ((s :-> x) : xs))
q :: D.UnionDecoder (Field (s :-> x ': xs)))