{-# 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 opts =
    let nL :: (s :-> a)
        nL = undefined
     in D.constructor (valName nL) (Val @s <$> D.autoWith opts)

instance FromDhallUnion (Field '[]) where
  autoWithU = pure $ D.UnionDecoder $ Compose mempty

instance FromDhallUnion x => FromDhallUnion (Identity x) where
  autoWithU opts = Identity <$> autoWithU 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 opts = D.union $ autoWithU 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 opts =
    let k :: Field xs -> Field (s :-> x ': xs)
        k = widenField
        l :: Field '[s :-> x] -> Field (s :-> x ': xs)
        l = widenField
        (p :: D.UnionDecoder (Field (s :-> x ': xs))) = fmap (l . CoVal . Identity) (autoWithU @(s :-> x) opts)
        (q :: D.UnionDecoder (Field (s :-> x ': xs))) = fmap k (autoWithU @(Field xs) opts)
     in (p <> q :: D.UnionDecoder (Field (s :-> x ': xs)))