composite-dhall-0.0.4.0: src/Composite/Dhall.hs
{-# 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 (unF), 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 newtype instance (D.ToDhall x) => D.FromDhall (Predicate x)
deriving newtype instance (D.ToDhall x) => D.FromDhall (Equivalence x)
deriving newtype instance (D.FromDhall b, D.ToDhall x) => D.FromDhall (Op b x)
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)
-- | Run a `TextTemplate` against a value.
--
-- @since 0.0.3.0
runTextTemplate :: TextTemplate a -> a -> Text
runTextTemplate (TextTemplate (Op f)) = f