{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
module Dhall
(
input
, inputWithSettings
, inputFile
, inputFileWithSettings
, inputExpr
, inputExprWithSettings
, rootDirectory
, sourceName
, startingContext
, normalizer
, defaultInputSettings
, InputSettings
, defaultEvaluateSettings
, EvaluateSettings
, HasEvaluateSettings
, detailed
, Type (..)
, RecordType(..)
, UnionType(..)
, InputType(..)
, Interpret(..)
, InvalidType(..)
, ExtractErrors(..)
, Extractor
, MonadicExtractor
, typeError
, extractError
, toMonadic
, fromMonadic
, auto
, genericAuto
, InterpretOptions(..)
, defaultInterpretOptions
, bool
, natural
, integer
, scientific
, double
, lazyText
, strictText
, maybe
, sequence
, list
, vector
, unit
, string
, pair
, record
, field
, union
, constructor
, GenericInterpret(..)
, GenericInject(..)
, Inject(..)
, inject
, genericInject
, RecordInputType(..)
, inputFieldWith
, inputField
, inputRecord
, UnionInputType(..)
, inputConstructorWith
, inputConstructor
, inputUnion
, (>|<)
, rawInput
, (>$<)
, (>*<)
, Natural
, Seq
, Text
, Vector
, Generic
) where
import Control.Applicative (empty, liftA2, Alternative)
import Control.Exception (Exception)
import Control.Monad.Trans.State.Strict
import Control.Monad (guard)
import Data.Coerce (coerce)
import Data.Either.Validation (Validation(..), ealt, eitherToValidation, validationToEither)
import Data.Fix (Fix(..))
import Data.Functor.Contravariant (Contravariant(..), (>$<), Op(..))
import Data.Functor.Contravariant.Divisible (Divisible(..), divided)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid ((<>))
import Data.Scientific (Scientific)
import Data.Semigroup (Semigroup)
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import Dhall.Core (Expr(..), Chunks(..))
import Dhall.Import (Imported(..))
import Dhall.Parser (Src(..))
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
import GHC.Generics
import Lens.Family (LensLike', set, view)
import Numeric.Natural (Natural)
import Prelude hiding (maybe, sequence)
import System.FilePath (takeDirectory)
import qualified Control.Applicative
import qualified Control.Exception
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Foldable
import qualified Data.Functor.Compose
import qualified Data.Functor.Product
import qualified Data.Maybe
import qualified Data.List.NonEmpty
import qualified Data.Semigroup
import qualified Data.Scientific
import qualified Data.Sequence
import qualified Data.Set
import qualified Data.Text
import qualified Data.Text.IO
import qualified Data.Text.Lazy
import qualified Data.Vector
import qualified Dhall.Context
import qualified Dhall.Core
import qualified Dhall.Import
import qualified Dhall.Map
import qualified Dhall.Parser
import qualified Dhall.Pretty.Internal
import qualified Dhall.TypeCheck
import qualified Dhall.Util
type Extractor s a = Validation (ExtractErrors s a)
type MonadicExtractor s a = Either (ExtractErrors s a)
typeError :: Expr s a -> Expr s a -> Extractor s a b
typeError expected actual = Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual
extractError :: Text -> Extractor s a b
extractError = Failure . ExtractErrors . pure . ExtractError
toMonadic :: Extractor s a b -> MonadicExtractor s a b
toMonadic = validationToEither
fromMonadic :: MonadicExtractor s a b -> Extractor s a b
fromMonadic = eitherToValidation
newtype ExtractErrors s a = ExtractErrors
{ getErrors :: NonEmpty (ExtractError s a)
} deriving Semigroup
instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractErrors s a) where
show (ExtractErrors (e :| [])) = show e
show (ExtractErrors es) = prefix <> (unlines . Data.List.NonEmpty.toList . fmap show $ es)
where
prefix =
"Multiple errors were encountered during extraction: \n\
\ \n"
instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractErrors s a)
data ExtractError s a =
TypeMismatch (InvalidType s a)
| ExtractError Text
instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractError s a) where
show (TypeMismatch e) = show e
show (ExtractError es) =
_ERROR <> ": Failed extraction \n\
\ \n\
\The expression type-checked successfully but the transformation to the target \n\
\type failed with the following error: \n\
\ \n\
\" <> Data.Text.unpack es <> "\n\
\ \n"
instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractError s a)
data InvalidType s a = InvalidType
{ invalidTypeExpected :: Expr s a
, invalidTypeExpression :: Expr s a
}
deriving (Typeable)
instance (Pretty s, Typeable s, Pretty a, Typeable a) => Exception (InvalidType s a)
_ERROR :: String
_ERROR = "\ESC[1;31mError\ESC[0m"
instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidType s a) where
show InvalidType { .. } =
_ERROR <> ": Invalid Dhall.Type \n\
\ \n\
\Every Type must provide an extract function that succeeds if an expression \n\
\matches the expected type. You provided a Type that disobeys this contract \n\
\ \n\
\The Type provided has the expected dhall type: \n\
\ \n\
\" <> show txt0 <> "\n\
\ \n\
\and it couldn't extract a value from the well-typed expression: \n\
\ \n\
\" <> show txt1 <> "\n\
\ \n"
where
txt0 = Dhall.Util.insert invalidTypeExpected
txt1 = Dhall.Util.insert invalidTypeExpression
data InputSettings = InputSettings
{ _rootDirectory :: FilePath
, _sourceName :: FilePath
, _evaluateSettings :: EvaluateSettings
}
defaultInputSettings :: InputSettings
defaultInputSettings = InputSettings
{ _rootDirectory = "."
, _sourceName = "(input)"
, _evaluateSettings = defaultEvaluateSettings
}
rootDirectory
:: (Functor f)
=> LensLike' f InputSettings FilePath
rootDirectory k s =
fmap (\x -> s { _rootDirectory = x }) (k (_rootDirectory s))
sourceName
:: (Functor f)
=> LensLike' f InputSettings FilePath
sourceName k s =
fmap (\x -> s { _sourceName = x}) (k (_sourceName s))
data EvaluateSettings = EvaluateSettings
{ _startingContext :: Dhall.Context.Context (Expr Src X)
, _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer X)
}
defaultEvaluateSettings :: EvaluateSettings
defaultEvaluateSettings = EvaluateSettings
{ _startingContext = Dhall.Context.empty
, _normalizer = Nothing
}
startingContext
:: (Functor f, HasEvaluateSettings s)
=> LensLike' f s (Dhall.Context.Context (Expr Src X))
startingContext = evaluateSettings . l
where
l :: (Functor f)
=> LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src X))
l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s))
normalizer
:: (Functor f, HasEvaluateSettings s)
=> LensLike' f s (Maybe (Dhall.Core.ReifiedNormalizer X))
normalizer = evaluateSettings . l
where
l :: (Functor f)
=> LensLike' f EvaluateSettings (Maybe (Dhall.Core.ReifiedNormalizer X))
l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))
class HasEvaluateSettings s where
evaluateSettings
:: (Functor f)
=> LensLike' f s EvaluateSettings
instance HasEvaluateSettings InputSettings where
evaluateSettings k s =
fmap (\x -> s { _evaluateSettings = x }) (k (_evaluateSettings s))
instance HasEvaluateSettings EvaluateSettings where
evaluateSettings = id
input
:: Type a
-> Text
-> IO a
input =
inputWithSettings defaultInputSettings
inputWithSettings
:: InputSettings
-> Type a
-> Text
-> IO a
inputWithSettings settings (Type {..}) txt = do
expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt)
let InputSettings {..} = settings
let EvaluateSettings {..} = _evaluateSettings
let transform =
set Dhall.Import.normalizer _normalizer
. set Dhall.Import.startingContext _startingContext
let status = transform (Dhall.Import.emptyStatus _rootDirectory)
expr' <- State.evalStateT (Dhall.Import.loadWith expr) status
let suffix = Dhall.Pretty.Internal.prettyToStrictText expected
let annot = case expr' of
Note (Src begin end bytes) _ ->
Note (Src begin end bytes') (Annot expr' expected)
where
bytes' = bytes <> " : " <> suffix
_ ->
Annot expr' expected
_ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot)
let normExpr = Dhall.Core.normalizeWith (view normalizer settings) expr'
case extract normExpr of
Success x -> return x
Failure e -> Control.Exception.throwIO e
inputFile
:: Type a
-> FilePath
-> IO a
inputFile =
inputFileWithSettings defaultEvaluateSettings
inputFileWithSettings
:: EvaluateSettings
-> Type a
-> FilePath
-> IO a
inputFileWithSettings settings ty path = do
text <- Data.Text.IO.readFile path
let inputSettings = InputSettings
{ _rootDirectory = takeDirectory path
, _sourceName = path
, _evaluateSettings = settings
}
inputWithSettings inputSettings ty text
inputExpr
:: Text
-> IO (Expr Src X)
inputExpr =
inputExprWithSettings defaultInputSettings
inputExprWithSettings
:: InputSettings
-> Text
-> IO (Expr Src X)
inputExprWithSettings settings txt = do
expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt)
let InputSettings {..} = settings
let EvaluateSettings {..} = _evaluateSettings
let transform =
set Dhall.Import.normalizer _normalizer
. set Dhall.Import.startingContext _startingContext
let status = transform (Dhall.Import.emptyStatus _rootDirectory)
expr' <- State.evalStateT (Dhall.Import.loadWith expr) status
_ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) expr')
pure (Dhall.Core.normalizeWith (view normalizer settings) expr')
rawInput
:: Alternative f
=> Type a
-> Expr s X
-> f a
rawInput (Type {..}) expr = do
case extract (Dhall.Core.normalize expr) of
Success x -> pure x
Failure _e -> empty
detailed :: IO a -> IO a
detailed =
Control.Exception.handle handler1 . Control.Exception.handle handler0
where
handler0 :: Imported (TypeError Src X) -> IO a
handler0 (Imported ps e) =
Control.Exception.throwIO (Imported ps (DetailedTypeError e))
handler1 :: TypeError Src X -> IO a
handler1 e = Control.Exception.throwIO (DetailedTypeError e)
data Type a = Type
{ extract :: Expr Src X -> Extractor Src X a
, expected :: Expr Src X
}
deriving (Functor)
bool :: Type Bool
bool = Type {..}
where
extract (BoolLit b) = pure b
extract expr = typeError expected expr
expected = Bool
natural :: Type Natural
natural = Type {..}
where
extract (NaturalLit n) = pure n
extract expr = typeError Natural expr
expected = Natural
integer :: Type Integer
integer = Type {..}
where
extract (IntegerLit n) = pure n
extract expr = typeError Integer expr
expected = Integer
scientific :: Type Scientific
scientific = fmap Data.Scientific.fromFloatDigits double
double :: Type Double
double = Type {..}
where
extract (DoubleLit n) = pure n
extract expr = typeError Double expr
expected = Double
lazyText :: Type Data.Text.Lazy.Text
lazyText = Type {..}
where
extract (TextLit (Chunks [] t)) = pure (Data.Text.Lazy.fromStrict t)
extract expr = typeError Text expr
expected = Text
strictText :: Type Text
strictText = fmap Data.Text.Lazy.toStrict lazyText
maybe :: Type a -> Type (Maybe a)
maybe (Type extractIn expectedIn) = Type extractOut expectedOut
where
extractOut (Some e ) = fmap Just (extractIn e)
extractOut (App None _) = pure Nothing
extractOut expr = typeError expectedOut expr
expectedOut = App Optional expectedIn
sequence :: Type a -> Type (Seq a)
sequence (Type extractIn expectedIn) = Type extractOut expectedOut
where
extractOut (ListLit _ es) = traverse extractIn es
extractOut expr = typeError expectedOut expr
expectedOut = App List expectedIn
list :: Type a -> Type [a]
list = fmap Data.Foldable.toList . sequence
vector :: Type a -> Type (Vector a)
vector = fmap Data.Vector.fromList . list
unit :: Type ()
unit = Type extractOut expectedOut
where
extractOut (RecordLit fields)
| Data.Foldable.null fields = pure ()
extractOut expr = typeError (Record mempty) expr
expectedOut = Record mempty
string :: Type String
string = Data.Text.Lazy.unpack <$> lazyText
pair :: Type a -> Type b -> Type (a, b)
pair l r = Type extractOut expectedOut
where
extractOut expr@(RecordLit fields) =
(,) <$> ( Data.Maybe.maybe (typeError expectedOut expr) (extract l) $ Dhall.Map.lookup "_1" fields)
<*> ( Data.Maybe.maybe (typeError expectedOut expr) (extract r) $ Dhall.Map.lookup "_2" fields)
extractOut expr = typeError expectedOut expr
expectedOut =
Record
(Dhall.Map.fromList
[ ("_1", expected l)
, ("_2", expected r)
]
)
class Interpret a where
autoWith:: InterpretOptions -> Type a
default autoWith
:: (Generic a, GenericInterpret (Rep a)) => InterpretOptions -> Type a
autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1)
instance Interpret Bool where
autoWith _ = bool
instance Interpret Natural where
autoWith _ = natural
instance Interpret Integer where
autoWith _ = integer
instance Interpret Scientific where
autoWith _ = scientific
instance Interpret Double where
autoWith _ = double
instance {-# OVERLAPS #-} Interpret [Char] where
autoWith _ = string
instance Interpret Data.Text.Lazy.Text where
autoWith _ = lazyText
instance Interpret Text where
autoWith _ = strictText
instance Interpret a => Interpret (Maybe a) where
autoWith opts = maybe (autoWith opts)
instance Interpret a => Interpret (Seq a) where
autoWith opts = sequence (autoWith opts)
instance Interpret a => Interpret [a] where
autoWith = fmap (fmap Data.Vector.toList) autoWith
instance Interpret a => Interpret (Vector a) where
autoWith opts = vector (autoWith opts)
instance (Inject a, Interpret b) => Interpret (a -> b) where
autoWith opts = Type extractOut expectedOut
where
normalizer_ = Just (inputNormalizer opts)
extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of
Success o -> o
Failure _e -> error "Interpret: You cannot decode a function if it does not have the correct type" )
expectedOut = Pi "_" declared expectedIn
InputType {..} = inject
Type extractIn expectedIn = autoWith opts
instance (Interpret a, Interpret b) => Interpret (a, b)
auto :: Interpret a => Type a
auto = autoWith defaultInterpretOptions
newtype Result f = Result { _unResult :: f (Result f) }
resultToFix :: Functor f => Result f -> Fix f
resultToFix (Result x) = Fix (fmap resultToFix x)
instance Interpret (f (Result f)) => Interpret (Result f) where
autoWith options = Type { expected = expected_, extract = extract_ }
where
expected_ = "result"
extract_ (App _ expression) = do
fmap Result (extract (autoWith options) expression)
extract_ expression = do
typeError expression expected_
instance (Functor f, Interpret (f (Result f))) => Interpret (Fix f) where
autoWith options = Type { expected = expected_, extract = extract_ }
where
expected_ =
Pi "result" (Const Dhall.Core.Type)
(Pi "Make" (Pi "_" (expected (autoWith options :: Type (f (Result f)))) "result")
"result"
)
extract_ expression0 = go0 (Dhall.Core.alphaNormalize expression0)
where
go0 (Lam _ _ (Lam _ _ expression1)) =
fmap resultToFix (extract (autoWith options) expression1)
go0 _ = typeError expected_ expression0
genericAuto :: (Generic a, GenericInterpret (Rep a)) => Type a
genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1)
data InterpretOptions = InterpretOptions
{ fieldModifier :: Text -> Text
, constructorModifier :: Text -> Text
, inputNormalizer :: Dhall.Core.ReifiedNormalizer X
}
defaultInterpretOptions :: InterpretOptions
defaultInterpretOptions = InterpretOptions
{ fieldModifier = id
, constructorModifier = id
, inputNormalizer = Dhall.Core.ReifiedNormalizer (const (pure Nothing))
}
class GenericInterpret f where
genericAutoWith :: InterpretOptions -> State Int (Type (f a))
instance GenericInterpret f => GenericInterpret (M1 D d f) where
genericAutoWith options = do
res <- genericAutoWith options
pure (fmap M1 res)
instance GenericInterpret V1 where
genericAutoWith _ = pure Type {..}
where
extract expr = typeError expected expr
expected = Union mempty
unsafeExpectUnion
:: Text -> Expr Src X -> Dhall.Map.Map Text (Maybe (Expr Src X))
unsafeExpectUnion _ (Union kts) =
kts
unsafeExpectUnion name expression =
Dhall.Core.internalError
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
unsafeExpectRecord :: Text -> Expr Src X -> Dhall.Map.Map Text (Expr Src X)
unsafeExpectRecord _ (Record kts) =
kts
unsafeExpectRecord name expression =
Dhall.Core.internalError
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
unsafeExpectUnionLit
:: Text
-> Expr Src X
-> (Text, Maybe (Expr Src X))
unsafeExpectUnionLit _ (Field (Union _) k) =
(k, Nothing)
unsafeExpectUnionLit _ (App (Field (Union _) k) v) =
(k, Just v)
unsafeExpectUnionLit name expression =
Dhall.Core.internalError
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
unsafeExpectRecordLit :: Text -> Expr Src X -> Dhall.Map.Map Text (Expr Src X)
unsafeExpectRecordLit _ (RecordLit kvs) =
kvs
unsafeExpectRecordLit name expression =
Dhall.Core.internalError
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
notEmptyRecordLit :: Expr s a -> Maybe (Expr s a)
notEmptyRecordLit e = case e of
RecordLit m | null m -> Nothing
_ -> Just e
notEmptyRecord :: Expr s a -> Maybe (Expr s a)
notEmptyRecord e = case e of
Record m | null m -> Nothing
_ -> Just e
extractUnionConstructor
:: Expr s a -> Maybe (Text, Expr s a, Dhall.Map.Map Text (Maybe (Expr s a)))
extractUnionConstructor (App (Field (Union kts) fld) e) =
return (fld, e, Dhall.Map.delete fld kts)
extractUnionConstructor (Field (Union kts) fld) =
return (fld, RecordLit mempty, Dhall.Map.delete fld kts)
extractUnionConstructor _ =
empty
instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
where
nL :: M1 i c1 f1 a
nL = undefined
nR :: M1 i c2 f2 a
nR = undefined
nameL = constructorModifier (Data.Text.pack (conName nL))
nameR = constructorModifier (Data.Text.pack (conName nR))
extract e0 = do
case extractUnionConstructor e0 of
Just (name, e1, _) ->
if
| name == nameL -> fmap (L1 . M1) (extractL e1)
| name == nameR -> fmap (R1 . M1) (extractR e1)
| otherwise -> typeError expected e0
_ -> typeError expected e0
expected =
Union
(Dhall.Map.fromList
[ (nameL, notEmptyRecord expectedL)
, (nameR, notEmptyRecord expectedR)
]
)
Type extractL expectedL = evalState (genericAutoWith options) 1
Type extractR expectedR = evalState (genericAutoWith options) 1
instance (Constructor c, GenericInterpret (f :+: g), GenericInterpret h) => GenericInterpret ((f :+: g) :+: M1 C c h) where
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
where
n :: M1 i c h a
n = undefined
name = constructorModifier (Data.Text.pack (conName n))
extract u = case extractUnionConstructor u of
Just (name', e, _) ->
if
| name == name' -> fmap (R1 . M1) (extractR e)
| otherwise -> fmap L1 (extractL u)
Nothing -> typeError expected u
expected =
Union (Dhall.Map.insert name (notEmptyRecord expectedR) ktsL)
Type extractL expectedL = evalState (genericAutoWith options) 1
Type extractR expectedR = evalState (genericAutoWith options) 1
ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL
instance (Constructor c, GenericInterpret f, GenericInterpret (g :+: h)) => GenericInterpret (M1 C c f :+: (g :+: h)) where
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
where
n :: M1 i c f a
n = undefined
name = constructorModifier (Data.Text.pack (conName n))
extract u = case extractUnionConstructor u of
Just (name', e, _) ->
if
| name == name' -> fmap (L1 . M1) (extractL e)
| otherwise -> fmap R1 (extractR u)
_ -> typeError expected u
expected =
Union (Dhall.Map.insert name (notEmptyRecord expectedL) ktsR)
Type extractL expectedL = evalState (genericAutoWith options) 1
Type extractR expectedR = evalState (genericAutoWith options) 1
ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR
instance (GenericInterpret (f :+: g), GenericInterpret (h :+: i)) => GenericInterpret ((f :+: g) :+: (h :+: i)) where
genericAutoWith options = pure (Type {..})
where
extract e = fmap L1 (extractL e) `ealt` fmap R1 (extractR e)
expected = Union (Dhall.Map.union ktsL ktsR)
Type extractL expectedL = evalState (genericAutoWith options) 1
Type extractR expectedR = evalState (genericAutoWith options) 1
ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL
ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR
instance GenericInterpret f => GenericInterpret (M1 C c f) where
genericAutoWith options = do
res <- genericAutoWith options
pure (fmap M1 res)
instance GenericInterpret U1 where
genericAutoWith _ = pure (Type {..})
where
extract _ = pure U1
expected = Record (Dhall.Map.fromList [])
instance (GenericInterpret f, GenericInterpret g) => GenericInterpret (f :*: g) where
genericAutoWith options = do
Type extractL expectedL <- genericAutoWith options
Type extractR expectedR <- genericAutoWith options
let ktsL = unsafeExpectRecord "genericAutoWith (:*:)"expectedL
let ktsR = unsafeExpectRecord "genericAutoWith (:*:)"expectedR
pure
(Type
{ extract = liftA2 (liftA2 (:*:)) extractL extractR
, expected = Record (Dhall.Map.union ktsL ktsR)
}
)
getSelName :: Selector s => M1 i s f a -> State Int String
getSelName n = case selName n of
"" -> do i <- get
put (i + 1)
pure ("_" ++ show i)
nn -> pure nn
instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where
genericAutoWith opts@(InterpretOptions {..}) = do
name <- getSelName n
let expected =
Record (Dhall.Map.fromList [(key, expected')])
where
key = fieldModifier (Data.Text.pack name)
let extract expr@(RecordLit m) =
let name' = fieldModifier (Data.Text.pack name)
extract'' e = fmap (M1 . K1) (extract' e)
lookupRes = Dhall.Map.lookup name' m
typeError' = typeError expected expr
in Data.Maybe.maybe typeError' extract'' lookupRes
extract expr = typeError expected expr
pure (Type {..})
where
n :: M1 i s f a
n = undefined
Type extract' expected' = autoWith opts
data InputType a = InputType
{ embed :: a -> Expr Src X
, declared :: Expr Src X
}
instance Contravariant InputType where
contramap f (InputType embed declared) = InputType embed' declared
where
embed' x = embed (f x)
class Inject a where
injectWith :: InterpretOptions -> InputType a
default injectWith
:: (Generic a, GenericInject (Rep a)) => InterpretOptions -> InputType a
injectWith options
= contramap GHC.Generics.from (evalState (genericInjectWith options) 1)
inject :: Inject a => InputType a
inject = injectWith defaultInterpretOptions
genericInject
:: (Generic a, GenericInject (Rep a)) => InputType a
genericInject
= contramap GHC.Generics.from (evalState (genericInjectWith defaultInterpretOptions) 1)
instance Inject Bool where
injectWith _ = InputType {..}
where
embed = BoolLit
declared = Bool
instance Inject Data.Text.Lazy.Text where
injectWith _ = InputType {..}
where
embed text =
TextLit (Chunks [] (Data.Text.Lazy.toStrict text))
declared = Text
instance Inject Text where
injectWith _ = InputType {..}
where
embed text = TextLit (Chunks [] text)
declared = Text
instance {-# OVERLAPS #-} Inject String where
injectWith options =
contramap Data.Text.pack (injectWith options :: InputType Text)
instance Inject Natural where
injectWith _ = InputType {..}
where
embed = NaturalLit
declared = Natural
instance Inject Integer where
injectWith _ = InputType {..}
where
embed = IntegerLit
declared = Integer
instance Inject Int where
injectWith _ = InputType {..}
where
embed = IntegerLit . toInteger
declared = Integer
instance Inject Word8 where
injectWith _ = InputType {..}
where
embed = IntegerLit . toInteger
declared = Integer
instance Inject Word16 where
injectWith _ = InputType {..}
where
embed = IntegerLit . toInteger
declared = Integer
instance Inject Word32 where
injectWith _ = InputType {..}
where
embed = IntegerLit . toInteger
declared = Integer
instance Inject Word64 where
injectWith _ = InputType {..}
where
embed = IntegerLit . toInteger
declared = Integer
instance Inject Double where
injectWith _ = InputType {..}
where
embed = DoubleLit
declared = Double
instance Inject Scientific where
injectWith options =
contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double)
instance Inject () where
injectWith _ = InputType {..}
where
embed = const (RecordLit mempty)
declared = Record mempty
instance Inject a => Inject (Maybe a) where
injectWith options = InputType embedOut declaredOut
where
embedOut (Just x ) = Some (embedIn x)
embedOut Nothing = App None declaredIn
InputType embedIn declaredIn = injectWith options
declaredOut = App Optional declaredIn
instance Inject a => Inject (Seq a) where
injectWith options = InputType embedOut declaredOut
where
embedOut xs = ListLit listType (fmap embedIn xs)
where
listType
| null xs = Just (App List declaredIn)
| otherwise = Nothing
declaredOut = App List declaredIn
InputType embedIn declaredIn = injectWith options
instance Inject a => Inject [a] where
injectWith = fmap (contramap Data.Sequence.fromList) injectWith
instance Inject a => Inject (Vector a) where
injectWith = fmap (contramap Data.Vector.toList) injectWith
instance Inject a => Inject (Data.Set.Set a) where
injectWith = fmap (contramap Data.Set.toList) injectWith
instance (Inject a, Inject b) => Inject (a, b)
class GenericInject f where
genericInjectWith :: InterpretOptions -> State Int (InputType (f a))
instance GenericInject f => GenericInject (M1 D d f) where
genericInjectWith options = do
res <- genericInjectWith options
pure (contramap unM1 res)
instance GenericInject f => GenericInject (M1 C c f) where
genericInjectWith options = do
res <- genericInjectWith options
pure (contramap unM1 res)
instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
where
embed (L1 (M1 l)) =
case notEmptyRecordLit (embedL l) of
Nothing ->
Field declared keyL
Just valL ->
App (Field declared keyL) valL
embed (R1 (M1 r)) =
case notEmptyRecordLit (embedR r) of
Nothing ->
Field declared keyR
Just valR ->
App (Field declared keyR) valR
declared =
Union
(Dhall.Map.fromList
[ (keyL, notEmptyRecord declaredL)
, (keyR, notEmptyRecord declaredR)
]
)
nL :: M1 i c1 f1 a
nL = undefined
nR :: M1 i c2 f2 a
nR = undefined
keyL = constructorModifier (Data.Text.pack (conName nL))
keyR = constructorModifier (Data.Text.pack (conName nR))
InputType embedL declaredL = evalState (genericInjectWith options) 1
InputType embedR declaredR = evalState (genericInjectWith options) 1
instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInject ((f :+: g) :+: M1 C c h) where
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
where
embed (L1 l) =
case maybeValL of
Nothing -> Field declared keyL
Just valL -> App (Field declared keyL) valL
where
(keyL, maybeValL) =
unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l)
embed (R1 (M1 r)) =
case notEmptyRecordLit (embedR r) of
Nothing -> Field declared keyR
Just valR -> App (Field declared keyR) valR
nR :: M1 i c h a
nR = undefined
keyR = constructorModifier (Data.Text.pack (conName nR))
declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL)
InputType embedL declaredL = evalState (genericInjectWith options) 1
InputType embedR declaredR = evalState (genericInjectWith options) 1
ktsL = unsafeExpectUnion "genericInjectWith (:+:)" declaredL
instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
where
embed (L1 (M1 l)) =
case notEmptyRecordLit (embedL l) of
Nothing -> Field declared keyL
Just valL -> App (Field declared keyL) valL
embed (R1 r) =
case maybeValR of
Nothing -> Field declared keyR
Just valR -> App (Field declared keyR) valR
where
(keyR, maybeValR) =
unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r)
nL :: M1 i c f a
nL = undefined
keyL = constructorModifier (Data.Text.pack (conName nL))
declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR)
InputType embedL declaredL = evalState (genericInjectWith options) 1
InputType embedR declaredR = evalState (genericInjectWith options) 1
ktsR = unsafeExpectUnion "genericInjectWith (:+:)" declaredR
instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f :+: g) :+: (h :+: i)) where
genericInjectWith options = pure (InputType {..})
where
embed (L1 l) =
case maybeValL of
Nothing -> Field declared keyL
Just valL -> App (Field declared keyL) valL
where
(keyL, maybeValL) =
unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l)
embed (R1 r) =
case maybeValR of
Nothing -> Field declared keyR
Just valR -> App (Field declared keyR) valR
where
(keyR, maybeValR) =
unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r)
declared = Union (Dhall.Map.union ktsL ktsR)
InputType embedL declaredL = evalState (genericInjectWith options) 1
InputType embedR declaredR = evalState (genericInjectWith options) 1
ktsL = unsafeExpectUnion "genericInjectWith (:+:)" declaredL
ktsR = unsafeExpectUnion "genericInjectWith (:+:)" declaredR
instance (GenericInject f, GenericInject g) => GenericInject (f :*: g) where
genericInjectWith options = do
InputType embedInL declaredInL <- genericInjectWith options
InputType embedInR declaredInR <- genericInjectWith options
let embed (l :*: r) =
RecordLit (Dhall.Map.union mapL mapR)
where
mapL =
unsafeExpectRecordLit "genericInjectWith (:*:)" (embedInL l)
mapR =
unsafeExpectRecordLit "genericInjectWith (:*:)" (embedInR r)
let declared = Record (Dhall.Map.union mapL mapR)
where
mapL = unsafeExpectRecord "genericInjectWith (:*:)" declaredInL
mapR = unsafeExpectRecord "genericInjectWith (:*:)" declaredInR
pure (InputType {..})
instance GenericInject U1 where
genericInjectWith _ = pure (InputType {..})
where
embed _ = RecordLit mempty
declared = Record mempty
instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where
genericInjectWith opts@(InterpretOptions {..}) = do
name <- fieldModifier . Data.Text.pack <$> getSelName n
let embed (M1 (K1 x)) =
RecordLit (Dhall.Map.singleton name (embedIn x))
let declared =
Record (Dhall.Map.singleton name declaredIn)
pure (InputType {..})
where
n :: M1 i s f a
n = undefined
InputType embedIn declaredIn = injectWith opts
newtype RecordType a =
RecordType
( Data.Functor.Product.Product
( Control.Applicative.Const
( Dhall.Map.Map
Text
( Expr Src X )
)
)
( Data.Functor.Compose.Compose
( (->) ( Expr Src X ) )
(Extractor Src X)
)
a
)
deriving (Functor, Applicative)
record :: RecordType a -> Dhall.Type a
record ( RecordType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Data.Functor.Compose.Compose extractF ) ) ) =
Type
{ extract =
extractF
, expected =
Record fields
}
field :: Text -> Type a -> RecordType a
field key valueType@(Type extract expected) =
let
extractBody expr@(RecordLit fields) = case Dhall.Map.lookup key fields of
Just v -> extract v
_ -> typeError expected expr
extractBody expr = typeError expected expr
in
RecordType
( Data.Functor.Product.Pair
( Control.Applicative.Const
( Dhall.Map.singleton
key
( Dhall.expected valueType )
)
)
( Data.Functor.Compose.Compose extractBody )
)
newtype UnionType a =
UnionType
( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Type a )
deriving (Functor)
instance Data.Semigroup.Semigroup (UnionType a) where
(<>) = coerce ((<>) :: Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a))
instance Monoid (UnionType a) where
mempty = coerce (mempty :: Dhall.Map.Map Text (Type a))
mappend = (Data.Semigroup.<>)
union :: UnionType a -> Type a
union (UnionType (Data.Functor.Compose.Compose mp)) = Type
{ extract = extractF
, expected = Union expect
}
where
expect = (notEmptyRecord . Dhall.expected) <$> mp
extractF e0 =
let result = do
(fld, e1, rest) <- extractUnionConstructor e0
t <- Dhall.Map.lookup fld mp
guard $ Dhall.Core.Union rest `Dhall.Core.judgmentallyEqual`
Dhall.Core.Union (Dhall.Map.delete fld expect)
pure (t, e1)
in Data.Maybe.maybe (typeError (Union expect) e0) (uncurry extract) result
constructor :: Text -> Type a -> UnionType a
constructor key valueType = UnionType
( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueType) )
(>*<) :: Divisible f => f a -> f b -> f (a, b)
(>*<) = divided
infixr 5 >*<
newtype RecordInputType a
= RecordInputType (Dhall.Map.Map Text (InputType a))
instance Contravariant RecordInputType where
contramap f (RecordInputType inputTypeRecord) = RecordInputType $ contramap f <$> inputTypeRecord
instance Divisible RecordInputType where
divide f (RecordInputType bInputTypeRecord) (RecordInputType cInputTypeRecord) =
RecordInputType
$ Dhall.Map.union
((contramap $ fst . f) <$> bInputTypeRecord)
((contramap $ snd . f) <$> cInputTypeRecord)
conquer = RecordInputType mempty
inputFieldWith :: Text -> InputType a -> RecordInputType a
inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType
inputField :: Inject a => Text -> RecordInputType a
inputField name = inputFieldWith name inject
inputRecord :: RecordInputType a -> InputType a
inputRecord (RecordInputType inputTypeRecord) = InputType makeRecordLit recordType
where
recordType = Record $ declared <$> inputTypeRecord
makeRecordLit x = RecordLit $ (($ x) . embed) <$> inputTypeRecord
newtype UnionInputType a =
UnionInputType
( Data.Functor.Product.Product
( Control.Applicative.Const
( Dhall.Map.Map
Text
( Expr Src X )
)
)
( Op (Text, Expr Src X) )
a
)
deriving (Contravariant)
(>|<) :: UnionInputType a -> UnionInputType b -> UnionInputType (Either a b)
UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx))
>|< UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) =
UnionInputType
( Data.Functor.Product.Pair
( Control.Applicative.Const (mx <> my) )
( Op (either fx fy) )
)
infixr 5 >|<
inputUnion :: UnionInputType a -> InputType a
inputUnion ( UnionInputType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) =
InputType
{ embed = \x ->
let (name, y) = embedF x
in case notEmptyRecordLit y of
Nothing -> Field (Union fields') name
Just val -> App (Field (Union fields') name) val
, declared =
Union fields'
}
where
fields' = fmap notEmptyRecord fields
inputConstructorWith
:: Text
-> InputType a
-> UnionInputType a
inputConstructorWith name inputType = UnionInputType $
Data.Functor.Product.Pair
( Control.Applicative.Const
( Dhall.Map.singleton
name
( declared inputType )
)
)
( Op ( (name,) . embed inputType )
)
inputConstructor
:: Inject a
=> Text
-> UnionInputType a
inputConstructor name = inputConstructorWith name inject