2016-09-09 18:17:25 +02:00
|
|
|
{-# LANGUAGE DefaultSignatures #-}
|
2017-08-21 18:08:51 +02:00
|
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
2016-09-09 18:17:25 +02:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2017-08-21 18:08:51 +02:00
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
2016-09-09 18:17:25 +02:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2018-01-22 01:31:29 +01:00
|
|
|
{-# LANGUAGE RankNTypes #-}
|
2016-09-09 18:17:25 +02:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2017-08-26 17:02:52 +02:00
|
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
2016-09-09 18:17:25 +02:00
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
|
2016-11-25 04:15:29 +01:00
|
|
|
{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
|
|
|
|
how to use the language, the compiler, and this library
|
|
|
|
-}
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
module Dhall
|
|
|
|
(
|
|
|
|
-- * Input
|
|
|
|
input
|
2018-01-22 01:31:29 +01:00
|
|
|
, inputWith
|
2016-11-21 01:25:55 +01:00
|
|
|
, detailed
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
-- * Types
|
2017-07-11 23:04:44 +02:00
|
|
|
, Type(..)
|
2017-07-27 20:44:37 +02:00
|
|
|
, InputType(..)
|
2016-09-13 06:27:47 +02:00
|
|
|
, Interpret(..)
|
2017-02-05 19:32:32 +01:00
|
|
|
, InvalidType(..)
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
, auto
|
2017-12-28 19:17:45 +01:00
|
|
|
, genericAuto
|
2017-02-23 18:35:52 +01:00
|
|
|
, InterpretOptions(..)
|
|
|
|
, defaultInterpretOptions
|
2016-09-09 18:51:31 +02:00
|
|
|
, bool
|
2016-09-09 18:17:25 +02:00
|
|
|
, natural
|
|
|
|
, integer
|
|
|
|
, double
|
2017-07-02 07:24:39 +02:00
|
|
|
, lazyText
|
|
|
|
, strictText
|
2016-09-19 00:38:36 +02:00
|
|
|
, maybe
|
2016-09-09 18:17:25 +02:00
|
|
|
, vector
|
2018-01-23 01:38:42 +01:00
|
|
|
, list
|
|
|
|
, unit
|
|
|
|
, string
|
|
|
|
, pair
|
2017-02-23 18:35:52 +01:00
|
|
|
, GenericInterpret(..)
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
, Inject(..)
|
|
|
|
, inject
|
|
|
|
|
2017-07-05 18:05:47 +02:00
|
|
|
-- * Miscellaneous
|
|
|
|
, rawInput
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
-- * Re-exports
|
2016-11-25 07:13:36 +01:00
|
|
|
, Natural
|
2016-09-19 00:24:54 +02:00
|
|
|
, Text
|
2016-09-09 18:17:25 +02:00
|
|
|
, Vector
|
|
|
|
, Generic
|
|
|
|
) where
|
|
|
|
|
2017-07-05 18:05:47 +02:00
|
|
|
import Control.Applicative (empty, liftA2, (<|>), Alternative)
|
2016-09-09 18:17:25 +02:00
|
|
|
import Control.Exception (Exception)
|
2017-08-22 22:30:28 +02:00
|
|
|
import Control.Monad.Trans.State.Strict
|
2017-07-22 13:53:24 +02:00
|
|
|
import Data.Functor.Contravariant (Contravariant(..))
|
2016-11-05 16:36:16 +01:00
|
|
|
import Data.Monoid ((<>))
|
2016-12-05 00:19:01 +01:00
|
|
|
import Data.Text.Buildable (Buildable(..))
|
2016-09-09 18:17:25 +02:00
|
|
|
import Data.Text.Lazy (Text)
|
2017-02-05 19:31:03 +01:00
|
|
|
import Data.Typeable (Typeable)
|
2016-09-09 18:17:25 +02:00
|
|
|
import Data.Vector (Vector)
|
2017-08-28 01:06:57 +02:00
|
|
|
import Data.Word (Word8, Word16, Word32, Word64)
|
2018-01-22 01:32:28 +01:00
|
|
|
import Dhall.Core (Expr(..), Chunks(..))
|
2016-11-21 01:25:55 +01:00
|
|
|
import Dhall.Import (Imported(..))
|
2016-11-05 16:36:16 +01:00
|
|
|
import Dhall.Parser (Src(..))
|
2016-11-21 01:25:55 +01:00
|
|
|
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
|
2016-09-09 18:17:25 +02:00
|
|
|
import GHC.Generics
|
|
|
|
import Numeric.Natural (Natural)
|
2016-09-19 00:38:36 +02:00
|
|
|
import Prelude hiding (maybe)
|
2016-11-03 17:40:29 +01:00
|
|
|
import Text.Trifecta.Delta (Delta(..))
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
import qualified Control.Exception
|
2016-11-05 16:36:16 +01:00
|
|
|
import qualified Data.ByteString.Lazy
|
2017-08-28 17:58:46 +02:00
|
|
|
import qualified Data.Foldable
|
2016-09-09 18:17:25 +02:00
|
|
|
import qualified Data.Map
|
2017-08-28 17:58:46 +02:00
|
|
|
import qualified Data.Sequence
|
|
|
|
import qualified Data.Set
|
2017-02-05 19:31:03 +01:00
|
|
|
import qualified Data.Text
|
2016-09-09 18:17:25 +02:00
|
|
|
import qualified Data.Text.Lazy
|
2016-10-11 18:18:52 +02:00
|
|
|
import qualified Data.Text.Lazy.Builder
|
2016-11-05 16:36:16 +01:00
|
|
|
import qualified Data.Text.Lazy.Encoding
|
2016-09-19 00:38:36 +02:00
|
|
|
import qualified Data.Vector
|
2018-01-22 01:31:29 +01:00
|
|
|
import qualified Dhall.Context
|
2016-09-09 18:17:25 +02:00
|
|
|
import qualified Dhall.Core
|
|
|
|
import qualified Dhall.Import
|
2016-10-31 03:31:47 +01:00
|
|
|
import qualified Dhall.Parser
|
2016-10-18 03:34:51 +02:00
|
|
|
import qualified Dhall.TypeCheck
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
throws :: Exception e => Either e a -> IO a
|
|
|
|
throws (Left e) = Control.Exception.throwIO e
|
|
|
|
throws (Right r) = return r
|
|
|
|
|
2017-02-05 19:31:03 +01:00
|
|
|
{-| Every `Type` must obey the contract that if an expression's type matches the
|
|
|
|
the `expected` type then the `extract` function must succeed. If not, then
|
|
|
|
this exception is thrown
|
|
|
|
|
|
|
|
This exception indicates that an invalid `Type` was provided to the `input`
|
|
|
|
function
|
|
|
|
-}
|
|
|
|
data InvalidType = InvalidType deriving (Typeable)
|
|
|
|
|
2017-07-26 04:51:40 +02:00
|
|
|
_ERROR :: String
|
2017-02-05 19:31:03 +01:00
|
|
|
_ERROR = "\ESC[1;31mError\ESC[0m"
|
|
|
|
|
|
|
|
instance Show InvalidType where
|
2017-07-26 04:51:40 +02:00
|
|
|
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"
|
2017-02-05 19:31:03 +01:00
|
|
|
|
|
|
|
instance Exception InvalidType
|
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
{-| Type-check and evaluate a Dhall program, decoding the result into Haskell
|
|
|
|
|
|
|
|
The first argument determines the type of value that you decode:
|
|
|
|
|
2016-09-10 04:02:13 +02:00
|
|
|
>>> input integer "2"
|
|
|
|
2
|
2017-02-05 16:23:25 +01:00
|
|
|
>>> input (vector double) "[1.0, 2.0]"
|
2016-09-10 04:02:13 +02:00
|
|
|
[1.0,2.0]
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
Use `auto` to automatically select which type to decode based on the
|
|
|
|
inferred return type:
|
|
|
|
|
2016-09-10 04:02:13 +02:00
|
|
|
>>> input auto "True" :: IO Bool
|
|
|
|
True
|
2016-09-09 18:17:25 +02:00
|
|
|
-}
|
|
|
|
input
|
|
|
|
:: Type a
|
|
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
2016-10-31 02:33:14 +01:00
|
|
|
-> Text
|
2016-09-09 18:17:25 +02:00
|
|
|
-- ^ The Dhall program
|
|
|
|
-> IO a
|
|
|
|
-- ^ The decoded value in Haskell
|
2018-01-22 01:31:29 +01:00
|
|
|
input ty txt =
|
|
|
|
inputWith ty Dhall.Context.empty (const Nothing) txt
|
|
|
|
|
|
|
|
{-| Extend 'input' with a custom typing context and normalization process.
|
|
|
|
|
|
|
|
-}
|
|
|
|
inputWith
|
|
|
|
:: Type a
|
|
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
|
|
-> Dhall.Context.Context (Expr Src X)
|
|
|
|
-- ^ The starting context for type-checking
|
|
|
|
-> Dhall.Core.Normalizer X
|
|
|
|
-> Text
|
|
|
|
-- ^ The Dhall program
|
|
|
|
-> IO a
|
|
|
|
-- ^ The decoded value in Haskell
|
|
|
|
inputWith (Type {..}) ctx n txt = do
|
2016-11-03 17:40:29 +01:00
|
|
|
let delta = Directed "(input)" 0 0 0 0
|
2017-02-05 19:31:03 +01:00
|
|
|
expr <- throws (Dhall.Parser.exprFromText delta txt)
|
2018-01-22 01:31:29 +01:00
|
|
|
expr' <- Dhall.Import.loadWithContext ctx expr
|
2016-11-05 16:36:16 +01:00
|
|
|
let suffix =
|
|
|
|
( Data.ByteString.Lazy.toStrict
|
|
|
|
. Data.Text.Lazy.Encoding.encodeUtf8
|
|
|
|
. Data.Text.Lazy.Builder.toLazyText
|
2016-12-05 00:19:01 +01:00
|
|
|
. build
|
2016-11-05 16:36:16 +01:00
|
|
|
) 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
|
2018-01-22 01:31:29 +01:00
|
|
|
_ <- throws (Dhall.TypeCheck.typeWith ctx annot)
|
|
|
|
case extract (Dhall.Core.normalizeWith n expr') of
|
2016-09-09 18:17:25 +02:00
|
|
|
Just x -> return x
|
2017-02-05 19:31:03 +01:00
|
|
|
Nothing -> Control.Exception.throwIO InvalidType
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2017-07-05 18:05:47 +02:00
|
|
|
-- | 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
|
2017-12-05 20:01:44 +01:00
|
|
|
:: Alternative f
|
2017-07-05 18:05:47 +02:00
|
|
|
=> Type a
|
|
|
|
-- ^ The type of value to decode from Dhall to Haskell
|
|
|
|
-> Expr s X
|
|
|
|
-- ^ 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
|
|
|
|
Just x -> pure x
|
|
|
|
Nothing -> empty
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-11-21 01:25:55 +01:00
|
|
|
{-| Use this to provide more detailed error messages
|
|
|
|
|
|
|
|
>> input auto "True" :: IO Integer
|
|
|
|
> *** Exception: Error: Expression doesn't match annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> True : Integer
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> (input):1:1
|
|
|
|
|
|
|
|
>> detailed (input auto "True") :: IO Integer
|
|
|
|
> *** Exception: Error: Expression doesn't match annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> Explanation: You can annotate an expression with its type or kind using the
|
|
|
|
> ❰:❱ symbol, like this:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌───────┐
|
|
|
|
> │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱
|
|
|
|
> └───────┘
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> The type checker verifies that the expression's type or kind matches the
|
|
|
|
> provided annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> For example, all of the following are valid annotations that the type checker
|
|
|
|
> accepts:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌─────────────┐
|
|
|
|
> │ 1 : Integer │ ❰1❱ is an expression that has type ❰Integer❱, so the type
|
|
|
|
> └─────────────┘ checker accepts the annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌────────────────────────┐
|
|
|
|
> │ Natural/even +2 : Bool │ ❰Natural/even +2❱ has type ❰Bool❱, so the type
|
|
|
|
> └────────────────────────┘ checker accepts the annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌────────────────────┐
|
|
|
|
> │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱,
|
|
|
|
> └────────────────────┘ so the type checker accepts the annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌──────────────────┐
|
|
|
|
> │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so
|
|
|
|
> └──────────────────┘ the type checker accepts the annotation
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> However, the following annotations are not valid and the type checker will
|
|
|
|
> reject them:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌──────────┐
|
|
|
|
> │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type
|
|
|
|
> └──────────┘ ❰Text❱
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌─────────────┐
|
|
|
|
> │ List : Type │ ❰List❱ does not have kind ❰Type❱
|
|
|
|
> └─────────────┘
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> You or the interpreter annotated this expression:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ↳ True
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ... with this type or kind:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ↳ Integer
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ... but the inferred type or kind of the expression is actually:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ↳ Bool
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> Some common reasons why you might get this error:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ● The Haskell Dhall interpreter implicitly inserts a top-level annotation
|
|
|
|
> matching the expected type
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> For example, if you run the following Haskell code:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌───────────────────────────────┐
|
|
|
|
> │ >>> input auto "1" :: IO Text │
|
|
|
|
> └───────────────────────────────┘
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ... then the interpreter will actually type check the following annotated
|
|
|
|
> expression:
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ┌──────────┐
|
|
|
|
> │ 1 : Text │
|
|
|
|
> └──────────┘
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ... and then type-checking will fail
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> ────────────────────────────────────────────────────────────────────────────────
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> True : Integer
|
2017-12-05 20:01:44 +01:00
|
|
|
>
|
2016-11-21 01:25:55 +01:00
|
|
|
> (input):1:1
|
|
|
|
|
|
|
|
-}
|
|
|
|
detailed :: IO a -> IO a
|
|
|
|
detailed =
|
|
|
|
Control.Exception.handle handler1 . Control.Exception.handle handler0
|
|
|
|
where
|
2017-12-05 20:01:44 +01:00
|
|
|
handler0 :: Imported (TypeError Src X) -> IO a
|
2016-11-21 01:25:55 +01:00
|
|
|
handler0 (Imported ps e) =
|
|
|
|
Control.Exception.throwIO (Imported ps (DetailedTypeError e))
|
|
|
|
|
2017-12-05 20:01:44 +01:00
|
|
|
handler1 :: TypeError Src X -> IO a
|
2016-11-21 01:25:55 +01:00
|
|
|
handler1 e = Control.Exception.throwIO (DetailedTypeError e)
|
|
|
|
|
2016-09-10 04:02:13 +02:00
|
|
|
{-| A @(Type a)@ represents a way to marshal a value of type @\'a\'@ from Dhall
|
2016-09-09 18:17:25 +02:00
|
|
|
into Haskell
|
|
|
|
|
|
|
|
You can produce `Type`s either explicitly:
|
|
|
|
|
2016-09-15 18:03:12 +02:00
|
|
|
> example :: Type (Vector Text)
|
|
|
|
> example = vector text
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
... or implicitly using `auto`:
|
|
|
|
|
2016-09-15 18:03:12 +02:00
|
|
|
> example :: Type (Vector Text)
|
2016-09-09 18:17:25 +02:00
|
|
|
> example = auto
|
|
|
|
|
|
|
|
You can consume `Type`s using the `input` function:
|
|
|
|
|
|
|
|
> input :: Type a -> Text -> IO a
|
|
|
|
-}
|
|
|
|
data Type a = Type
|
2017-07-22 13:53:24 +02:00
|
|
|
{ extract :: Expr Src X -> Maybe a
|
2017-07-11 23:04:44 +02:00
|
|
|
-- ^ Extracts Haskell value from the Dhall expression
|
2016-10-30 05:48:18 +01:00
|
|
|
, expected :: Expr Src X
|
2017-07-11 23:04:44 +02:00
|
|
|
-- ^ Dhall type of the Haskell value
|
2016-09-09 18:17:25 +02:00
|
|
|
}
|
|
|
|
deriving (Functor)
|
|
|
|
|
|
|
|
{-| Decode a `Bool`
|
|
|
|
|
|
|
|
>>> input bool "True"
|
|
|
|
True
|
|
|
|
-}
|
|
|
|
bool :: Type Bool
|
|
|
|
bool = Type {..}
|
|
|
|
where
|
|
|
|
extract (BoolLit b) = pure b
|
|
|
|
extract _ = Nothing
|
|
|
|
|
|
|
|
expected = Bool
|
|
|
|
|
|
|
|
{-| Decode a `Natural`
|
|
|
|
|
|
|
|
>>> input natural "+42"
|
|
|
|
42
|
|
|
|
-}
|
|
|
|
natural :: Type Natural
|
|
|
|
natural = Type {..}
|
|
|
|
where
|
|
|
|
extract (NaturalLit n) = pure n
|
|
|
|
extract _ = empty
|
|
|
|
|
|
|
|
expected = Natural
|
|
|
|
|
|
|
|
{-| Decode an `Integer`
|
|
|
|
|
|
|
|
>>> input integer "42"
|
|
|
|
42
|
|
|
|
-}
|
|
|
|
integer :: Type Integer
|
|
|
|
integer = Type {..}
|
|
|
|
where
|
|
|
|
extract (IntegerLit n) = pure n
|
|
|
|
extract _ = empty
|
|
|
|
|
|
|
|
expected = Integer
|
|
|
|
|
|
|
|
{-| Decode a `Double`
|
|
|
|
|
|
|
|
>>> input double "42.0"
|
|
|
|
42.0
|
|
|
|
-}
|
|
|
|
double :: Type Double
|
|
|
|
double = Type {..}
|
|
|
|
where
|
|
|
|
extract (DoubleLit n) = pure n
|
|
|
|
extract _ = empty
|
|
|
|
|
|
|
|
expected = Double
|
|
|
|
|
2017-07-02 07:24:39 +02:00
|
|
|
{-| Decode lazy `Text`
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2017-07-02 07:24:39 +02:00
|
|
|
>>> input lazyText "\"Test\""
|
2016-09-09 18:17:25 +02:00
|
|
|
"Test"
|
|
|
|
-}
|
2017-07-02 07:24:39 +02:00
|
|
|
lazyText :: Type Text
|
|
|
|
lazyText = Type {..}
|
2016-09-09 18:17:25 +02:00
|
|
|
where
|
2018-01-22 01:32:28 +01:00
|
|
|
extract (TextLit (Chunks [] t)) = pure (Data.Text.Lazy.Builder.toLazyText t)
|
|
|
|
extract _ = empty
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
expected = Text
|
|
|
|
|
2017-07-02 07:24:39 +02:00
|
|
|
{-| Decode strict `Text`
|
|
|
|
|
|
|
|
>>> input strictText "\"Test\""
|
|
|
|
"Test"
|
|
|
|
-}
|
|
|
|
strictText :: Type Data.Text.Text
|
|
|
|
strictText = fmap Data.Text.Lazy.toStrict lazyText
|
|
|
|
|
2016-09-19 00:38:36 +02:00
|
|
|
{-| Decode a `Maybe`
|
|
|
|
|
2016-12-05 00:10:08 +01:00
|
|
|
>>> input (maybe integer) "[1] : Optional Integer"
|
|
|
|
Just 1
|
2016-09-19 00:38:36 +02:00
|
|
|
-}
|
|
|
|
maybe :: Type a -> Type (Maybe a)
|
|
|
|
maybe (Type extractIn expectedIn) = Type extractOut expectedOut
|
|
|
|
where
|
2016-11-12 17:31:13 +01:00
|
|
|
extractOut (OptionalLit _ es) = traverse extractIn es'
|
2016-09-19 00:38:36 +02:00
|
|
|
where
|
|
|
|
es' = if Data.Vector.null es then Nothing else Just (Data.Vector.head es)
|
2017-01-29 23:10:28 +01:00
|
|
|
extractOut _ = Nothing
|
2016-09-19 00:38:36 +02:00
|
|
|
|
2016-11-12 17:31:13 +01:00
|
|
|
expectedOut = App Optional expectedIn
|
2016-09-19 00:38:36 +02:00
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
{-| Decode a `Vector`
|
|
|
|
|
2017-02-05 16:23:25 +01:00
|
|
|
>>> input (vector integer) "[1, 2, 3]"
|
2016-09-09 18:17:25 +02:00
|
|
|
[1,2,3]
|
|
|
|
-}
|
|
|
|
vector :: Type a -> Type (Vector a)
|
|
|
|
vector (Type extractIn expectedIn) = Type extractOut expectedOut
|
|
|
|
where
|
|
|
|
extractOut (ListLit _ es) = traverse extractIn es
|
2017-01-29 23:10:28 +01:00
|
|
|
extractOut _ = Nothing
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2016-09-15 18:03:12 +02:00
|
|
|
expectedOut = App List expectedIn
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2018-01-23 01:38:42 +01:00
|
|
|
{-| Decode a list
|
|
|
|
|
|
|
|
>>> input (list integer) "[1, 2, 3]"
|
|
|
|
[1,2,3]
|
|
|
|
-}
|
|
|
|
list :: Type a -> Type [a]
|
|
|
|
list = fmap Data.Vector.toList . vector
|
|
|
|
|
|
|
|
{-| Decode `()` from an empty record.
|
|
|
|
|
|
|
|
>>> input unit "{=}"
|
|
|
|
()
|
|
|
|
-}
|
|
|
|
unit :: Type ()
|
|
|
|
unit = Type extractOut expectedOut
|
|
|
|
where
|
|
|
|
extractOut (RecordLit fields) | Data.Map.null fields = return ()
|
|
|
|
extractOut _ = Nothing
|
|
|
|
|
|
|
|
expectedOut = Record Data.Map.empty
|
|
|
|
|
|
|
|
{-| 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 (RecordLit fields) =
|
|
|
|
(,) <$> ( Data.Map.lookup "_1" fields >>= extract l )
|
|
|
|
<*> ( Data.Map.lookup "_2" fields >>= extract r )
|
|
|
|
extractOut _ = Nothing
|
|
|
|
|
|
|
|
expectedOut = Record (Data.Map.fromList [("_1", expected l)
|
|
|
|
,("_2", expected r)])
|
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
{-| Any value that implements `Interpret` can be automatically decoded based on
|
|
|
|
the inferred return type of `input`
|
|
|
|
|
2017-02-05 16:23:25 +01:00
|
|
|
>>> input auto "[1, 2, 3]" :: IO (Vector Integer)
|
2016-09-09 18:17:25 +02:00
|
|
|
[1,2,3]
|
2016-09-10 04:02:13 +02:00
|
|
|
|
|
|
|
This class auto-generates a default implementation for records that
|
2017-02-05 16:27:07 +01:00
|
|
|
implement `Generic`. This does not auto-generate an instance for recursive
|
|
|
|
types.
|
2016-09-09 18:17:25 +02:00
|
|
|
-}
|
|
|
|
class Interpret a where
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
autoWith:: InterpretOptions -> Type a
|
|
|
|
default autoWith
|
|
|
|
:: (Generic a, GenericInterpret (Rep a)) => InterpretOptions -> Type a
|
2017-08-22 22:30:28 +02:00
|
|
|
autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1)
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
instance Interpret Bool where
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
autoWith _ = bool
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
instance Interpret Natural where
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
autoWith _ = natural
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
instance Interpret Integer where
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
autoWith _ = integer
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
instance Interpret Double where
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
autoWith _ = double
|
2016-09-09 18:17:25 +02:00
|
|
|
|
|
|
|
instance Interpret Text where
|
2017-07-02 07:24:39 +02:00
|
|
|
autoWith _ = lazyText
|
|
|
|
|
|
|
|
instance Interpret Data.Text.Text where
|
|
|
|
autoWith _ = strictText
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2016-09-19 00:38:36 +02:00
|
|
|
instance Interpret a => Interpret (Maybe a) where
|
Fix `InterpretOptions` to work inside `Optional`/`List`. Fixes #33
Consider the following Haskell program:
```
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: Vector GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
Before this change the above program attempts to decode a value of type:
```
{ userName : Text, dotfilesRepo : List { _host : Text, _repo : Text } }
```
... when it should be decoding a value of type:
```
{ userName : Text, dotfilesRepo : List { host : Text, repo : Text } }
```
This change ensures that `InterpretOptions` correctly propagate to elements of
`List` or `Optional` values
2017-03-27 16:00:17 +02:00
|
|
|
autoWith opts = maybe (autoWith opts)
|
2016-09-19 00:38:36 +02:00
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
instance Interpret a => Interpret (Vector a) where
|
Fix `InterpretOptions` to work inside `Optional`/`List`. Fixes #33
Consider the following Haskell program:
```
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: Vector GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
Before this change the above program attempts to decode a value of type:
```
{ userName : Text, dotfilesRepo : List { _host : Text, _repo : Text } }
```
... when it should be decoding a value of type:
```
{ userName : Text, dotfilesRepo : List { host : Text, repo : Text } }
```
This change ensures that `InterpretOptions` correctly propagate to elements of
`List` or `Optional` values
2017-03-27 16:00:17 +02:00
|
|
|
autoWith opts = vector (autoWith opts)
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2017-08-21 20:36:59 +02:00
|
|
|
instance Interpret a => Interpret [a] where
|
|
|
|
autoWith = fmap (fmap Data.Vector.toList) autoWith
|
|
|
|
|
2017-07-22 13:53:24 +02:00
|
|
|
instance (Inject a, Interpret b) => Interpret (a -> b) where
|
|
|
|
autoWith opts = Type extractOut expectedOut
|
|
|
|
where
|
|
|
|
extractOut e = Just (\i -> case extractIn (Dhall.Core.normalize (App e (embed i))) of
|
|
|
|
Just o -> o
|
|
|
|
Nothing -> 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
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
deriving instance (Interpret a, Interpret b) => Interpret (a, b)
|
|
|
|
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
{-| Use the default options for interpreting a configuration file
|
2017-02-23 18:35:52 +01:00
|
|
|
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
> auto = autoWith defaultInterpretOptions
|
2017-02-23 18:35:52 +01:00
|
|
|
-}
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
auto :: Interpret a => Type a
|
|
|
|
auto = autoWith defaultInterpretOptions
|
2017-02-23 18:35:52 +01:00
|
|
|
|
2017-12-28 19:17:45 +01:00
|
|
|
{-| `genericAuto` is the default implementation for `auto` if you derive
|
|
|
|
`Interpret`. The difference is that you can use `genericAuto` without
|
|
|
|
having to explicitly provide an `Interpret` instance for a type as long as
|
|
|
|
the type derives `Generic`
|
|
|
|
-}
|
|
|
|
genericAuto :: (Generic a, GenericInterpret (Rep a)) => Type a
|
|
|
|
genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1)
|
|
|
|
|
2017-02-23 18:35:52 +01:00
|
|
|
{-| Use these options to tweak how Dhall derives a generic implementation of
|
|
|
|
`Interpret`
|
|
|
|
-}
|
|
|
|
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
|
|
|
|
}
|
|
|
|
|
|
|
|
{-| Default interpret options, which you can tweak or override, like this:
|
|
|
|
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
> autoWith
|
|
|
|
> (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') })
|
2017-02-23 18:35:52 +01:00
|
|
|
-}
|
|
|
|
defaultInterpretOptions :: InterpretOptions
|
|
|
|
defaultInterpretOptions = InterpretOptions
|
|
|
|
{ fieldModifier = id
|
|
|
|
, constructorModifier = id
|
|
|
|
}
|
|
|
|
|
|
|
|
{-| This is the underlying class that powers the `Interpret` class's support
|
|
|
|
for automatically deriving a generic implementation
|
|
|
|
-}
|
2016-09-09 18:17:25 +02:00
|
|
|
class GenericInterpret f where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith :: InterpretOptions -> State Int (Type (f a))
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2016-10-16 02:35:51 +02:00
|
|
|
instance GenericInterpret f => GenericInterpret (M1 D d f) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options = do
|
|
|
|
res <- genericAutoWith options
|
|
|
|
pure (fmap M1 res)
|
2016-10-16 02:35:51 +02:00
|
|
|
|
|
|
|
instance GenericInterpret V1 where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith _ = pure Type {..}
|
2016-10-16 02:35:51 +02:00
|
|
|
where
|
|
|
|
extract _ = Nothing
|
|
|
|
|
|
|
|
expected = Union Data.Map.empty
|
|
|
|
|
2016-12-05 16:33:09 +01:00
|
|
|
instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
|
2016-10-16 02:35:51 +02:00
|
|
|
where
|
2016-12-05 16:33:09 +01:00
|
|
|
nL :: M1 i c1 f1 a
|
|
|
|
nL = undefined
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2016-12-05 16:33:09 +01:00
|
|
|
nR :: M1 i c2 f2 a
|
|
|
|
nR = undefined
|
|
|
|
|
2017-02-23 18:35:52 +01:00
|
|
|
nameL = constructorModifier (Data.Text.Lazy.pack (conName nL))
|
|
|
|
nameR = constructorModifier (Data.Text.Lazy.pack (conName nR))
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
extract (UnionLit name e _)
|
|
|
|
| name == nameL = fmap (L1 . M1) (extractL e)
|
|
|
|
| name == nameR = fmap (R1 . M1) (extractR e)
|
|
|
|
| otherwise = Nothing
|
2017-01-29 23:10:28 +01:00
|
|
|
extract _ = Nothing
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
expected =
|
|
|
|
Union (Data.Map.fromList [(nameL, expectedL), (nameR, expectedR)])
|
|
|
|
|
2017-08-22 22:30:28 +02:00
|
|
|
Type extractL expectedL = evalState (genericAutoWith options) 1
|
|
|
|
Type extractR expectedR = evalState (genericAutoWith options) 1
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
instance (Constructor c, GenericInterpret (f :+: g), GenericInterpret h) => GenericInterpret ((f :+: g) :+: M1 C c h) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
|
2016-12-05 16:33:09 +01:00
|
|
|
where
|
|
|
|
n :: M1 i c h a
|
|
|
|
n = undefined
|
|
|
|
|
2017-02-23 18:35:52 +01:00
|
|
|
name = constructorModifier (Data.Text.Lazy.pack (conName n))
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
extract u@(UnionLit name' e _)
|
|
|
|
| name == name' = fmap (R1 . M1) (extractR e)
|
|
|
|
| otherwise = fmap L1 (extractL u)
|
2017-01-29 23:10:28 +01:00
|
|
|
extract _ = Nothing
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
expected = Union (Data.Map.insert name expectedR expectedL)
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2017-08-22 22:30:28 +02:00
|
|
|
Type extractL (Union expectedL) = evalState (genericAutoWith options) 1
|
|
|
|
Type extractR expectedR = evalState (genericAutoWith options) 1
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2016-12-05 16:33:09 +01:00
|
|
|
instance (Constructor c, GenericInterpret f, GenericInterpret (g :+: h)) => GenericInterpret (M1 C c f :+: (g :+: h)) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
|
2016-10-16 02:35:51 +02:00
|
|
|
where
|
|
|
|
n :: M1 i c f a
|
|
|
|
n = undefined
|
|
|
|
|
2017-02-23 18:35:52 +01:00
|
|
|
name = constructorModifier (Data.Text.Lazy.pack (conName n))
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2016-12-05 16:33:09 +01:00
|
|
|
extract u@(UnionLit name' e _)
|
|
|
|
| name == name' = fmap (L1 . M1) (extractL e)
|
|
|
|
| otherwise = fmap R1 (extractR u)
|
2017-01-29 23:10:28 +01:00
|
|
|
extract _ = Nothing
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
expected = Union (Data.Map.insert name expectedL expectedR)
|
|
|
|
|
2017-08-22 22:30:28 +02:00
|
|
|
Type extractL expectedL = evalState (genericAutoWith options) 1
|
|
|
|
Type extractR (Union expectedR) = evalState (genericAutoWith options) 1
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
instance (GenericInterpret (f :+: g), GenericInterpret (h :+: i)) => GenericInterpret ((f :+: g) :+: (h :+: i)) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options = pure (Type {..})
|
2016-12-05 16:33:09 +01:00
|
|
|
where
|
|
|
|
extract e = fmap L1 (extractL e) <|> fmap R1 (extractR e)
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2016-12-05 16:33:09 +01:00
|
|
|
expected = Union (Data.Map.union expectedL expectedR)
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2017-08-22 22:30:28 +02:00
|
|
|
Type extractL (Union expectedL) = evalState (genericAutoWith options) 1
|
|
|
|
Type extractR (Union expectedR) = evalState (genericAutoWith options) 1
|
2016-12-05 16:33:09 +01:00
|
|
|
|
|
|
|
instance GenericInterpret f => GenericInterpret (M1 C c f) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options = do
|
|
|
|
res <- genericAutoWith options
|
|
|
|
pure (fmap M1 res)
|
2016-10-16 02:35:51 +02:00
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
instance GenericInterpret U1 where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith _ = pure (Type {..})
|
2016-09-09 18:17:25 +02:00
|
|
|
where
|
|
|
|
extract _ = Just U1
|
|
|
|
|
|
|
|
expected = Record (Data.Map.fromList [])
|
|
|
|
|
|
|
|
instance (GenericInterpret f, GenericInterpret g) => GenericInterpret (f :*: g) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith options = do
|
|
|
|
Type extractL expectedL <- genericAutoWith options
|
|
|
|
Type extractR expectedR <- genericAutoWith options
|
|
|
|
let Record ktsL = expectedL
|
|
|
|
let Record ktsR = expectedR
|
|
|
|
pure (Type { extract = liftA2 (liftA2 (:*:)) extractL extractR
|
|
|
|
, expected = Record (Data.Map.union ktsL ktsR) })
|
2016-09-09 18:17:25 +02:00
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
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
|
|
|
|
|
2016-09-09 18:17:25 +02:00
|
|
|
instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where
|
2017-08-22 22:30:28 +02:00
|
|
|
genericAutoWith opts@(InterpretOptions {..}) = do
|
2017-08-26 17:02:52 +02:00
|
|
|
name <- getSelName n
|
2017-08-22 22:30:28 +02:00
|
|
|
let extract (RecordLit m) = do
|
2017-02-23 18:35:52 +01:00
|
|
|
let name' = fieldModifier (Data.Text.Lazy.pack name)
|
|
|
|
e <- Data.Map.lookup name' m
|
2016-09-09 18:17:25 +02:00
|
|
|
fmap (M1 . K1) (extract' e)
|
2017-08-22 22:30:28 +02:00
|
|
|
extract _ = Nothing
|
|
|
|
let expected = Record (Data.Map.fromList [(key, expected')])
|
|
|
|
where
|
|
|
|
key = fieldModifier (Data.Text.Lazy.pack name)
|
|
|
|
pure (Type {..})
|
|
|
|
where
|
|
|
|
n :: M1 i s f a
|
|
|
|
n = undefined
|
2016-09-09 18:17:25 +02:00
|
|
|
|
Fix `InterpretOptions` to affect nested records. Fixes #33
Consider the following program which marshals a Dhall record into Haskell:
```haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Dhall hiding (auto)
import qualified Data.Text.Lazy
interpretOptions :: InterpretOptions
interpretOptions = defaultInterpretOptions
{ fieldModifier = Data.Text.Lazy.dropWhile (== '_') }
data GitRepo = GitRepo
{ _host :: Text
, _repo :: Text
} deriving (Generic, Interpret, Show)
data BoxConfig = BoxConfig
{ _userName :: Text
, _dotfilesRepo :: GitRepo
} deriving (Generic, Interpret, Show)
main :: IO ()
main = do
x <- Dhall.input (autoWith interpretOptions) "./config"
print (x :: BoxConfig)
```
The above program is a common pattern when mixing Dhall records with lenses
(which typically prefix the original fields with "_").
Before this change, the above program expects a record of the following type:
```
{ userName : Text, dotfilesRepo : { _host : Text, _repo : Text } }
```
Note that the sub-record ignores the `InterpretOptions` and incorrectly includes
the underscore in the expected field names.
This change fixes the derived `Interpret` instance for records to correctly
thread `InterpretOptions` to nested records.
This required a change to the `auto` method of the `Interpret` class to
accept `InterpretOptions`, otherwise there is no way to supply the
`InterpretOptions` record to sub-records. This modified `auto` method is now
called `autoWith`. I still include an `auto` function that uses
`defaultInterpretOptions` consistent with the old behavior.
2017-03-26 18:20:04 +02:00
|
|
|
Type extract' expected' = autoWith opts
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
{-| 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 X
|
|
|
|
-- ^ Embeds a Haskell value as a Dhall expression
|
|
|
|
, declared :: Expr Src X
|
|
|
|
-- ^ 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 `Interpret` instance for functions:
|
|
|
|
|
|
|
|
> instance (Inject a, Interpret b) => Interpret (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 X@)
|
|
|
|
* Applying the Dhall function (i.e. @f :: Expr Src X@) 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 Inject a where
|
|
|
|
injectWith :: InterpretOptions -> InputType a
|
|
|
|
default injectWith
|
|
|
|
:: (Generic a, GenericInject (Rep a)) => InterpretOptions -> InputType a
|
2017-08-26 17:02:52 +02:00
|
|
|
injectWith options
|
|
|
|
= contramap GHC.Generics.from (evalState (genericInjectWith options) 1)
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
{-| Use the default options for injecting a value
|
|
|
|
|
|
|
|
> inject = inject defaultInterpretOptions
|
|
|
|
-}
|
|
|
|
inject :: Inject a => InputType a
|
|
|
|
inject = injectWith defaultInterpretOptions
|
|
|
|
|
|
|
|
instance Inject Bool where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = BoolLit
|
|
|
|
|
|
|
|
declared = Bool
|
|
|
|
|
|
|
|
instance Inject Text where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
2018-01-22 01:32:28 +01:00
|
|
|
embed text =
|
|
|
|
TextLit (Chunks [] (Data.Text.Lazy.Builder.fromLazyText text))
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
declared = Text
|
|
|
|
|
|
|
|
instance Inject Data.Text.Text where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
2018-01-22 01:32:28 +01:00
|
|
|
embed text = TextLit (Chunks [] (Data.Text.Lazy.Builder.fromText text))
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
declared = Text
|
|
|
|
|
|
|
|
instance Inject Natural where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = NaturalLit
|
|
|
|
|
|
|
|
declared = Natural
|
|
|
|
|
|
|
|
instance Inject Integer where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = IntegerLit
|
|
|
|
|
|
|
|
declared = Integer
|
|
|
|
|
2017-08-20 19:24:24 +02:00
|
|
|
instance Inject Int where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = IntegerLit . toInteger
|
|
|
|
|
|
|
|
declared = Integer
|
|
|
|
|
2017-08-28 01:06:57 +02:00
|
|
|
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
|
|
|
|
|
2017-08-20 19:24:24 +02:00
|
|
|
|
2017-07-22 13:53:24 +02:00
|
|
|
instance Inject Double where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = DoubleLit
|
|
|
|
|
|
|
|
declared = Double
|
|
|
|
|
2017-09-29 21:49:34 +02:00
|
|
|
instance Inject () where
|
|
|
|
injectWith _ = InputType {..}
|
|
|
|
where
|
|
|
|
embed = const (RecordLit Data.Map.empty)
|
|
|
|
|
|
|
|
declared = Record Data.Map.empty
|
|
|
|
|
2017-07-22 13:53:24 +02:00
|
|
|
instance Inject a => Inject (Maybe a) where
|
|
|
|
injectWith options = InputType embedOut declaredOut
|
|
|
|
where
|
|
|
|
embedOut (Just x) =
|
|
|
|
OptionalLit declaredIn (Data.Vector.singleton (embedIn x))
|
|
|
|
embedOut Nothing =
|
|
|
|
OptionalLit declaredIn Data.Vector.empty
|
|
|
|
|
|
|
|
InputType embedIn declaredIn = injectWith options
|
|
|
|
|
|
|
|
declaredOut = App Optional declaredIn
|
|
|
|
|
|
|
|
instance Inject a => Inject (Vector a) where
|
|
|
|
injectWith options = InputType embedOut declaredOut
|
|
|
|
where
|
|
|
|
embedOut xs = ListLit (Just declaredIn) (fmap embedIn xs)
|
|
|
|
|
|
|
|
declaredOut = App List declaredIn
|
|
|
|
|
|
|
|
InputType embedIn declaredIn = injectWith options
|
|
|
|
|
2017-08-21 20:36:59 +02:00
|
|
|
instance Inject a => Inject [a] where
|
|
|
|
injectWith = fmap (contramap Data.Vector.fromList) injectWith
|
|
|
|
|
2017-08-28 17:58:46 +02:00
|
|
|
instance Inject a => Inject (Data.Set.Set a) where
|
|
|
|
injectWith = fmap (contramap go) injectWith where
|
|
|
|
go se = Data.Vector.fromListN (Data.Set.size se) (Data.Foldable.toList se)
|
|
|
|
|
|
|
|
instance Inject a => Inject (Data.Sequence.Seq a) where
|
|
|
|
injectWith = fmap (contramap go) injectWith where
|
|
|
|
go se = Data.Vector.fromListN (Data.Sequence.length se) (Data.Foldable.toList se)
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
deriving instance (Inject a, Inject b) => Inject (a, b)
|
2017-08-21 18:08:51 +02:00
|
|
|
|
2017-07-22 13:53:24 +02:00
|
|
|
{-| This is the underlying class that powers the `Interpret` class's support
|
|
|
|
for automatically deriving a generic implementation
|
|
|
|
-}
|
|
|
|
class GenericInject f where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith :: InterpretOptions -> State Int (InputType (f a))
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance GenericInject f => GenericInject (M1 D d f) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options = do
|
|
|
|
res <- genericInjectWith options
|
|
|
|
pure (contramap unM1 res)
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance GenericInject f => GenericInject (M1 C c f) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options = do
|
|
|
|
res <- genericInjectWith options
|
|
|
|
pure (contramap unM1 res)
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
embed (L1 (M1 l)) = UnionLit keyL (embedL l) Data.Map.empty
|
|
|
|
embed (R1 (M1 r)) = UnionLit keyR (embedR r) Data.Map.empty
|
|
|
|
|
|
|
|
declared =
|
|
|
|
Union (Data.Map.fromList [(keyL, declaredL), (keyR, declaredR)])
|
|
|
|
|
|
|
|
nL :: M1 i c1 f1 a
|
|
|
|
nL = undefined
|
|
|
|
|
|
|
|
nR :: M1 i c2 f2 a
|
|
|
|
nR = undefined
|
|
|
|
|
|
|
|
keyL = constructorModifier (Data.Text.Lazy.pack (conName nL))
|
|
|
|
keyR = constructorModifier (Data.Text.Lazy.pack (conName nR))
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
InputType embedL declaredL = evalState (genericInjectWith options) 1
|
|
|
|
InputType embedR declaredR = evalState (genericInjectWith options) 1
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInject ((f :+: g) :+: M1 C c h) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
embed (L1 l) = UnionLit keyL valL (Data.Map.insert keyR declaredR ktsL')
|
|
|
|
where
|
|
|
|
UnionLit keyL valL ktsL' = embedL l
|
|
|
|
embed (R1 (M1 r)) = UnionLit keyR (embedR r) ktsL
|
|
|
|
|
|
|
|
nR :: M1 i c h a
|
|
|
|
nR = undefined
|
|
|
|
|
|
|
|
keyR = constructorModifier (Data.Text.Lazy.pack (conName nR))
|
|
|
|
|
|
|
|
declared = Union (Data.Map.insert keyR declaredR ktsL)
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1
|
|
|
|
InputType embedR declaredR = evalState (genericInjectWith options) 1
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
embed (L1 (M1 l)) = UnionLit keyL (embedL l) ktsR
|
|
|
|
embed (R1 r) = UnionLit keyR valR (Data.Map.insert keyL declaredL ktsR')
|
|
|
|
where
|
|
|
|
UnionLit keyR valR ktsR' = embedR r
|
|
|
|
|
|
|
|
nL :: M1 i c f a
|
|
|
|
nL = undefined
|
|
|
|
|
|
|
|
keyL = constructorModifier (Data.Text.Lazy.pack (conName nL))
|
|
|
|
|
|
|
|
declared = Union (Data.Map.insert keyL declaredL ktsR)
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
InputType embedL declaredL = evalState (genericInjectWith options) 1
|
|
|
|
InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f :+: g) :+: (h :+: i)) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options = pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
embed (L1 l) = UnionLit keyL valR (Data.Map.union ktsL' ktsR)
|
|
|
|
where
|
|
|
|
UnionLit keyL valR ktsL' = embedL l
|
|
|
|
embed (R1 r) = UnionLit keyR valR (Data.Map.union ktsL ktsR')
|
|
|
|
where
|
|
|
|
UnionLit keyR valR ktsR' = embedR r
|
|
|
|
|
|
|
|
declared = Union (Data.Map.union ktsL ktsR)
|
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1
|
|
|
|
InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance (GenericInject f, GenericInject g) => GenericInject (f :*: g) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith options = do
|
|
|
|
InputType embedInL declaredInL <- genericInjectWith options
|
|
|
|
InputType embedInR declaredInR <- genericInjectWith options
|
2017-07-22 13:53:24 +02:00
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
let embed (l :*: r) = RecordLit (Data.Map.union mapL mapR)
|
|
|
|
where
|
|
|
|
RecordLit mapL = embedInL l
|
|
|
|
RecordLit mapR = embedInR r
|
2017-07-22 13:53:24 +02:00
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
let declared = Record (Data.Map.union mapL mapR)
|
|
|
|
where
|
|
|
|
Record mapL = declaredInL
|
|
|
|
Record mapR = declaredInR
|
2017-07-22 13:53:24 +02:00
|
|
|
|
2017-08-26 17:02:52 +02:00
|
|
|
pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
|
|
|
|
instance GenericInject U1 where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith _ = pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
embed _ = RecordLit Data.Map.empty
|
|
|
|
|
|
|
|
declared = Record Data.Map.empty
|
|
|
|
|
|
|
|
instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where
|
2017-08-26 17:02:52 +02:00
|
|
|
genericInjectWith opts@(InterpretOptions {..}) = do
|
|
|
|
name <- fieldModifier . Data.Text.Lazy.pack <$> getSelName n
|
|
|
|
let embed (M1 (K1 x)) = RecordLit (Data.Map.singleton name (embedIn x))
|
|
|
|
let declared = Record (Data.Map.singleton name declaredIn)
|
|
|
|
pure (InputType {..})
|
2017-07-22 13:53:24 +02:00
|
|
|
where
|
|
|
|
n :: M1 i s f a
|
|
|
|
n = undefined
|
|
|
|
|
|
|
|
InputType embedIn declaredIn = injectWith opts
|