CoRecord.hs

{-# 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)))