{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Composite.Dhall () where import Composite.Record import Composite.TH import Control.Applicative import qualified Control.Lens as L import Data.Functor.Contravariant import Data.Text (Text) import qualified Data.Text as T import Data.Void import qualified Dhall as D import Dhall.Core hiding (File, Text, field) import Dhall.Map import Dhall.Src import GHC.TypeLits unsafeExpectRecordLit :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) unsafeExpectRecordLit :: Text -> Expr Src Void -> Map Text (RecordField Src Void) unsafeExpectRecordLit Text _ (RecordLit Map Text (RecordField Src Void) kvs) = Map Text (RecordField Src Void) kvs unsafeExpectRecordLit Text name Expr Src Void expression = Text -> forall b. b Dhall.Core.internalError (Text name Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ": Unexpected constructor: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Expr Src Void -> Text forall a. Pretty a => a -> Text Dhall.Core.pretty Expr Src Void expression) unsafeExpectRecord :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) unsafeExpectRecord :: Text -> Expr Src Void -> Map Text (RecordField Src Void) unsafeExpectRecord Text _ (Record Map Text (RecordField Src Void) kts) = Map Text (RecordField Src Void) kts unsafeExpectRecord Text name Expr Src Void expression = Text -> forall b. b Dhall.Core.internalError (Text name Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ": Unexpected constructor: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Expr Src Void -> Text forall a. Pretty a => a -> Text Dhall.Core.pretty Expr Src Void expression) instance D.ToDhall (Record '[]) where injectWith :: InputNormalizer -> Encoder (Record '[]) injectWith = Encoder (Record '[]) -> InputNormalizer -> Encoder (Record '[]) forall (f :: * -> *) a. Applicative f => a -> f a pure (Encoder :: forall a. (a -> Expr Src Void) -> Expr Src Void -> Encoder a D.Encoder {Expr Src Void Record '[] -> Expr Src Void forall s a. Expr s a forall p s a. p -> Expr s a embed :: Record '[] -> Expr Src Void declared :: Expr Src Void declared :: forall s a. Expr s a embed :: forall p s a. p -> Expr s a ..}) where embed :: p -> Expr s a embed p _ = Map Text (RecordField s a) -> Expr s a forall s a. Map Text (RecordField s a) -> Expr s a RecordLit Map Text (RecordField s a) forall a. Monoid a => a mempty declared :: Expr s a declared = Map Text (RecordField s a) -> Expr s a forall s a. Map Text (RecordField s a) -> Expr s a Record Map Text (RecordField s a) forall a. Monoid a => a mempty instance (KnownSymbol s, D.ToDhall (Record xs), D.ToDhall x) => D.ToDhall (Record (s :-> x ': xs)) where injectWith :: InputNormalizer -> Encoder (Record ((s :-> x) : xs)) injectWith = do let f :: s :-> x f :: s :-> x f = s :-> x forall a. HasCallStack => a undefined let name :: Text name = (s :-> x) -> Text forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text valName s :-> x f let D.Encoder x -> Expr Src Void embedL Expr Src Void declaredL = Encoder x forall a. ToDhall a => Encoder a D.inject let D.Encoder Record xs -> Expr Src Void embedR Expr Src Void declaredR = Encoder (Record xs) forall a. ToDhall a => Encoder a D.inject let embed :: Rec Identity ((s :-> x) : xs) -> Expr Src Void embed (x s :*: Record xs xs) = Map Text (RecordField Src Void) -> Expr Src Void forall s a. Map Text (RecordField s a) -> Expr s a RecordLit (Text -> RecordField Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void) forall k v. Ord k => k -> v -> Map k v -> Map k v Dhall.Map.insert Text name (Expr Src Void -> RecordField Src Void forall s a. Expr s a -> RecordField s a Dhall.Core.makeRecordField (x -> Expr Src Void embedL (x -> Expr Src Void) -> x -> Expr Src Void forall a b. (a -> b) -> a -> b $ x s)) Map Text (RecordField Src Void) mapR) where mapR :: Map Text (RecordField Src Void) mapR = Text -> Expr Src Void -> Map Text (RecordField Src Void) unsafeExpectRecordLit Text "Composite Record" (Expr Src Void -> Map Text (RecordField Src Void)) -> Expr Src Void -> Map Text (RecordField Src Void) forall a b. (a -> b) -> a -> b $ Record xs -> Expr Src Void embedR Record xs xs let declared :: Expr Src Void declared = Map Text (RecordField Src Void) -> Expr Src Void forall s a. Map Text (RecordField s a) -> Expr s a Record (Text -> RecordField Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void) forall k v. Ord k => k -> v -> Map k v -> Map k v Dhall.Map.insert Text name (Expr Src Void -> RecordField Src Void forall s a. Expr s a -> RecordField s a Dhall.Core.makeRecordField (Expr Src Void declaredL)) Map Text (RecordField Src Void) mapR) where mapR :: Map Text (RecordField Src Void) mapR = Text -> Expr Src Void -> Map Text (RecordField Src Void) unsafeExpectRecord Text "Composite Record" Expr Src Void declaredR Encoder (Record ((s :-> x) : xs)) -> InputNormalizer -> Encoder (Record ((s :-> x) : xs)) forall (f :: * -> *) a. Applicative f => a -> f a pure (Encoder (Record ((s :-> x) : xs)) -> InputNormalizer -> Encoder (Record ((s :-> x) : xs))) -> Encoder (Record ((s :-> x) : xs)) -> InputNormalizer -> Encoder (Record ((s :-> x) : xs)) forall a b. (a -> b) -> a -> b $ Encoder :: forall a. (a -> Expr Src Void) -> Expr Src Void -> Encoder a D.Encoder {Expr Src Void Record ((s :-> x) : xs) -> Expr Src Void forall (s :: Symbol). Rec Identity ((s :-> x) : xs) -> Expr Src Void declared :: Expr Src Void embed :: forall (s :: Symbol). Rec Identity ((s :-> x) : xs) -> Expr Src Void embed :: Record ((s :-> x) : xs) -> Expr Src Void declared :: Expr Src Void ..} instance D.FromDhall (Record '[]) where autoWith :: InputNormalizer -> Decoder (Record '[]) autoWith InputNormalizer _ = Decoder :: forall a. (Expr Src Void -> Extractor Src Void a) -> Expector (Expr Src Void) -> Decoder a D.Decoder {Expector (Expr Src Void) Expr Src Void -> Validation (ExtractErrors Src Void) (Record '[]) forall s a. Validation ExpectedTypeErrors (Expr s a) forall (f :: * -> *) p (a :: * -> *). Applicative f => p -> f (Rec a '[]) extract :: Expr Src Void -> Validation (ExtractErrors Src Void) (Record '[]) expected :: Expector (Expr Src Void) expected :: forall s a. Validation ExpectedTypeErrors (Expr s a) extract :: forall (f :: * -> *) p (a :: * -> *). Applicative f => p -> f (Rec a '[]) ..} where extract :: p -> f (Rec a '[]) extract p _ = Rec a '[] -> f (Rec a '[]) forall (f :: * -> *) a. Applicative f => a -> f a pure Rec a '[] forall u (a :: u -> *). Rec a '[] RNil expected :: Validation ExpectedTypeErrors (Expr s a) expected = Expr s a -> Validation ExpectedTypeErrors (Expr s a) forall (f :: * -> *) a. Applicative f => a -> f a pure (Expr s a -> Validation ExpectedTypeErrors (Expr s a)) -> Expr s a -> Validation ExpectedTypeErrors (Expr s a) forall a b. (a -> b) -> a -> b $ Map Text (RecordField s a) -> Expr s a forall s a. Map Text (RecordField s a) -> Expr s a Record ([(Text, RecordField s a)] -> Map Text (RecordField s a) forall k v. Ord k => [(k, v)] -> Map k v Dhall.Map.fromList []) instance (KnownSymbol s, D.FromDhall (Record xs), D.FromDhall x) => D.FromDhall (Record (s :-> x ': xs)) where autoWith :: InputNormalizer -> Decoder (Record ((s :-> x) : xs)) autoWith = do let nL :: s :-> x nL :: s :-> x nL = s :-> x forall a. HasCallStack => a undefined let nameL :: Text nameL = (s :-> x) -> Text forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text valName s :-> x nL D.Decoder Expr Src Void -> Extractor Src Void x extractL Expector (Expr Src Void) expectedL <- FromDhall x => InputNormalizer -> Decoder x forall a. FromDhall a => InputNormalizer -> Decoder a D.autoWith @x D.Decoder Expr Src Void -> Extractor Src Void (Record xs) extractR Expector (Expr Src Void) expectedR <- FromDhall (Record xs) => InputNormalizer -> Decoder (Record xs) forall a. FromDhall a => InputNormalizer -> Decoder a D.autoWith @(Record xs) let ktsR :: Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) ktsR = Text -> Expr Src Void -> Map Text (RecordField Src Void) unsafeExpectRecord Text "Composite Record" (Expr Src Void -> Map Text (RecordField Src Void)) -> Expector (Expr Src Void) -> Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Expector (Expr Src Void) expectedR let expected :: Expector (Expr Src Void) expected = Map Text (RecordField Src Void) -> Expr Src Void forall s a. Map Text (RecordField s a) -> Expr s a Record (Map Text (RecordField Src Void) -> Expr Src Void) -> Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) -> Expector (Expr Src Void) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Text -> RecordField Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void) forall k v. Ord k => k -> v -> Map k v -> Map k v Dhall.Map.insert Text nameL (RecordField Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void)) -> (Expr Src Void -> RecordField Src Void) -> Expr Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void) forall b c a. (b -> c) -> (a -> b) -> a -> c . Expr Src Void -> RecordField Src Void forall s a. Expr s a -> RecordField s a Dhall.Core.makeRecordField (Expr Src Void -> Map Text (RecordField Src Void) -> Map Text (RecordField Src Void)) -> Expector (Expr Src Void) -> Validation ExpectedTypeErrors (Map Text (RecordField Src Void) -> Map Text (RecordField Src Void)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Expector (Expr Src Void) expectedL Validation ExpectedTypeErrors (Map Text (RecordField Src Void) -> Map Text (RecordField Src Void)) -> Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) -> Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Validation ExpectedTypeErrors (Map Text (RecordField Src Void)) ktsR) let extract :: Expr Src Void -> Validation (ExtractErrors Src Void) (Rec Identity ((s :-> x) : xs)) extract Expr Src Void expression = do let die :: Extractor Src Void b die = Expector (Expr Src Void) -> Expr Src Void -> Extractor Src Void b forall s a b. Expector (Expr s a) -> Expr s a -> Extractor s a b D.typeError Expector (Expr Src Void) expected Expr Src Void expression case Expr Src Void expression of RecordLit Map Text (RecordField Src Void) kvs -> case RecordField Src Void -> Expr Src Void forall s a. RecordField s a -> Expr s a Dhall.Core.recordFieldValue (RecordField Src Void -> Expr Src Void) -> Maybe (RecordField Src Void) -> Maybe (Expr Src Void) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Text -> Map Text (RecordField Src Void) -> Maybe (RecordField Src Void) forall k v. Ord k => k -> Map k v -> Maybe v Dhall.Map.lookup Text nameL Map Text (RecordField Src Void) kvs of Just Expr Src Void expressionL -> (x -> Record xs -> Rec Identity ((s :-> x) : xs)) -> Extractor Src Void x -> Extractor Src Void (Record xs) -> Validation (ExtractErrors Src Void) (Rec Identity ((s :-> x) : xs)) forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 x -> Record xs -> Rec Identity ((s :-> x) : xs) forall a (rs :: [*]) (s :: Symbol). a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs) (:*:) (Expr Src Void -> Extractor Src Void x extractL Expr Src Void expressionL) (Expr Src Void -> Extractor Src Void (Record xs) extractR Expr Src Void expression) Maybe (Expr Src Void) _ -> Validation (ExtractErrors Src Void) (Rec Identity ((s :-> x) : xs)) forall b. Extractor Src Void b die Expr Src Void _ -> Validation (ExtractErrors Src Void) (Rec Identity ((s :-> x) : xs)) forall b. Extractor Src Void b die Decoder (Record ((s :-> x) : xs)) -> InputNormalizer -> Decoder (Record ((s :-> x) : xs)) forall (f :: * -> *) a. Applicative f => a -> f a pure ((Expr Src Void -> Extractor Src Void (Record ((s :-> x) : xs))) -> Expector (Expr Src Void) -> Decoder (Record ((s :-> x) : xs)) forall a. (Expr Src Void -> Extractor Src Void a) -> Expector (Expr Src Void) -> Decoder a D.Decoder Expr Src Void -> Extractor Src Void (Record ((s :-> x) : xs)) forall (s :: Symbol). Expr Src Void -> Validation (ExtractErrors Src Void) (Rec Identity ((s :-> x) : xs)) extract Expector (Expr Src Void) expected)