2614 lines
81 KiB
Haskell
2614 lines
81 KiB
Haskell
{-# 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 #-}
|
|
|
|
{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
|
|
how to use the language, the compiler, and this library
|
|
-}
|
|
|
|
module Dhall
|
|
(
|
|
-- * Input
|
|
input
|
|
, inputWithSettings
|
|
, inputFile
|
|
, inputFileWithSettings
|
|
, inputExpr
|
|
, inputExprWithSettings
|
|
, rootDirectory
|
|
, sourceName
|
|
, startingContext
|
|
, normalizer
|
|
, defaultInputSettings
|
|
, InputSettings
|
|
, defaultEvaluateSettings
|
|
, EvaluateSettings
|
|
, HasEvaluateSettings
|
|
, detailed
|
|
|
|
-- * Types
|
|
, Type (..)
|
|
, RecordType(..)
|
|
, UnionType(..)
|
|
, InputType(..)
|
|
, FromDhall(..)
|
|
, Interpret
|
|
, InvalidType(..)
|
|
, ExtractErrors(..)
|
|
, Extractor
|
|
, MonadicExtractor
|
|
, typeError
|
|
, extractError
|
|
, toMonadic
|
|
, fromMonadic
|
|
, auto
|
|
, genericAuto
|
|
, InterpretOptions(..)
|
|
, SingletonConstructors(..)
|
|
, defaultInterpretOptions
|
|
, bool
|
|
, natural
|
|
, integer
|
|
, scientific
|
|
, double
|
|
, lazyText
|
|
, strictText
|
|
, maybe
|
|
, sequence
|
|
, list
|
|
, vector
|
|
, setFromDistinctList
|
|
, setIgnoringDuplicates
|
|
, hashSetFromDistinctList
|
|
, hashSetIgnoringDuplicates
|
|
, Dhall.map
|
|
, hashMap
|
|
, pairFromMapEntry
|
|
, unit
|
|
, void
|
|
, string
|
|
, pair
|
|
, record
|
|
, field
|
|
, union
|
|
, constructor
|
|
, GenericFromDhall(..)
|
|
, GenericToDhall(..)
|
|
|
|
, ToDhall(..)
|
|
, Inject
|
|
, inject
|
|
, genericToDhall
|
|
, RecordInputType(..)
|
|
, inputFieldWith
|
|
, inputField
|
|
, inputRecord
|
|
, UnionInputType(..)
|
|
, inputConstructorWith
|
|
, inputConstructor
|
|
, inputUnion
|
|
, (>|<)
|
|
|
|
-- * Miscellaneous
|
|
, rawInput
|
|
, (>$<)
|
|
, (>*<)
|
|
|
|
-- * Re-exports
|
|
, 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.Hashable (Hashable)
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.Map (Map)
|
|
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.Void (Void)
|
|
import Data.Word (Word8, Word16, Word32, Word64)
|
|
import Dhall.Syntax (Expr(..), Chunks(..), DhallDouble(..))
|
|
import Dhall.Import (Imported(..))
|
|
import Dhall.Parser (Src(..))
|
|
import Dhall.TypeCheck (DetailedTypeError(..), TypeError)
|
|
import GHC.Generics
|
|
import Lens.Family (LensLike', 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.HashMap.Strict as HashMap
|
|
import qualified Data.Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.List
|
|
import qualified Data.List.NonEmpty
|
|
import qualified Data.Semigroup
|
|
import qualified Data.Scientific
|
|
import qualified Data.Sequence
|
|
import qualified Data.Set
|
|
import qualified Data.HashSet
|
|
import qualified Data.Text
|
|
import qualified Data.Text.IO
|
|
import qualified Data.Text.Lazy
|
|
import qualified Data.Vector
|
|
import qualified Data.Void
|
|
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
|
|
import qualified Lens.Family
|
|
|
|
-- $setup
|
|
-- >>> :set -XOverloadedStrings
|
|
-- >>> :set -XRecordWildCards
|
|
-- >>> import Data.Word (Word8, Word16, Word32, Word64)
|
|
-- >>> import Dhall.Pretty.Internal (prettyExpr)
|
|
|
|
{-| Useful synonym for the `Validation` type used when marshalling Dhall
|
|
expressions
|
|
-}
|
|
type Extractor s a = Validation (ExtractErrors s a)
|
|
|
|
{-| Useful synonym for the equivalent `Either` type used when marshalling Dhall
|
|
code
|
|
-}
|
|
type MonadicExtractor s a = Either (ExtractErrors s a)
|
|
|
|
{-| Generate a type error during extraction by specifying the expected type
|
|
and the actual type
|
|
-}
|
|
typeError :: Expr s a -> Expr s a -> Extractor s a b
|
|
typeError expected actual =
|
|
Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual
|
|
|
|
-- | Turn a `Text` message into an extraction failure
|
|
extractError :: Text -> Extractor s a b
|
|
extractError = Failure . ExtractErrors . pure . ExtractError
|
|
|
|
-- | Switches from an @Applicative@ extraction result, able to accumulate errors,
|
|
-- to a @Monad@ extraction result, able to chain sequential operations
|
|
toMonadic :: Extractor s a b -> MonadicExtractor s a b
|
|
toMonadic = validationToEither
|
|
|
|
-- | Switches from a @Monad@ extraction result, able to chain sequential errors,
|
|
-- to an @Applicative@ extraction result, able to accumulate errors
|
|
fromMonadic :: MonadicExtractor s a b -> Extractor s a b
|
|
fromMonadic = eitherToValidation
|
|
|
|
{-| One or more errors returned from extracting a Dhall expression to a
|
|
Haskell expression
|
|
-}
|
|
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)
|
|
|
|
{-| Extraction of a value can fail for two reasons, either a type mismatch (which should not happen,
|
|
as expressions are type-checked against the expected type before being passed to @extract@), or
|
|
a term-level error, described with a freeform text value.
|
|
-}
|
|
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)
|
|
|
|
{-| Every `Type` must obey the contract that if an expression's type matches the
|
|
the `expected` type then the `extract` function must not fail with a type error.
|
|
If not, then this value is returned.
|
|
|
|
This value indicates that an invalid `Type` was provided to the `input`
|
|
function
|
|
-}
|
|
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
|
|
|
|
-- | @since 1.16
|
|
data InputSettings = InputSettings
|
|
{ _rootDirectory :: FilePath
|
|
, _sourceName :: FilePath
|
|
, _evaluateSettings :: EvaluateSettings
|
|
}
|
|
|
|
-- | Default input settings: resolves imports relative to @.@ (the
|
|
-- current working directory), report errors as coming from @(input)@,
|
|
-- and default evaluation settings from 'defaultEvaluateSettings'.
|
|
--
|
|
-- @since 1.16
|
|
defaultInputSettings :: InputSettings
|
|
defaultInputSettings = InputSettings
|
|
{ _rootDirectory = "."
|
|
, _sourceName = "(input)"
|
|
, _evaluateSettings = defaultEvaluateSettings
|
|
}
|
|
|
|
-- | Access the directory to resolve imports relative to.
|
|
--
|
|
-- @since 1.16
|
|
rootDirectory
|
|
:: (Functor f)
|
|
=> LensLike' f InputSettings FilePath
|
|
rootDirectory k s =
|
|
fmap (\x -> s { _rootDirectory = x }) (k (_rootDirectory s))
|
|
|
|
-- | Access the name of the source to report locations from; this is
|
|
-- only used in error messages, so it's okay if this is a best guess
|
|
-- or something symbolic.
|
|
--
|
|
-- @since 1.16
|
|
sourceName
|
|
:: (Functor f)
|
|
=> LensLike' f InputSettings FilePath
|
|
sourceName k s =
|
|
fmap (\x -> s { _sourceName = x}) (k (_sourceName s))
|
|
|
|
-- | @since 1.16
|
|
data EvaluateSettings = EvaluateSettings
|
|
{ _startingContext :: Dhall.Context.Context (Expr Src Void)
|
|
, _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer Void)
|
|
}
|
|
|
|
-- | Default evaluation settings: no extra entries in the initial
|
|
-- context, and no special normalizer behaviour.
|
|
--
|
|
-- @since 1.16
|
|
defaultEvaluateSettings :: EvaluateSettings
|
|
defaultEvaluateSettings = EvaluateSettings
|
|
{ _startingContext = Dhall.Context.empty
|
|
, _normalizer = Nothing
|
|
}
|
|
|
|
-- | Access the starting context used for evaluation and type-checking.
|
|
--
|
|
-- @since 1.16
|
|
startingContext
|
|
:: (Functor f, HasEvaluateSettings s)
|
|
=> LensLike' f s (Dhall.Context.Context (Expr Src Void))
|
|
startingContext = evaluateSettings . l
|
|
where
|
|
l :: (Functor f)
|
|
=> LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src Void))
|
|
l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s))
|
|
|
|
-- | Access the custom normalizer.
|
|
--
|
|
-- @since 1.16
|
|
normalizer
|
|
:: (Functor f, HasEvaluateSettings s)
|
|
=> LensLike' f s (Maybe (Dhall.Core.ReifiedNormalizer Void))
|
|
normalizer = evaluateSettings . l
|
|
where
|
|
l :: (Functor f)
|
|
=> LensLike' f EvaluateSettings (Maybe (Dhall.Core.ReifiedNormalizer Void))
|
|
l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))
|
|
|
|
-- | @since 1.16
|
|
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
|
|
|
|
{-| Type-check and evaluate a Dhall program, decoding the result into Haskell
|
|
|
|
The first argument determines the type of value that you decode:
|
|
|
|
>>> input integer "+2"
|
|
2
|
|
>>> input (vector double) "[1.0, 2.0]"
|
|
[1.0,2.0]
|
|
|
|
Use `auto` to automatically select which type to decode based on the
|
|
inferred return type:
|
|
|
|
>>> input auto "True" :: IO Bool
|
|
True
|
|
|
|
This uses the settings from 'defaultInputSettings'.
|
|
-}
|
|
input
|
|
:: Type a
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
-> Text
|
|
-- ^ The Dhall program
|
|
-> IO a
|
|
-- ^ The decoded value in Haskell
|
|
input =
|
|
inputWithSettings defaultInputSettings
|
|
|
|
{-| Extend 'input' with a root directory to resolve imports relative
|
|
to, a file to mention in errors as the source, a custom typing
|
|
context, and a custom normalization process.
|
|
|
|
@since 1.16
|
|
-}
|
|
inputWithSettings
|
|
:: InputSettings
|
|
-> Type a
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
-> Text
|
|
-- ^ The Dhall program
|
|
-> IO a
|
|
-- ^ The decoded value in Haskell
|
|
inputWithSettings settings (Type {..}) txt = do
|
|
expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt)
|
|
|
|
let InputSettings {..} = settings
|
|
|
|
let EvaluateSettings {..} = _evaluateSettings
|
|
|
|
let transform =
|
|
Lens.Family.set Dhall.Import.normalizer _normalizer
|
|
. Lens.Family.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
|
|
|
|
{-| Type-check and evaluate a Dhall program that is read from the
|
|
file-system.
|
|
|
|
This uses the settings from 'defaultEvaluateSettings'.
|
|
|
|
@since 1.16
|
|
-}
|
|
inputFile
|
|
:: Type a
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
-> FilePath
|
|
-- ^ The path to the Dhall program.
|
|
-> IO a
|
|
-- ^ The decoded value in Haskell.
|
|
inputFile =
|
|
inputFileWithSettings defaultEvaluateSettings
|
|
|
|
{-| Extend 'inputFile' with a custom typing context and a custom
|
|
normalization process.
|
|
|
|
@since 1.16
|
|
-}
|
|
inputFileWithSettings
|
|
:: EvaluateSettings
|
|
-> Type a
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
-> FilePath
|
|
-- ^ The path to the Dhall program.
|
|
-> IO a
|
|
-- ^ The decoded value in Haskell.
|
|
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
|
|
|
|
{-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell
|
|
type.
|
|
|
|
Uses the settings from 'defaultInputSettings'.
|
|
-}
|
|
inputExpr
|
|
:: Text
|
|
-- ^ The Dhall program
|
|
-> IO (Expr Src Void)
|
|
-- ^ The fully normalized AST
|
|
inputExpr =
|
|
inputExprWithSettings defaultInputSettings
|
|
|
|
{-| Extend 'inputExpr' with a root directory to resolve imports relative
|
|
to, a file to mention in errors as the source, a custom typing
|
|
context, and a custom normalization process.
|
|
|
|
@since 1.16
|
|
-}
|
|
inputExprWithSettings
|
|
:: InputSettings
|
|
-> Text
|
|
-- ^ The Dhall program
|
|
-> IO (Expr Src Void)
|
|
-- ^ The fully normalized AST
|
|
inputExprWithSettings settings txt = do
|
|
expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt)
|
|
|
|
let InputSettings {..} = settings
|
|
|
|
let EvaluateSettings {..} = _evaluateSettings
|
|
|
|
let transform =
|
|
Lens.Family.set Dhall.Import.normalizer _normalizer
|
|
. Lens.Family.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')
|
|
|
|
-- | Use this function to extract Haskell values directly from Dhall AST.
|
|
-- The intended use case is to allow easy extraction of Dhall values for
|
|
-- making the function `Dhall.Core.normalizeWith` easier to use.
|
|
--
|
|
-- For other use cases, use `input` from `Dhall` module. It will give you
|
|
-- a much better user experience.
|
|
rawInput
|
|
:: Alternative f
|
|
=> Type a
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
-> Expr s Void
|
|
-- ^ a closed form Dhall program, which evaluates to the expected type
|
|
-> f a
|
|
-- ^ The decoded value in Haskell
|
|
rawInput (Type {..}) expr = do
|
|
case extract (Dhall.Core.normalize expr) of
|
|
Success x -> pure x
|
|
Failure _e -> empty
|
|
|
|
{-| Use this to provide more detailed error messages
|
|
|
|
>> input auto "True" :: IO Integer
|
|
> *** Exception: Error: Expression doesn't match annotation
|
|
>
|
|
> True : Integer
|
|
>
|
|
> (input):1:1
|
|
|
|
>> detailed (input auto "True") :: IO Integer
|
|
> *** Exception: Error: Expression doesn't match annotation
|
|
>
|
|
> Explanation: You can annotate an expression with its type or kind using the
|
|
> ❰:❱ symbol, like this:
|
|
>
|
|
>
|
|
> ┌───────┐
|
|
> │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱
|
|
> └───────┘
|
|
>
|
|
> The type checker verifies that the expression's type or kind matches the
|
|
> provided annotation
|
|
>
|
|
> For example, all of the following are valid annotations that the type checker
|
|
> accepts:
|
|
>
|
|
>
|
|
> ┌─────────────┐
|
|
> │ 1 : Natural │ ❰1❱ is an expression that has type ❰Natural❱, so the type
|
|
> └─────────────┘ checker accepts the annotation
|
|
>
|
|
>
|
|
> ┌───────────────────────┐
|
|
> │ Natural/even 2 : Bool │ ❰Natural/even 2❱ has type ❰Bool❱, so the type
|
|
> └───────────────────────┘ checker accepts the annotation
|
|
>
|
|
>
|
|
> ┌────────────────────┐
|
|
> │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱,
|
|
> └────────────────────┘ so the type checker accepts the annotation
|
|
>
|
|
>
|
|
> ┌──────────────────┐
|
|
> │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so
|
|
> └──────────────────┘ the type checker accepts the annotation
|
|
>
|
|
>
|
|
> However, the following annotations are not valid and the type checker will
|
|
> reject them:
|
|
>
|
|
>
|
|
> ┌──────────┐
|
|
> │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type
|
|
> └──────────┘ ❰Text❱
|
|
>
|
|
>
|
|
> ┌─────────────┐
|
|
> │ List : Type │ ❰List❱ does not have kind ❰Type❱
|
|
> └─────────────┘
|
|
>
|
|
>
|
|
> You or the interpreter annotated this expression:
|
|
>
|
|
> ↳ True
|
|
>
|
|
> ... with this type or kind:
|
|
>
|
|
> ↳ Integer
|
|
>
|
|
> ... but the inferred type or kind of the expression is actually:
|
|
>
|
|
> ↳ Bool
|
|
>
|
|
> Some common reasons why you might get this error:
|
|
>
|
|
> ● The Haskell Dhall interpreter implicitly inserts a top-level annotation
|
|
> matching the expected type
|
|
>
|
|
> For example, if you run the following Haskell code:
|
|
>
|
|
>
|
|
> ┌───────────────────────────────┐
|
|
> │ >>> input auto "1" :: IO Text │
|
|
> └───────────────────────────────┘
|
|
>
|
|
>
|
|
> ... then the interpreter will actually type check the following annotated
|
|
> expression:
|
|
>
|
|
>
|
|
> ┌──────────┐
|
|
> │ 1 : Text │
|
|
> └──────────┘
|
|
>
|
|
>
|
|
> ... and then type-checking will fail
|
|
>
|
|
> ────────────────────────────────────────────────────────────────────────────────
|
|
>
|
|
> True : Integer
|
|
>
|
|
> (input):1:1
|
|
|
|
-}
|
|
detailed :: IO a -> IO a
|
|
detailed =
|
|
Control.Exception.handle handler1 . Control.Exception.handle handler0
|
|
where
|
|
handler0 :: Imported (TypeError Src Void) -> IO a
|
|
handler0 (Imported ps e) =
|
|
Control.Exception.throwIO (Imported ps (DetailedTypeError e))
|
|
|
|
handler1 :: TypeError Src Void -> IO a
|
|
handler1 e = Control.Exception.throwIO (DetailedTypeError e)
|
|
|
|
{-| A @(Type a)@ represents a way to marshal a value of type @\'a\'@ from Dhall
|
|
into Haskell
|
|
|
|
You can produce `Type`s either explicitly:
|
|
|
|
> example :: Type (Vector Text)
|
|
> example = vector text
|
|
|
|
... or implicitly using `auto`:
|
|
|
|
> example :: Type (Vector Text)
|
|
> example = auto
|
|
|
|
You can consume `Type`s using the `input` function:
|
|
|
|
> input :: Type a -> Text -> IO a
|
|
-}
|
|
data Type a = Type
|
|
{ extract :: Expr Src Void -> Extractor Src Void a
|
|
-- ^ Extracts Haskell value from the Dhall expression
|
|
, expected :: Expr Src Void
|
|
-- ^ Dhall type of the Haskell value
|
|
}
|
|
deriving (Functor)
|
|
|
|
{-| Decode a `Bool`
|
|
|
|
>>> input bool "True"
|
|
True
|
|
-}
|
|
bool :: Type Bool
|
|
bool = Type {..}
|
|
where
|
|
extract (BoolLit b) = pure b
|
|
extract expr = typeError expected expr
|
|
|
|
expected = Bool
|
|
|
|
{-| Decode a `Natural`
|
|
|
|
>>> input natural "42"
|
|
42
|
|
-}
|
|
natural :: Type Natural
|
|
natural = Type {..}
|
|
where
|
|
extract (NaturalLit n) = pure n
|
|
extract expr = typeError Natural expr
|
|
|
|
expected = Natural
|
|
|
|
{-| Decode an `Integer`
|
|
|
|
>>> input integer "+42"
|
|
42
|
|
-}
|
|
integer :: Type Integer
|
|
integer = Type {..}
|
|
where
|
|
extract (IntegerLit n) = pure n
|
|
extract expr = typeError Integer expr
|
|
|
|
expected = Integer
|
|
|
|
{-| Decode a `Scientific`
|
|
|
|
>>> input scientific "1e100"
|
|
1.0e100
|
|
-}
|
|
scientific :: Type Scientific
|
|
scientific = fmap Data.Scientific.fromFloatDigits double
|
|
|
|
{-| Decode a `Double`
|
|
|
|
>>> input double "42.0"
|
|
42.0
|
|
-}
|
|
double :: Type Double
|
|
double = Type {..}
|
|
where
|
|
extract (DoubleLit (DhallDouble n)) = pure n
|
|
extract expr = typeError Double expr
|
|
|
|
expected = Double
|
|
|
|
{-| Decode lazy `Text`
|
|
|
|
>>> input lazyText "\"Test\""
|
|
"Test"
|
|
-}
|
|
lazyText :: Type Data.Text.Lazy.Text
|
|
lazyText = fmap Data.Text.Lazy.fromStrict strictText
|
|
|
|
{-| Decode strict `Text`
|
|
|
|
>>> input strictText "\"Test\""
|
|
"Test"
|
|
-}
|
|
strictText :: Type Text
|
|
strictText = Type {..}
|
|
where
|
|
extract (TextLit (Chunks [] t)) = pure t
|
|
extract expr = typeError Text expr
|
|
|
|
expected = Text
|
|
{-| Decode a `Maybe`
|
|
|
|
>>> input (maybe natural) "Some 1"
|
|
Just 1
|
|
-}
|
|
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
|
|
|
|
{-| Decode a `Seq`
|
|
|
|
>>> input (sequence natural) "[1, 2, 3]"
|
|
fromList [1,2,3]
|
|
-}
|
|
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
|
|
|
|
{-| Decode a list
|
|
|
|
>>> input (list natural) "[1, 2, 3]"
|
|
[1,2,3]
|
|
-}
|
|
list :: Type a -> Type [a]
|
|
list = fmap Data.Foldable.toList . sequence
|
|
|
|
{-| Decode a `Vector`
|
|
|
|
>>> input (vector natural) "[1, 2, 3]"
|
|
[1,2,3]
|
|
-}
|
|
vector :: Type a -> Type (Vector a)
|
|
vector = fmap Data.Vector.fromList . list
|
|
|
|
{-| Decode a `Set` from a `List`
|
|
|
|
>>> input (setIgnoringDuplicates natural) "[1, 2, 3]"
|
|
fromList [1,2,3]
|
|
|
|
Duplicate elements are ignored.
|
|
|
|
>>> input (setIgnoringDuplicates natural) "[1, 1, 3]"
|
|
fromList [1,3]
|
|
|
|
-}
|
|
setIgnoringDuplicates :: (Ord a) => Type a -> Type (Data.Set.Set a)
|
|
setIgnoringDuplicates = fmap Data.Set.fromList . list
|
|
|
|
{-| Decode a `HashSet` from a `List`
|
|
|
|
>>> input (hashSetIgnoringDuplicates natural) "[1, 2, 3]"
|
|
fromList [1,2,3]
|
|
|
|
Duplicate elements are ignored.
|
|
|
|
>>> input (hashSetIgnoringDuplicates natural) "[1, 1, 3]"
|
|
fromList [1,3]
|
|
|
|
-}
|
|
hashSetIgnoringDuplicates :: (Hashable a, Ord a)
|
|
=> Type a
|
|
-> Type (Data.HashSet.HashSet a)
|
|
hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list
|
|
|
|
{-| Decode a `Set` from a `List` with distinct elements
|
|
|
|
>>> input (setFromDistinctList natural) "[1, 2, 3]"
|
|
fromList [1,2,3]
|
|
|
|
An error is thrown if the list contains duplicates.
|
|
|
|
> >>> input (setFromDistinctList natural) "[1, 1, 3]"
|
|
> *** Exception: Error: Failed extraction
|
|
>
|
|
> The expression type-checked successfully but the transformation to the target
|
|
> type failed with the following error:
|
|
>
|
|
> One duplicate element in the list: 1
|
|
>
|
|
|
|
> >>> input (setFromDistinctList natural) "[1, 1, 3, 3]"
|
|
> *** Exception: Error: Failed extraction
|
|
>
|
|
> The expression type-checked successfully but the transformation to the target
|
|
> type failed with the following error:
|
|
>
|
|
> 2 duplicates were found in the list, including 1
|
|
>
|
|
|
|
-}
|
|
setFromDistinctList :: (Ord a, Show a) => Type a -> Type (Data.Set.Set a)
|
|
setFromDistinctList = setHelper Data.Set.size Data.Set.fromList
|
|
|
|
{-| Decode a `HashSet` from a `List` with distinct elements
|
|
|
|
>>> input (hashSetFromDistinctList natural) "[1, 2, 3]"
|
|
fromList [1,2,3]
|
|
|
|
An error is thrown if the list contains duplicates.
|
|
|
|
> >>> input (hashSetFromDistinctList natural) "[1, 1, 3]"
|
|
> *** Exception: Error: Failed extraction
|
|
>
|
|
> The expression type-checked successfully but the transformation to the target
|
|
> type failed with the following error:
|
|
>
|
|
> One duplicate element in the list: 1
|
|
>
|
|
|
|
> >>> input (hashSetFromDistinctList natural) "[1, 1, 3, 3]"
|
|
> *** Exception: Error: Failed extraction
|
|
>
|
|
> The expression type-checked successfully but the transformation to the target
|
|
> type failed with the following error:
|
|
>
|
|
> 2 duplicates were found in the list, including 1
|
|
>
|
|
|
|
-}
|
|
hashSetFromDistinctList :: (Hashable a, Ord a, Show a)
|
|
=> Type a
|
|
-> Type (Data.HashSet.HashSet a)
|
|
hashSetFromDistinctList = setHelper Data.HashSet.size Data.HashSet.fromList
|
|
|
|
|
|
setHelper :: (Eq a, Foldable t, Show a)
|
|
=> (t a -> Int)
|
|
-> ([a] -> t a)
|
|
-> Type a
|
|
-> Type (t a)
|
|
setHelper size toSet (Type extractIn expectedIn) = Type extractOut expectedOut
|
|
where
|
|
extractOut (ListLit _ es) = case traverse extractIn es of
|
|
Success vSeq
|
|
| sameSize -> Success vSet
|
|
| otherwise -> extractError err
|
|
where
|
|
vList = Data.Foldable.toList vSeq
|
|
vSet = toSet vList
|
|
sameSize = size vSet == Data.Sequence.length vSeq
|
|
duplicates = vList Data.List.\\ Data.Foldable.toList vSet
|
|
err | length duplicates == 1 =
|
|
"One duplicate element in the list: "
|
|
<> (Data.Text.pack $ show $ head duplicates)
|
|
| otherwise = Data.Text.pack $ unwords
|
|
[ show $ length duplicates
|
|
, "duplicates were found in the list, including"
|
|
, show $ head duplicates
|
|
]
|
|
Failure f -> Failure f
|
|
extractOut expr = typeError expectedOut expr
|
|
|
|
expectedOut = App List expectedIn
|
|
|
|
{-| Decode a `Map` from a @toMap@ expression or generally a @Prelude.Map.Type@
|
|
|
|
>>> input (Dhall.map strictText bool) "toMap { a = True, b = False }"
|
|
fromList [("a",True),("b",False)]
|
|
>>> input (Dhall.map strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]"
|
|
fromList [("foo",True)]
|
|
|
|
If there are duplicate @mapKey@s, later @mapValue@s take precedence:
|
|
|
|
>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]"
|
|
>>> input (Dhall.map natural bool) expr
|
|
fromList [(1,False)]
|
|
|
|
-}
|
|
map :: Ord k => Type k -> Type v -> Type (Map k v)
|
|
map k v = fmap Data.Map.fromList (list (pairFromMapEntry k v))
|
|
|
|
{-| Decode a `HashMap` from a @toMap@ expression or generally a @Prelude.Map.Type@
|
|
|
|
>>> input (Dhall.hashMap strictText bool) "toMap { a = True, b = False }"
|
|
fromList [("a",True),("b",False)]
|
|
>>> input (Dhall.hashMap strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]"
|
|
fromList [("foo",True)]
|
|
|
|
If there are duplicate @mapKey@s, later @mapValue@s take precedence:
|
|
|
|
>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]"
|
|
>>> input (Dhall.hashMap natural bool) expr
|
|
fromList [(1,False)]
|
|
|
|
-}
|
|
hashMap :: (Eq k, Hashable k) => Type k -> Type v -> Type (HashMap k v)
|
|
hashMap k v = fmap HashMap.fromList (list (pairFromMapEntry k v))
|
|
|
|
{-| Decode a tuple from a @Prelude.Map.Entry@ record
|
|
|
|
>>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }"
|
|
("foo",3)
|
|
-}
|
|
pairFromMapEntry :: Type k -> Type v -> Type (k, v)
|
|
pairFromMapEntry k v = Type extractOut expectedOut
|
|
where
|
|
extractOut (RecordLit kvs)
|
|
| Just key <- Dhall.Map.lookup "mapKey" kvs
|
|
, Just value <- Dhall.Map.lookup "mapValue" kvs
|
|
= liftA2 (,) (extract k key) (extract v value)
|
|
extractOut expr = typeError expectedOut expr
|
|
|
|
expectedOut = Record (Dhall.Map.fromList [("mapKey", expected k), ("mapValue", expected v)])
|
|
|
|
{-| Decode @()@ from an empty record.
|
|
|
|
>>> input unit "{=}" -- GHC doesn't print the result if it is ()
|
|
|
|
-}
|
|
unit :: Type ()
|
|
unit = Type extractOut expectedOut
|
|
where
|
|
extractOut (RecordLit fields)
|
|
| Data.Foldable.null fields = pure ()
|
|
extractOut expr = typeError (Record mempty) expr
|
|
|
|
expectedOut = Record mempty
|
|
|
|
{-| Decode 'Void' from an empty union.
|
|
|
|
Since @<>@ is uninhabited, @'input' 'void'@ will always fail.
|
|
-}
|
|
void :: Type Void
|
|
void = union mempty
|
|
|
|
{-| Decode a `String`
|
|
|
|
>>> input string "\"ABC\""
|
|
"ABC"
|
|
|
|
-}
|
|
string :: Type String
|
|
string = Data.Text.Lazy.unpack <$> lazyText
|
|
|
|
{-| Given a pair of `Type`s, decode a tuple-record into their pairing.
|
|
|
|
>>> input (pair natural bool) "{ _1 = 42, _2 = False }"
|
|
(42,False)
|
|
-}
|
|
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)
|
|
]
|
|
)
|
|
|
|
{-| Any value that implements `FromDhall` can be automatically decoded based on
|
|
the inferred return type of `input`
|
|
|
|
>>> input auto "[1, 2, 3]" :: IO (Vector Natural)
|
|
[1,2,3]
|
|
>>> input auto "toMap { a = False, b = True }" :: IO (Map Text Bool)
|
|
fromList [("a",False),("b",True)]
|
|
|
|
This class auto-generates a default implementation for records that
|
|
implement `Generic`. This does not auto-generate an instance for recursive
|
|
types.
|
|
-}
|
|
class FromDhall a where
|
|
autoWith:: InterpretOptions -> Type a
|
|
default autoWith
|
|
:: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Type a
|
|
autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1)
|
|
|
|
{-| A compatibility alias for `FromDhall`
|
|
|
|
This will eventually be removed.
|
|
-}
|
|
type Interpret = FromDhall
|
|
|
|
instance FromDhall Void where
|
|
autoWith _ = void
|
|
|
|
instance FromDhall () where
|
|
autoWith _ = unit
|
|
|
|
instance FromDhall Bool where
|
|
autoWith _ = bool
|
|
|
|
instance FromDhall Natural where
|
|
autoWith _ = natural
|
|
|
|
instance FromDhall Integer where
|
|
autoWith _ = integer
|
|
|
|
instance FromDhall Scientific where
|
|
autoWith _ = scientific
|
|
|
|
instance FromDhall Double where
|
|
autoWith _ = double
|
|
|
|
instance {-# OVERLAPS #-} FromDhall [Char] where
|
|
autoWith _ = string
|
|
|
|
instance FromDhall Data.Text.Lazy.Text where
|
|
autoWith _ = lazyText
|
|
|
|
instance FromDhall Text where
|
|
autoWith _ = strictText
|
|
|
|
instance FromDhall a => FromDhall (Maybe a) where
|
|
autoWith opts = maybe (autoWith opts)
|
|
|
|
instance FromDhall a => FromDhall (Seq a) where
|
|
autoWith opts = sequence (autoWith opts)
|
|
|
|
instance FromDhall a => FromDhall [a] where
|
|
autoWith opts = list (autoWith opts)
|
|
|
|
instance FromDhall a => FromDhall (Vector a) where
|
|
autoWith opts = vector (autoWith opts)
|
|
|
|
{-| Note that this instance will throw errors in the presence of duplicates in
|
|
the list. To ignore duplicates, use `setIgnoringDuplicates`.
|
|
-}
|
|
instance (FromDhall a, Ord a, Show a) => FromDhall (Data.Set.Set a) where
|
|
autoWith opts = setFromDistinctList (autoWith opts)
|
|
|
|
{-| Note that this instance will throw errors in the presence of duplicates in
|
|
the list. To ignore duplicates, use `hashSetIgnoringDuplicates`.
|
|
-}
|
|
instance (FromDhall a, Hashable a, Ord a, Show a) => FromDhall (Data.HashSet.HashSet a) where
|
|
autoWith opts = hashSetFromDistinctList (autoWith opts)
|
|
|
|
instance (Ord k, FromDhall k, FromDhall v) => FromDhall (Map k v) where
|
|
autoWith opts = Dhall.map (autoWith opts) (autoWith opts)
|
|
|
|
instance (Eq k, Hashable k, FromDhall k, FromDhall v) => FromDhall (HashMap k v) where
|
|
autoWith opts = Dhall.hashMap (autoWith opts) (autoWith opts)
|
|
|
|
instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where
|
|
autoWith opts = Type extractOut expectedOut
|
|
where
|
|
normalizer_ = Just (inputNormalizer opts)
|
|
|
|
-- ToDo
|
|
extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of
|
|
Success o -> o
|
|
Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" )
|
|
|
|
expectedOut = Pi "_" declared expectedIn
|
|
|
|
InputType {..} = injectWith opts
|
|
|
|
Type extractIn expectedIn = autoWith opts
|
|
|
|
instance (FromDhall a, FromDhall b) => FromDhall (a, b)
|
|
|
|
{-| Use the default options for interpreting a configuration file
|
|
|
|
> auto = autoWith defaultInterpretOptions
|
|
-}
|
|
auto :: FromDhall a => Type a
|
|
auto = autoWith defaultInterpretOptions
|
|
|
|
{-| This type is exactly the same as `Data.Fix.Fix` except with a different
|
|
`FromDhall` instance. This intermediate type simplies the implementation
|
|
of the inner loop for the `FromDhall` instance for `Fix`
|
|
-}
|
|
newtype Result f = Result { _unResult :: f (Result f) }
|
|
|
|
resultToFix :: Functor f => Result f -> Fix f
|
|
resultToFix (Result x) = Fix (fmap resultToFix x)
|
|
|
|
instance FromDhall (f (Result f)) => FromDhall (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_
|
|
|
|
-- | You can use this instance to marshal recursive types from Dhall to Haskell.
|
|
--
|
|
-- Here is an example use of this instance:
|
|
--
|
|
-- > {-# LANGUAGE DeriveAnyClass #-}
|
|
-- > {-# LANGUAGE DeriveFoldable #-}
|
|
-- > {-# LANGUAGE DeriveFunctor #-}
|
|
-- > {-# LANGUAGE DeriveTraversable #-}
|
|
-- > {-# LANGUAGE DeriveGeneric #-}
|
|
-- > {-# LANGUAGE KindSignatures #-}
|
|
-- > {-# LANGUAGE QuasiQuotes #-}
|
|
-- > {-# LANGUAGE StandaloneDeriving #-}
|
|
-- > {-# LANGUAGE TypeFamilies #-}
|
|
-- > {-# LANGUAGE TemplateHaskell #-}
|
|
-- >
|
|
-- > import Data.Fix (Fix(..))
|
|
-- > import Data.Text (Text)
|
|
-- > import Dhall (FromDhall)
|
|
-- > import GHC.Generics (Generic)
|
|
-- > import Numeric.Natural (Natural)
|
|
-- >
|
|
-- > import qualified Data.Fix as Fix
|
|
-- > import qualified Data.Functor.Foldable as Foldable
|
|
-- > import qualified Data.Functor.Foldable.TH as TH
|
|
-- > import qualified Dhall
|
|
-- > import qualified NeatInterpolation
|
|
-- >
|
|
-- > data Expr
|
|
-- > = Lit Natural
|
|
-- > | Add Expr Expr
|
|
-- > | Mul Expr Expr
|
|
-- > deriving (Show)
|
|
-- >
|
|
-- > TH.makeBaseFunctor ''Expr
|
|
-- >
|
|
-- > deriving instance Generic (ExprF a)
|
|
-- > deriving instance FromDhall a => FromDhall (ExprF a)
|
|
-- >
|
|
-- > example :: Text
|
|
-- > example = [NeatInterpolation.text|
|
|
-- > \(Expr : Type)
|
|
-- > -> let ExprF =
|
|
-- > < LitF :
|
|
-- > { _1 : Natural }
|
|
-- > | AddF :
|
|
-- > { _1 : Expr, _2 : Expr }
|
|
-- > | MulF :
|
|
-- > { _1 : Expr, _2 : Expr }
|
|
-- > >
|
|
-- >
|
|
-- > in \(Fix : ExprF -> Expr)
|
|
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x })
|
|
-- >
|
|
-- > let Add =
|
|
-- > \(x : Expr)
|
|
-- > -> \(y : Expr)
|
|
-- > -> Fix (ExprF.AddF { _1 = x, _2 = y })
|
|
-- >
|
|
-- > let Mul =
|
|
-- > \(x : Expr)
|
|
-- > -> \(y : Expr)
|
|
-- > -> Fix (ExprF.MulF { _1 = x, _2 = y })
|
|
-- >
|
|
-- > in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))
|
|
-- > |]
|
|
-- >
|
|
-- > convert :: Fix ExprF -> Expr
|
|
-- > convert = Fix.cata Foldable.embed
|
|
-- >
|
|
-- > main :: IO ()
|
|
-- > main = do
|
|
-- > x <- Dhall.input Dhall.auto example :: IO (Fix ExprF)
|
|
-- >
|
|
-- > print (convert x :: Expr)
|
|
instance (Functor f, FromDhall (f (Result f))) => FromDhall (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` is the default implementation for `auto` if you derive
|
|
`FromDhall`. The difference is that you can use `genericAuto` without
|
|
having to explicitly provide a `FromDhall` instance for a type as long as
|
|
the type derives `Generic`
|
|
-}
|
|
genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Type a
|
|
genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1)
|
|
|
|
{-| Use these options to tweak how Dhall derives a generic implementation of
|
|
`FromDhall`
|
|
-}
|
|
data InterpretOptions = InterpretOptions
|
|
{ fieldModifier :: Text -> Text
|
|
-- ^ Function used to transform Haskell field names into their corresponding
|
|
-- Dhall field names
|
|
, constructorModifier :: Text -> Text
|
|
-- ^ Function used to transform Haskell constructor names into their
|
|
-- corresponding Dhall alternative names
|
|
, singletonConstructors :: SingletonConstructors
|
|
-- ^ Specify how to handle constructors with only one field. The default is
|
|
-- `Wrapped` for backwards compatibility but will eventually be changed to
|
|
-- `Smart`
|
|
, inputNormalizer :: Dhall.Core.ReifiedNormalizer Void
|
|
-- ^ This is only used by the `FromDhall` instance for functions in order
|
|
-- to normalize the function input before marshaling the input into a
|
|
-- Dhall expression
|
|
}
|
|
|
|
{-| This type specifies how to model a Haskell constructor with 1 field in
|
|
Dhall
|
|
|
|
For example, consider the following Haskell datatype definition:
|
|
|
|
> data Example = Foo { x :: Double } | Bar Double
|
|
|
|
Depending on which option you pick, the corresponding Dhall type could be:
|
|
|
|
> < Foo : Double | Bar : Double > -- Bare
|
|
|
|
> < Foo : { x : Double } | Bar : { _1 : Double } > -- Wrapped
|
|
|
|
> < Foo : { x : Double } | Bar : Double > -- Smart
|
|
-}
|
|
data SingletonConstructors
|
|
= Bare
|
|
-- ^ Never wrap the field in a record
|
|
| Wrapped
|
|
-- ^ Always wrap the field in a record
|
|
| Smart
|
|
-- ^ Only fields in a record if they are named
|
|
|
|
{-| Default interpret options, which you can tweak or override, like this:
|
|
|
|
> autoWith
|
|
> (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') })
|
|
-}
|
|
defaultInterpretOptions :: InterpretOptions
|
|
defaultInterpretOptions = InterpretOptions
|
|
{ fieldModifier =
|
|
id
|
|
, constructorModifier =
|
|
id
|
|
, singletonConstructors =
|
|
Wrapped
|
|
, inputNormalizer =
|
|
Dhall.Core.ReifiedNormalizer (const (pure Nothing))
|
|
}
|
|
|
|
{-| This is the underlying class that powers the `FromDhall` class's support
|
|
for automatically deriving a generic implementation
|
|
-}
|
|
class GenericFromDhall f where
|
|
genericAutoWith :: InterpretOptions -> State Int (Type (f a))
|
|
|
|
instance GenericFromDhall f => GenericFromDhall (M1 D d f) where
|
|
genericAutoWith options = do
|
|
res <- genericAutoWith options
|
|
pure (fmap M1 res)
|
|
|
|
instance GenericFromDhall V1 where
|
|
genericAutoWith _ = pure Type {..}
|
|
where
|
|
extract expr = typeError expected expr
|
|
|
|
expected = Union mempty
|
|
|
|
unsafeExpectUnion
|
|
:: Text -> Expr Src Void -> Dhall.Map.Map Text (Maybe (Expr Src Void))
|
|
unsafeExpectUnion _ (Union kts) =
|
|
kts
|
|
unsafeExpectUnion name expression =
|
|
Dhall.Core.internalError
|
|
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
|
|
|
|
unsafeExpectRecord
|
|
:: Text -> Expr Src Void -> Dhall.Map.Map Text (Expr Src Void)
|
|
unsafeExpectRecord _ (Record kts) =
|
|
kts
|
|
unsafeExpectRecord name expression =
|
|
Dhall.Core.internalError
|
|
(name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression)
|
|
|
|
unsafeExpectUnionLit
|
|
:: Text
|
|
-> Expr Src Void
|
|
-> (Text, Maybe (Expr Src Void))
|
|
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 Void -> Dhall.Map.Map Text (Expr Src Void)
|
|
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, GenericFromDhall f1, GenericFromDhall f2) => GenericFromDhall (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, GenericFromDhall (f :+: g), GenericFromDhall h) => GenericFromDhall ((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, GenericFromDhall f, GenericFromDhall (g :+: h)) => GenericFromDhall (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 (GenericFromDhall (f :+: g), GenericFromDhall (h :+: i)) => GenericFromDhall ((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 GenericFromDhall f => GenericFromDhall (M1 C c f) where
|
|
genericAutoWith options = do
|
|
res <- genericAutoWith options
|
|
pure (fmap M1 res)
|
|
|
|
instance GenericFromDhall U1 where
|
|
genericAutoWith _ = pure (Type {..})
|
|
where
|
|
extract _ = pure U1
|
|
|
|
expected = Record (Dhall.Map.fromList [])
|
|
|
|
getSelName :: Selector s => M1 i s f a -> State Int Text
|
|
getSelName n = case selName n of
|
|
"" -> do i <- get
|
|
put (i + 1)
|
|
pure (Data.Text.pack ("_" ++ show i))
|
|
nn -> pure (Data.Text.pack nn)
|
|
|
|
instance (GenericFromDhall (f :*: g), GenericFromDhall (h :*: i)) => GenericFromDhall ((f :*: g) :*: (h :*: i)) where
|
|
genericAutoWith options = do
|
|
Type extractL expectedL <- genericAutoWith options
|
|
Type extractR expectedR <- genericAutoWith options
|
|
|
|
let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL
|
|
let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR
|
|
|
|
let expected = Record (Dhall.Map.union ktsL ktsR)
|
|
|
|
let extract expression =
|
|
liftA2 (:*:) (extractL expression) (extractR expression)
|
|
|
|
return (Type {..})
|
|
|
|
instance (GenericFromDhall (f :*: g), Selector s, FromDhall a) => GenericFromDhall ((f :*: g) :*: M1 S s (K1 i a)) where
|
|
genericAutoWith options@InterpretOptions{..} = do
|
|
let nR :: M1 S s (K1 i a) r
|
|
nR = undefined
|
|
|
|
nameR <- fmap fieldModifier (getSelName nR)
|
|
|
|
Type extractL expectedL <- genericAutoWith options
|
|
|
|
let Type extractR expectedR = autoWith options
|
|
|
|
let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL
|
|
|
|
let expected = Record (Dhall.Map.insert nameR expectedR ktsL)
|
|
|
|
let extract expression = do
|
|
let die = typeError expected expression
|
|
|
|
case expression of
|
|
RecordLit kvs ->
|
|
case Dhall.Map.lookup nameR kvs of
|
|
Just expressionR ->
|
|
liftA2 (:*:)
|
|
(extractL expression)
|
|
(fmap (M1 . K1) (extractR expressionR))
|
|
_ -> die
|
|
_ -> die
|
|
|
|
return (Type {..})
|
|
|
|
instance (Selector s, FromDhall a, GenericFromDhall (f :*: g)) => GenericFromDhall (M1 S s (K1 i a) :*: (f :*: g)) where
|
|
genericAutoWith options@InterpretOptions{..} = do
|
|
let nL :: M1 S s (K1 i a) r
|
|
nL = undefined
|
|
|
|
nameL <- fmap fieldModifier (getSelName nL)
|
|
|
|
let Type extractL expectedL = autoWith options
|
|
|
|
Type extractR expectedR <- genericAutoWith options
|
|
|
|
let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR
|
|
|
|
let expected = Record (Dhall.Map.insert nameL expectedL ktsR)
|
|
|
|
let extract expression = do
|
|
let die = typeError expected expression
|
|
|
|
case expression of
|
|
RecordLit kvs ->
|
|
case Dhall.Map.lookup nameL kvs of
|
|
Just expressionL ->
|
|
liftA2 (:*:)
|
|
(fmap (M1 . K1) (extractL expressionL))
|
|
(extractR expression)
|
|
_ -> die
|
|
_ -> die
|
|
|
|
return (Type {..})
|
|
|
|
instance (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where
|
|
genericAutoWith options@InterpretOptions{..} = do
|
|
let nL :: M1 S s1 (K1 i1 a1) r
|
|
nL = undefined
|
|
|
|
let nR :: M1 S s2 (K1 i2 a2) r
|
|
nR = undefined
|
|
|
|
nameL <- fmap fieldModifier (getSelName nL)
|
|
nameR <- fmap fieldModifier (getSelName nR)
|
|
|
|
let Type extractL expectedL = autoWith options
|
|
let Type extractR expectedR = autoWith options
|
|
|
|
let expected =
|
|
Record
|
|
(Dhall.Map.fromList
|
|
[ (nameL, expectedL)
|
|
, (nameR, expectedR)
|
|
]
|
|
)
|
|
|
|
let extract expression = do
|
|
let die = typeError expected expression
|
|
|
|
case expression of
|
|
RecordLit kvs -> do
|
|
case liftA2 (,) (Dhall.Map.lookup nameL kvs) (Dhall.Map.lookup nameR kvs) of
|
|
Just (expressionL, expressionR) ->
|
|
liftA2 (:*:)
|
|
(fmap (M1 . K1) (extractL expressionL))
|
|
(fmap (M1 . K1) (extractR expressionR))
|
|
Nothing -> die
|
|
_ -> die
|
|
|
|
return (Type {..})
|
|
|
|
instance (Selector s, FromDhall a) => GenericFromDhall (M1 S s (K1 i a)) where
|
|
genericAutoWith options@InterpretOptions{..} = do
|
|
let n :: M1 S s (K1 i a) r
|
|
n = undefined
|
|
|
|
name <- fmap fieldModifier (getSelName n)
|
|
|
|
let Type { extract = extract', expected = expected'} = autoWith options
|
|
|
|
let expected =
|
|
case singletonConstructors of
|
|
Bare ->
|
|
expected'
|
|
Smart | selName n == "" ->
|
|
expected'
|
|
_ ->
|
|
Record (Dhall.Map.singleton name expected')
|
|
|
|
let extract0 expression = fmap (M1 . K1) (extract' expression)
|
|
|
|
let extract1 expression = do
|
|
let die = typeError expected expression
|
|
|
|
case expression of
|
|
RecordLit kvs -> do
|
|
case Dhall.Map.lookup name kvs of
|
|
Just subExpression ->
|
|
fmap (M1 . K1) (extract' subExpression)
|
|
Nothing ->
|
|
die
|
|
_ -> do
|
|
die
|
|
|
|
|
|
let extract =
|
|
case singletonConstructors of
|
|
Bare -> extract0
|
|
Smart | selName n == "" -> extract0
|
|
_ -> extract1
|
|
|
|
return (Type {..})
|
|
|
|
{-| An @(InputType a)@ represents a way to marshal a value of type @\'a\'@ from
|
|
Haskell into Dhall
|
|
-}
|
|
data InputType a = InputType
|
|
{ embed :: a -> Expr Src Void
|
|
-- ^ Embeds a Haskell value as a Dhall expression
|
|
, declared :: Expr Src Void
|
|
-- ^ Dhall type of the Haskell value
|
|
}
|
|
|
|
instance Contravariant InputType where
|
|
contramap f (InputType embed declared) = InputType embed' declared
|
|
where
|
|
embed' x = embed (f x)
|
|
|
|
{-| This class is used by `FromDhall` instance for functions:
|
|
|
|
> instance (ToDhall a, FromDhall b) => FromDhall (a -> b)
|
|
|
|
You can convert Dhall functions with "simple" inputs (i.e. instances of this
|
|
class) into Haskell functions. This works by:
|
|
|
|
* Marshaling the input to the Haskell function into a Dhall expression (i.e.
|
|
@x :: Expr Src Void@)
|
|
* Applying the Dhall function (i.e. @f :: Expr Src Void@) to the Dhall input
|
|
(i.e. @App f x@)
|
|
* Normalizing the syntax tree (i.e. @normalize (App f x)@)
|
|
* Marshaling the resulting Dhall expression back into a Haskell value
|
|
-}
|
|
class ToDhall a where
|
|
injectWith :: InterpretOptions -> InputType a
|
|
default injectWith
|
|
:: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputType a
|
|
injectWith options
|
|
= contramap GHC.Generics.from (evalState (genericToDhallWith options) 1)
|
|
|
|
{-| A compatibility alias for `ToDhall`
|
|
|
|
This will eventually be removed.
|
|
-}
|
|
type Inject = ToDhall
|
|
|
|
{-| Use the default options for injecting a value
|
|
|
|
> inject = injectWith defaultInterpretOptions
|
|
-}
|
|
inject :: ToDhall a => InputType a
|
|
inject = injectWith defaultInterpretOptions
|
|
|
|
{-| Use the default options for injecting a value, whose structure is
|
|
determined generically.
|
|
|
|
This can be used when you want to use 'ToDhall' on types that you don't
|
|
want to define orphan instances for.
|
|
-}
|
|
genericToDhall
|
|
:: (Generic a, GenericToDhall (Rep a)) => InputType a
|
|
genericToDhall
|
|
= contramap GHC.Generics.from (evalState (genericToDhallWith defaultInterpretOptions) 1)
|
|
|
|
instance ToDhall Void where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = Data.Void.absurd
|
|
|
|
declared = Union mempty
|
|
|
|
instance ToDhall Bool where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = BoolLit
|
|
|
|
declared = Bool
|
|
|
|
instance ToDhall Data.Text.Lazy.Text where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed text =
|
|
TextLit (Chunks [] (Data.Text.Lazy.toStrict text))
|
|
|
|
declared = Text
|
|
|
|
instance ToDhall Text where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed text = TextLit (Chunks [] text)
|
|
|
|
declared = Text
|
|
|
|
instance {-# OVERLAPS #-} ToDhall String where
|
|
injectWith options =
|
|
contramap Data.Text.pack (injectWith options :: InputType Text)
|
|
|
|
instance ToDhall Natural where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit
|
|
|
|
declared = Natural
|
|
|
|
instance ToDhall Integer where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = IntegerLit
|
|
|
|
declared = Integer
|
|
|
|
instance ToDhall Int where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = IntegerLit . toInteger
|
|
|
|
declared = Integer
|
|
|
|
{-|
|
|
|
|
>>> embed inject (12 :: Word)
|
|
NaturalLit 12
|
|
-}
|
|
|
|
instance ToDhall Word where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit . fromIntegral
|
|
|
|
declared = Natural
|
|
|
|
{-|
|
|
|
|
>>> embed inject (12 :: Word8)
|
|
NaturalLit 12
|
|
-}
|
|
|
|
instance ToDhall Word8 where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit . fromIntegral
|
|
|
|
declared = Natural
|
|
|
|
{-|
|
|
|
|
>>> embed inject (12 :: Word16)
|
|
NaturalLit 12
|
|
-}
|
|
|
|
instance ToDhall Word16 where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit . fromIntegral
|
|
|
|
declared = Natural
|
|
|
|
{-|
|
|
|
|
>>> embed inject (12 :: Word32)
|
|
NaturalLit 12
|
|
-}
|
|
|
|
instance ToDhall Word32 where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit . fromIntegral
|
|
|
|
declared = Natural
|
|
|
|
{-|
|
|
|
|
>>> embed inject (12 :: Word64)
|
|
NaturalLit 12
|
|
-}
|
|
|
|
instance ToDhall Word64 where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = NaturalLit . fromIntegral
|
|
|
|
declared = Natural
|
|
|
|
instance ToDhall Double where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = DoubleLit . DhallDouble
|
|
|
|
declared = Double
|
|
|
|
instance ToDhall Scientific where
|
|
injectWith options =
|
|
contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double)
|
|
|
|
instance ToDhall () where
|
|
injectWith _ = InputType {..}
|
|
where
|
|
embed = const (RecordLit mempty)
|
|
|
|
declared = Record mempty
|
|
|
|
instance ToDhall a => ToDhall (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 ToDhall a => ToDhall (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 ToDhall a => ToDhall [a] where
|
|
injectWith = fmap (contramap Data.Sequence.fromList) injectWith
|
|
|
|
instance ToDhall a => ToDhall (Vector a) where
|
|
injectWith = fmap (contramap Data.Vector.toList) injectWith
|
|
|
|
{-| Note that the ouput list will be sorted
|
|
|
|
>>> let x = Data.Set.fromList ["mom", "hi" :: Text]
|
|
>>> prettyExpr $ embed inject x
|
|
[ "hi", "mom" ]
|
|
|
|
-}
|
|
instance ToDhall a => ToDhall (Data.Set.Set a) where
|
|
injectWith = fmap (contramap Data.Set.toAscList) injectWith
|
|
|
|
{-| Note that the ouput list may not be sorted
|
|
|
|
>>> let x = Data.HashSet.fromList ["hi", "mom" :: Text]
|
|
>>> prettyExpr $ embed inject x
|
|
[ "mom", "hi" ]
|
|
|
|
-}
|
|
instance ToDhall a => ToDhall (Data.HashSet.HashSet a) where
|
|
injectWith = fmap (contramap Data.HashSet.toList) injectWith
|
|
|
|
instance (ToDhall a, ToDhall b) => ToDhall (a, b)
|
|
|
|
{-| Embed a `Data.Map` as a @Prelude.Map.Type@
|
|
|
|
>>> prettyExpr $ embed inject (Data.Map.fromList [(1 :: Natural, True)])
|
|
[ { mapKey = 1, mapValue = True } ]
|
|
|
|
>>> prettyExpr $ embed inject (Data.Map.fromList [] :: Data.Map.Map Natural Bool)
|
|
[] : List { mapKey : Natural, mapValue : Bool }
|
|
|
|
-}
|
|
instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where
|
|
injectWith options = InputType embedOut declaredOut
|
|
where
|
|
embedOut m = ListLit listType (mapEntries m)
|
|
where
|
|
listType
|
|
| Data.Map.null m = Just declaredOut
|
|
| otherwise = Nothing
|
|
|
|
declaredOut = App List (Record (Dhall.Map.fromList
|
|
[("mapKey", declaredK), ("mapValue", declaredV)]))
|
|
|
|
mapEntries = Data.Sequence.fromList . fmap recordPair . Data.Map.toList
|
|
recordPair (k, v) = RecordLit (Dhall.Map.fromList
|
|
[("mapKey", embedK k), ("mapValue", embedV v)])
|
|
|
|
InputType embedK declaredK = injectWith options
|
|
InputType embedV declaredV = injectWith options
|
|
|
|
{-| Embed a `Data.HashMap` as a @Prelude.Map.Type@
|
|
|
|
>>> prettyExpr $ embed inject (HashMap.fromList [(1 :: Natural, True)])
|
|
[ { mapKey = 1, mapValue = True } ]
|
|
|
|
>>> prettyExpr $ embed inject (HashMap.fromList [] :: HashMap Natural Bool)
|
|
[] : List { mapKey : Natural, mapValue : Bool }
|
|
|
|
-}
|
|
instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where
|
|
injectWith options = InputType embedOut declaredOut
|
|
where
|
|
embedOut m = ListLit listType (mapEntries m)
|
|
where
|
|
listType
|
|
| HashMap.null m = Just declaredOut
|
|
| otherwise = Nothing
|
|
|
|
declaredOut = App List (Record (Dhall.Map.fromList
|
|
[("mapKey", declaredK), ("mapValue", declaredV)]))
|
|
|
|
mapEntries = Data.Sequence.fromList . fmap recordPair . HashMap.toList
|
|
recordPair (k, v) = RecordLit (Dhall.Map.fromList
|
|
[("mapKey", embedK k), ("mapValue", embedV v)])
|
|
|
|
InputType embedK declaredK = injectWith options
|
|
InputType embedV declaredV = injectWith options
|
|
|
|
{-| This is the underlying class that powers the `FromDhall` class's support
|
|
for automatically deriving a generic implementation
|
|
-}
|
|
class GenericToDhall f where
|
|
genericToDhallWith :: InterpretOptions -> State Int (InputType (f a))
|
|
|
|
instance GenericToDhall f => GenericToDhall (M1 D d f) where
|
|
genericToDhallWith options = do
|
|
res <- genericToDhallWith options
|
|
pure (contramap unM1 res)
|
|
|
|
instance GenericToDhall f => GenericToDhall (M1 C c f) where
|
|
genericToDhallWith options = do
|
|
res <- genericToDhallWith options
|
|
pure (contramap unM1 res)
|
|
|
|
instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where
|
|
genericToDhallWith options@InterpretOptions{..} = do
|
|
let InputType { embed = embed', declared = declared' } =
|
|
injectWith options
|
|
|
|
let n :: M1 S s (K1 i a) r
|
|
n = undefined
|
|
|
|
name <- fieldModifier <$> getSelName n
|
|
|
|
let embed0 (M1 (K1 x)) = embed' x
|
|
|
|
let embed1 (M1 (K1 x)) =
|
|
RecordLit (Dhall.Map.singleton name (embed' x))
|
|
|
|
let embed =
|
|
case singletonConstructors of
|
|
Bare -> embed0
|
|
Smart | selName n == "" -> embed0
|
|
_ -> embed1
|
|
|
|
let declared =
|
|
case singletonConstructors of
|
|
Bare ->
|
|
declared'
|
|
Smart | selName n == "" ->
|
|
declared'
|
|
_ ->
|
|
Record (Dhall.Map.singleton name declared')
|
|
|
|
return (InputType {..})
|
|
|
|
instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where
|
|
genericToDhallWith 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 (genericToDhallWith options) 1
|
|
InputType embedR declaredR = evalState (genericToDhallWith options) 1
|
|
|
|
instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where
|
|
genericToDhallWith 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 "genericToDhallWith (:+:)" (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 (genericToDhallWith options) 1
|
|
InputType embedR declaredR = evalState (genericToDhallWith options) 1
|
|
|
|
ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL
|
|
|
|
instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where
|
|
genericToDhallWith 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 "genericToDhallWith (:+:)" (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 (genericToDhallWith options) 1
|
|
InputType embedR declaredR = evalState (genericToDhallWith options) 1
|
|
|
|
ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR
|
|
|
|
instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where
|
|
genericToDhallWith 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 "genericToDhallWith (:+:)" (embedL l)
|
|
embed (R1 r) =
|
|
case maybeValR of
|
|
Nothing -> Field declared keyR
|
|
Just valR -> App (Field declared keyR) valR
|
|
where
|
|
(keyR, maybeValR) =
|
|
unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedR r)
|
|
|
|
declared = Union (Dhall.Map.union ktsL ktsR)
|
|
|
|
InputType embedL declaredL = evalState (genericToDhallWith options) 1
|
|
InputType embedR declaredR = evalState (genericToDhallWith options) 1
|
|
|
|
ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL
|
|
ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR
|
|
|
|
instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where
|
|
genericToDhallWith options = do
|
|
InputType embedL declaredL <- genericToDhallWith options
|
|
InputType embedR declaredR <- genericToDhallWith options
|
|
|
|
let embed (l :*: r) =
|
|
RecordLit (Dhall.Map.union mapL mapR)
|
|
where
|
|
mapL =
|
|
unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l)
|
|
|
|
mapR =
|
|
unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r)
|
|
|
|
let declared = Record (Dhall.Map.union mapL mapR)
|
|
where
|
|
mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL
|
|
mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR
|
|
|
|
pure (InputType {..})
|
|
|
|
instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where
|
|
genericToDhallWith options@InterpretOptions{..} = do
|
|
let nR :: M1 S s (K1 i a) r
|
|
nR = undefined
|
|
|
|
nameR <- fmap fieldModifier (getSelName nR)
|
|
|
|
InputType embedL declaredL <- genericToDhallWith options
|
|
|
|
let InputType embedR declaredR = injectWith options
|
|
|
|
let embed (l :*: M1 (K1 r)) =
|
|
RecordLit (Dhall.Map.insert nameR (embedR r) mapL)
|
|
where
|
|
mapL =
|
|
unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l)
|
|
|
|
let declared = Record (Dhall.Map.insert nameR declaredR mapL)
|
|
where
|
|
mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL
|
|
|
|
return (InputType {..})
|
|
|
|
instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where
|
|
genericToDhallWith options@InterpretOptions{..} = do
|
|
let nL :: M1 S s (K1 i a) r
|
|
nL = undefined
|
|
|
|
nameL <- fmap fieldModifier (getSelName nL)
|
|
|
|
let InputType embedL declaredL = injectWith options
|
|
|
|
InputType embedR declaredR <- genericToDhallWith options
|
|
|
|
let embed (M1 (K1 l) :*: r) =
|
|
RecordLit (Dhall.Map.insert nameL (embedL l) mapR)
|
|
where
|
|
mapR =
|
|
unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r)
|
|
|
|
let declared = Record (Dhall.Map.insert nameL declaredL mapR)
|
|
where
|
|
mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR
|
|
|
|
return (InputType {..})
|
|
|
|
instance (Selector s1, Selector s2, ToDhall a1, ToDhall a2) => GenericToDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where
|
|
genericToDhallWith options@InterpretOptions{..} = do
|
|
let nL :: M1 S s1 (K1 i1 a1) r
|
|
nL = undefined
|
|
|
|
let nR :: M1 S s2 (K1 i2 a2) r
|
|
nR = undefined
|
|
|
|
nameL <- fmap fieldModifier (getSelName nL)
|
|
nameR <- fmap fieldModifier (getSelName nR)
|
|
|
|
let InputType embedL declaredL = injectWith options
|
|
let InputType embedR declaredR = injectWith options
|
|
|
|
let embed (M1 (K1 l) :*: M1 (K1 r)) =
|
|
RecordLit
|
|
(Dhall.Map.fromList
|
|
[ (nameL, embedL l), (nameR, embedR r) ]
|
|
)
|
|
|
|
let declared =
|
|
Record
|
|
(Dhall.Map.fromList
|
|
[ (nameL, declaredL), (nameR, declaredR) ]
|
|
)
|
|
|
|
return (InputType {..})
|
|
|
|
instance GenericToDhall U1 where
|
|
genericToDhallWith _ = pure (InputType {..})
|
|
where
|
|
embed _ = RecordLit mempty
|
|
|
|
declared = Record mempty
|
|
|
|
{-| The 'RecordType' applicative functor allows you to build a 'Type' parser
|
|
from a Dhall record.
|
|
|
|
For example, let's take the following Haskell data type:
|
|
|
|
>>> :{
|
|
data Project = Project
|
|
{ projectName :: Text
|
|
, projectDescription :: Text
|
|
, projectStars :: Natural
|
|
}
|
|
:}
|
|
|
|
And assume that we have the following Dhall record that we would like to
|
|
parse as a @Project@:
|
|
|
|
> { name =
|
|
> "dhall-haskell"
|
|
> , description =
|
|
> "A configuration language guaranteed to terminate"
|
|
> , stars =
|
|
> 289
|
|
> }
|
|
|
|
Our parser has type 'Type' @Project@, but we can't build that out of any
|
|
smaller parsers, as 'Type's cannot be combined (they are only 'Functor's).
|
|
However, we can use a 'RecordType' to build a 'Type' for @Project@:
|
|
|
|
>>> :{
|
|
project :: Type Project
|
|
project =
|
|
record
|
|
( Project <$> field "name" strictText
|
|
<*> field "description" strictText
|
|
<*> field "stars" natural
|
|
)
|
|
:}
|
|
-}
|
|
|
|
newtype RecordType a =
|
|
RecordType
|
|
( Data.Functor.Product.Product
|
|
( Control.Applicative.Const
|
|
( Dhall.Map.Map
|
|
Text
|
|
( Expr Src Void )
|
|
)
|
|
)
|
|
( Data.Functor.Compose.Compose
|
|
( (->) ( Expr Src Void ) )
|
|
(Extractor Src Void)
|
|
)
|
|
a
|
|
)
|
|
deriving (Functor, Applicative)
|
|
|
|
|
|
-- | Run a 'RecordType' parser to build a 'Type' parser.
|
|
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
|
|
}
|
|
|
|
|
|
-- | Parse a single field of a record.
|
|
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 )
|
|
)
|
|
|
|
{-| The 'UnionType' monoid allows you to build a 'Type' parser
|
|
from a Dhall union
|
|
|
|
For example, let's take the following Haskell data type:
|
|
|
|
>>> :{
|
|
data Status = Queued Natural
|
|
| Result Text
|
|
| Errored Text
|
|
:}
|
|
|
|
And assume that we have the following Dhall union that we would like to
|
|
parse as a @Status@:
|
|
|
|
> < Result : Text
|
|
> | Queued : Natural
|
|
> | Errored : Text
|
|
> >.Result "Finish successfully"
|
|
|
|
Our parser has type 'Type' @Status@, but we can't build that out of any
|
|
smaller parsers, as 'Type's cannot be combined (they are only 'Functor's).
|
|
However, we can use a 'UnionType' to build a 'Type' for @Status@:
|
|
|
|
>>> :{
|
|
status :: Type Status
|
|
status = union
|
|
( ( Queued <$> constructor "Queued" natural )
|
|
<> ( Result <$> constructor "Result" strictText )
|
|
<> ( Errored <$> constructor "Errored" strictText )
|
|
)
|
|
:}
|
|
|
|
-}
|
|
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.<>)
|
|
|
|
-- | Run a 'UnionType' parser to build a 'Type' parser.
|
|
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
|
|
|
|
-- | Parse a single constructor of a union
|
|
constructor :: Text -> Type a -> UnionType a
|
|
constructor key valueType = UnionType
|
|
( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueType) )
|
|
|
|
{-| The 'RecordInputType' divisible (contravariant) functor allows you to build
|
|
an 'InputType' injector for a Dhall record.
|
|
|
|
For example, let's take the following Haskell data type:
|
|
|
|
>>> :{
|
|
data Project = Project
|
|
{ projectName :: Text
|
|
, projectDescription :: Text
|
|
, projectStars :: Natural
|
|
}
|
|
:}
|
|
|
|
And assume that we have the following Dhall record that we would like to
|
|
parse as a @Project@:
|
|
|
|
> { name =
|
|
> "dhall-haskell"
|
|
> , description =
|
|
> "A configuration language guaranteed to terminate"
|
|
> , stars =
|
|
> 289
|
|
> }
|
|
|
|
Our injector has type 'InputType' @Project@, but we can't build that out of any
|
|
smaller injectors, as 'InputType's cannot be combined (they are only 'Contravariant's).
|
|
However, we can use an 'InputRecordType' to build an 'InputType' for @Project@:
|
|
|
|
>>> :{
|
|
injectProject :: InputType Project
|
|
injectProject =
|
|
inputRecord
|
|
( adapt >$< inputFieldWith "name" inject
|
|
>*< inputFieldWith "description" inject
|
|
>*< inputFieldWith "stars" inject
|
|
)
|
|
where
|
|
adapt (Project{..}) = (projectName, (projectDescription, projectStars))
|
|
:}
|
|
|
|
Or, since we are simply using the `ToDhall` instance to inject each field, we could write
|
|
|
|
>>> :{
|
|
injectProject :: InputType Project
|
|
injectProject =
|
|
inputRecord
|
|
( adapt >$< inputField "name"
|
|
>*< inputField "description"
|
|
>*< inputField "stars"
|
|
)
|
|
where
|
|
adapt (Project{..}) = (projectName, (projectDescription, projectStars))
|
|
:}
|
|
|
|
-}
|
|
|
|
-- | Infix 'divided'
|
|
(>*<) :: Divisible f => f a -> f b -> f (a, b)
|
|
(>*<) = divided
|
|
|
|
infixr 5 >*<
|
|
|
|
-- | Intermediate type used for building a `ToDhall` instance for a record
|
|
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
|
|
|
|
{-| Specify how to encode one field of a record by supplying an explicit
|
|
`InputType` for that field
|
|
-}
|
|
inputFieldWith :: Text -> InputType a -> RecordInputType a
|
|
inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType
|
|
|
|
{-| Specify how to encode one field of a record using the default `ToDhall`
|
|
instance for that type
|
|
-}
|
|
inputField :: ToDhall a => Text -> RecordInputType a
|
|
inputField name = inputFieldWith name inject
|
|
|
|
-- | Convert a `RecordInputType` into the equivalent `InputType`
|
|
inputRecord :: RecordInputType a -> InputType a
|
|
inputRecord (RecordInputType inputTypeRecord) = InputType makeRecordLit recordType
|
|
where
|
|
recordType = Record $ declared <$> inputTypeRecord
|
|
makeRecordLit x = RecordLit $ (($ x) . embed) <$> inputTypeRecord
|
|
|
|
{-| 'UnionInputType' allows you to build an 'InputType' injector for a Dhall
|
|
record.
|
|
|
|
For example, let's take the following Haskell data type:
|
|
|
|
>>> :{
|
|
data Status = Queued Natural
|
|
| Result Text
|
|
| Errored Text
|
|
:}
|
|
|
|
And assume that we have the following Dhall union that we would like to
|
|
parse as a @Status@:
|
|
|
|
> < Result : Text
|
|
> | Queued : Natural
|
|
> | Errored : Text
|
|
> >.Result "Finish successfully"
|
|
|
|
Our injector has type 'InputType' @Status@, but we can't build that out of any
|
|
smaller injectors, as 'InputType's cannot be combined.
|
|
However, we can use an 'UnionInputType' to build an 'InputType' for @Status@:
|
|
|
|
>>> :{
|
|
injectStatus :: InputType Status
|
|
injectStatus = adapt >$< inputUnion
|
|
( inputConstructorWith "Queued" inject
|
|
>|< inputConstructorWith "Result" inject
|
|
>|< inputConstructorWith "Errored" inject
|
|
)
|
|
where
|
|
adapt (Queued n) = Left n
|
|
adapt (Result t) = Right (Left t)
|
|
adapt (Errored e) = Right (Right e)
|
|
:}
|
|
|
|
Or, since we are simply using the `ToDhall` instance to inject each branch, we could write
|
|
|
|
>>> :{
|
|
injectStatus :: InputType Status
|
|
injectStatus = adapt >$< inputUnion
|
|
( inputConstructor "Queued"
|
|
>|< inputConstructor "Result"
|
|
>|< inputConstructor "Errored"
|
|
)
|
|
where
|
|
adapt (Queued n) = Left n
|
|
adapt (Result t) = Right (Left t)
|
|
adapt (Errored e) = Right (Right e)
|
|
:}
|
|
|
|
-}
|
|
newtype UnionInputType a =
|
|
UnionInputType
|
|
( Data.Functor.Product.Product
|
|
( Control.Applicative.Const
|
|
( Dhall.Map.Map
|
|
Text
|
|
( Expr Src Void )
|
|
)
|
|
)
|
|
( Op (Text, Expr Src Void) )
|
|
a
|
|
)
|
|
deriving (Contravariant)
|
|
|
|
-- | Combines two 'UnionInputType' values. See 'UnionInputType' for usage
|
|
-- notes.
|
|
--
|
|
-- Ideally, this matches 'Data.Functor.Contravariant.Divisible.chosen';
|
|
-- however, this allows 'UnionInputType' to not need a 'Divisible' instance
|
|
-- itself (since no instance is possible).
|
|
(>|<) :: 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 >|<
|
|
|
|
-- | Convert a `UnionInputType` into the equivalent `InputType`
|
|
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
|
|
|
|
{-| Specify how to encode an alternative by providing an explicit `InputType`
|
|
for that alternative
|
|
-}
|
|
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 )
|
|
)
|
|
|
|
{-| Specify how to encode an alternative by using the default `ToDhall` instance
|
|
for that type
|
|
-}
|
|
inputConstructor
|
|
:: ToDhall a
|
|
=> Text
|
|
-> UnionInputType a
|
|
inputConstructor name = inputConstructorWith name inject
|