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

module Composite.Dhall (TextTemplate (TextTemplate, unTextTemplate), runTextTemplate, F (F, unF), CoF (CoF, unCoF)) 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 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.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 {..}

-- | Newtype wrapper for deriving `(Rec f xs)` where f is a `Functor` using DerivingVia.
--
-- @since 0.0.4.0
newtype F f xs = F {unF :: Rec f xs}

-- | Newtype wrapper for deriving `(Rec f xs)` where f is `Contravariant` using DerivingVia.
--
-- @since 0.0.4.0
newtype CoF f xs = CoF {unCoF :: Rec f xs}

deriving newtype instance D.FromDhall (F f '[])

deriving newtype instance D.FromDhall (CoF f '[])

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

instance (KnownSymbol s, Functor f, D.FromDhall (F f xs), D.FromDhall (f x)) => D.FromDhall (F f (s :-> x ': xs)) where
  autoWith opts =
    let nL :: s :-> x
        nL = undefined

        nameL = valName nL

        D.Decoder extractL expectedL = D.autoWith @(f x) opts

        D.Decoder extractR expectedR = unF <$> D.autoWith @(F f xs) opts

        ktsR = unsafeExpectRecord "Composite Rec f (Functor)" <$> expectedR

        expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
        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
     in F <$> D.Decoder extract expected

instance (KnownSymbol s, D.FromDhall (CoF f xs), Contravariant f, D.FromDhall (f x)) => D.FromDhall (CoF f (s :-> x ': xs)) where
  autoWith opts =
    let nL :: s :-> x
        nL = undefined

        nameL = valName nL

        D.Decoder extractL expectedL = D.autoWith @(f x) opts

        D.Decoder extractR expectedR = unCoF <$> D.autoWith @(CoF f xs) opts

        ktsR = unsafeExpectRecord "Composite Rec f (Contravariant)" <$> expectedR

        expected = Record <$> (Dhall.Map.insert nameL . Dhall.Core.makeRecordField <$> expectedL <*> ktsR)
        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
     in CoF <$> D.Decoder extract expected

deriving via (F Maybe (s :-> x ': xs)) instance (KnownSymbol s, D.ToDhall (F Maybe xs), D.ToDhall x) => D.ToDhall (Rec Maybe (s :-> x ': xs))

deriving via (F [] (s :-> x ': xs)) instance (KnownSymbol s, D.ToDhall (F [] xs), D.ToDhall x) => D.ToDhall (Rec [] (s :-> x ': xs))

deriving via (F Maybe (s :-> x ': xs)) instance (KnownSymbol s, D.FromDhall (F Maybe xs), D.FromDhall x) => D.FromDhall (Rec Maybe (s :-> x ': xs))

deriving via (F [] (s :-> x ': xs)) instance (KnownSymbol s, D.FromDhall (F [] xs), D.FromDhall x) => D.FromDhall (Rec [] (s :-> x ': xs))

deriving via (CoF Predicate (s :-> x ': xs)) instance (KnownSymbol s, D.FromDhall (CoF Predicate xs), D.ToDhall x) => D.FromDhall (Rec Predicate (s :-> x ': xs))

deriving via (CoF Equivalence (s :-> x ': xs)) instance (KnownSymbol s, D.FromDhall (CoF Equivalence xs), D.ToDhall x) => D.FromDhall (Rec Equivalence (s :-> x ': xs))

deriving via (CoF (Op b) (s :-> x ': xs)) instance (KnownSymbol s, D.FromDhall (CoF (Op b) xs), D.FromDhall b, D.ToDhall x) => D.FromDhall (Rec (Op b) (s :-> x ': xs))

-- | The common case where a function from `a -> Text` can be used
-- in a record.
--
-- @since 0.0.3.0
newtype TextTemplate a = TextTemplate {unTextTemplate :: Op Text a}
  deriving newtype (D.FromDhall)

deriving newtype instance Contravariant TextTemplate

-- | Run a `TextTemplate` against a value.
--
-- @since 0.0.3.0
runTextTemplate :: TextTemplate a -> a -> Text
runTextTemplate (TextTemplate (Op f)) = f