Dhall.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Composite.Dhall () where

import Composite.Record
import Control.Applicative
import Data.Functor.Contravariant
import Data.Text (Text)
import Data.Void
import qualified Dhall as D
import Dhall.Core hiding (File, Text)
import Dhall.Map
import Dhall.Src
import GHC.TypeLits

unsafeExpectRecordLit ::
  Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void)
unsafeExpectRecordLit _ (RecordLit kvs) =
  kvs
unsafeExpectRecordLit name expression =
  Dhall.Core.internalError
    (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)

unsafeExpectRecord ::
  Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void)
unsafeExpectRecord _ (Record kts) =
  kts
unsafeExpectRecord name expression =
  Dhall.Core.internalError
    (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)

instance D.ToDhall (Rec f '[]) where
  injectWith = pure (D.Encoder {..})
    where
      embed _ = RecordLit mempty
      declared = Record mempty

instance (KnownSymbol s, D.ToDhall (Record xs), D.ToDhall x) => D.ToDhall (Record (s :-> x ': xs)) where
  injectWith = do
    let f :: s :-> x
        f = undefined
    let name = valName f
    let D.Encoder embedL declaredL = D.inject
    let D.Encoder embedR declaredR = D.inject
    let embed (s :*: xs) = RecordLit (Dhall.Map.insert name (Dhall.Core.makeRecordField (embedL s)) mapR)
          where
            mapR = unsafeExpectRecordLit "Composite Record" $ embedR xs
    let declared = Record (Dhall.Map.insert name (Dhall.Core.makeRecordField declaredL) mapR)
          where
            mapR = unsafeExpectRecord "Composite Record" declaredR
    pure $ D.Encoder {..}

instance (KnownSymbol s, D.ToDhall (Rec Maybe xs), D.ToDhall x) => D.ToDhall (Rec Maybe (s :-> x ': xs)) where
  injectWith = do
    let f :: s :-> x
        f = undefined
    let name = valName f
    let D.Encoder embedL declaredL = D.inject
    let D.Encoder embedR declaredR = D.inject
    let embed (s :^: xs) = RecordLit (Dhall.Map.insert name (Dhall.Core.makeRecordField (embedL s)) mapR)
          where
            mapR = unsafeExpectRecordLit "Composite Record" $ embedR xs
    let declared = Record (Dhall.Map.insert name (Dhall.Core.makeRecordField declaredL) mapR)
          where
            mapR = unsafeExpectRecord "Composite Record" declaredR
    pure $ D.Encoder {..}

instance D.FromDhall (Rec f '[]) where
  autoWith _ = D.Decoder {..}
    where
      extract _ = pure RNil
      expected = pure $ Record (Dhall.Map.fromList [])

instance (KnownSymbol s, D.FromDhall (Record xs), D.FromDhall x) => D.FromDhall (Record (s :-> x ': xs)) where
  autoWith = do
    let nL :: s :-> x
        nL = undefined

    let nameL = valName nL

    D.Decoder extractL expectedL <- D.autoWith @x

    D.Decoder extractR expectedR <- D.autoWith @(Record xs)

    let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR

    let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
    let extract expression = do
          let die = D.typeError expected expression

          case expression of
            RecordLit kvs ->
              case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of
                Just expressionL ->
                  liftA2
                    (:*:)
                    (extractL expressionL)
                    (extractR expression)
                _ -> die
            _ -> die
    pure (D.Decoder extract expected)

instance (KnownSymbol s, D.FromDhall (Rec Maybe xs), D.FromDhall x) => D.FromDhall (Rec Maybe (s :-> x ': xs)) where
  autoWith = do
    let nL :: s :-> x
        nL = undefined

    let nameL = valName nL

    D.Decoder extractL expectedL <- D.autoWith @(Maybe x)

    D.Decoder extractR expectedR <- D.autoWith @(Rec Maybe xs)

    let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR

    let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
    let extract expression = do
          let die = D.typeError expected expression

          case expression of
            RecordLit kvs ->
              case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of
                Just expressionL ->
                  liftA2
                    (:^:)
                    (extractL expressionL)
                    (extractR expression)
                _ -> die
            _ -> die
    pure (D.Decoder extract expected)

deriving newtype instance (D.FromDhall b, D.ToDhall x) => D.FromDhall (Op b x)

deriving newtype instance (D.ToDhall x) => D.FromDhall (Predicate x)

deriving newtype instance (D.ToDhall x) => D.FromDhall (Equivalence x)

instance (KnownSymbol s, D.FromDhall (Rec (Op b) xs), D.FromDhall b, D.ToDhall x) => D.FromDhall (Rec (Op b) (s :-> x ': xs)) where
  autoWith = do
    let nL :: s :-> x
        nL = undefined

    let nameL = valName nL

    D.Decoder extractL expectedL <- D.autoWith @(Op b x)

    D.Decoder extractR expectedR <- D.autoWith @(Rec (Op b) xs)

    let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR

    let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
    let extract expression = do
          let die = D.typeError expected expression

          case expression of
            RecordLit kvs ->
              case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of
                Just expressionL ->
                  liftA2
                    (:&)
                    (contramap getVal <$> extractL expressionL)
                    (extractR expression)
                _ -> die
            _ -> die
    pure (D.Decoder extract expected)

instance (KnownSymbol s, D.FromDhall (Rec Predicate xs), D.ToDhall x) => D.FromDhall (Rec Predicate (s :-> x ': xs)) where
  autoWith = do
    let nL :: s :-> x
        nL = undefined

    let nameL = valName nL

    D.Decoder extractL expectedL <- D.autoWith @(Predicate x)

    D.Decoder extractR expectedR <- D.autoWith @(Rec Predicate xs)

    let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR

    let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
    let extract expression = do
          let die = D.typeError expected expression

          case expression of
            RecordLit kvs ->
              case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of
                Just expressionL ->
                  liftA2
                    (:&)
                    (contramap getVal <$> extractL expressionL)
                    (extractR expression)
                _ -> die
            _ -> die
    pure (D.Decoder extract expected)

instance (KnownSymbol s, D.FromDhall (Rec Equivalence xs), D.ToDhall x) => D.FromDhall (Rec Equivalence (s :-> x ': xs)) where
  autoWith = do
    let nL :: s :-> x
        nL = undefined

    let nameL = valName nL

    D.Decoder extractL expectedL <- D.autoWith @(Equivalence x)

    D.Decoder extractR expectedR <- D.autoWith @(Rec Equivalence xs)

    let ktsR = unsafeExpectRecord "Composite Record" <$> expectedR

    let expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
    let extract expression = do
          let die = D.typeError expected expression

          case expression of
            RecordLit kvs ->
              case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of
                Just expressionL ->
                  liftA2
                    (:&)
                    (contramap getVal <$> extractL expressionL)
                    (extractR expression)
                _ -> die
            _ -> die
    pure (D.Decoder extract expected)