Implement Inject instance for unnamed tuples. (#107)
This removes the need for `R2`
This commit is contained in:
bosu
Gabriel Gonzalez
parent
47849e3fca
commit
5b1cbb08af
111
src/Dhall.hs
111
src/Dhall.hs
|
|
@ -7,6 +7,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
|
||||
|
|
@ -24,7 +25,6 @@ module Dhall
|
|||
, InputType(..)
|
||||
, Interpret(..)
|
||||
, InvalidType(..)
|
||||
, R2(..)
|
||||
, auto
|
||||
, InterpretOptions(..)
|
||||
, defaultInterpretOptions
|
||||
|
|
@ -107,14 +107,6 @@ instance Show InvalidType where
|
|||
|
||||
instance Exception InvalidType
|
||||
|
||||
{-| Dhall uses the type @R2 a b@ to represent a 2-tuple of type @(a, b)@
|
||||
|
||||
You might prefer to use this type instead of a 2-tuple if you want the Dhall
|
||||
type to exactly match the Haskell type
|
||||
-}
|
||||
data R2 a b = R2 { _1 :: a, _2 :: b }
|
||||
deriving (Generic, Inject, Interpret, Show)
|
||||
|
||||
{-| Type-check and evaluate a Dhall program, decoding the result into Haskell
|
||||
|
||||
The first argument determines the type of value that you decode:
|
||||
|
|
@ -464,10 +456,6 @@ instance Interpret a => Interpret (Vector a) where
|
|||
instance Interpret a => Interpret [a] where
|
||||
autoWith = fmap (fmap Data.Vector.toList) autoWith
|
||||
|
||||
-- | The Haskell type @(a, b)@ corresponds to the Dhall type @{ _1 : a, _2 : b }@
|
||||
instance (Interpret a, Interpret b) => Interpret (a, b) where
|
||||
autoWith = fmap (\R2{..} -> (_1, _2)) . autoWith
|
||||
|
||||
instance (Inject a, Interpret b) => Interpret (a -> b) where
|
||||
autoWith opts = Type extractOut expectedOut
|
||||
where
|
||||
|
|
@ -481,6 +469,8 @@ instance (Inject a, Interpret b) => Interpret (a -> b) where
|
|||
|
||||
Type extractIn expectedIn = autoWith opts
|
||||
|
||||
deriving instance (Interpret a, Interpret b) => Interpret (a, b)
|
||||
|
||||
{-| Use the default options for interpreting a configuration file
|
||||
|
||||
> auto = autoWith defaultInterpretOptions
|
||||
|
|
@ -620,13 +610,16 @@ instance (GenericInterpret f, GenericInterpret g) => GenericInterpret (f :*: g)
|
|||
pure (Type { extract = liftA2 (liftA2 (:*:)) extractL extractR
|
||||
, expected = Record (Data.Map.union ktsL ktsR) })
|
||||
|
||||
getSelName :: Selector s => M1 i s f a -> State Int String
|
||||
getSelName n = case selName n of
|
||||
"" -> do i <- get
|
||||
put (i + 1)
|
||||
pure ("_" ++ show i)
|
||||
nn -> pure nn
|
||||
|
||||
instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where
|
||||
genericAutoWith opts@(InterpretOptions {..}) = do
|
||||
name <- case selName n of
|
||||
"" -> do i <- get
|
||||
put (i + 1)
|
||||
pure ("_" ++ show i)
|
||||
nn -> pure nn
|
||||
name <- getSelName n
|
||||
let extract (RecordLit m) = do
|
||||
let name' = fieldModifier (Data.Text.Lazy.pack name)
|
||||
e <- Data.Map.lookup name' m
|
||||
|
|
@ -675,7 +668,8 @@ class Inject a where
|
|||
injectWith :: InterpretOptions -> InputType a
|
||||
default injectWith
|
||||
:: (Generic a, GenericInject (Rep a)) => InterpretOptions -> InputType a
|
||||
injectWith options = contramap GHC.Generics.from (genericInjectWith options)
|
||||
injectWith options
|
||||
= contramap GHC.Generics.from (evalState (genericInjectWith options) 1)
|
||||
|
||||
{-| Use the default options for injecting a value
|
||||
|
||||
|
|
@ -758,26 +752,26 @@ instance Inject a => Inject (Vector a) where
|
|||
instance Inject a => Inject [a] where
|
||||
injectWith = fmap (contramap Data.Vector.fromList) injectWith
|
||||
|
||||
-- | The Haskell type @(a, b)@ corresponds to the Dhall type @{ _1 : a, _2 : b }@
|
||||
instance (Inject a, Inject b) => Inject (a, b) where
|
||||
injectWith = fmap (contramap adapt) injectWith
|
||||
where
|
||||
adapt (_1, _2) = R2 {..}
|
||||
deriving instance (Inject a, Inject b) => Inject (a, b)
|
||||
|
||||
{-| This is the underlying class that powers the `Interpret` class's support
|
||||
for automatically deriving a generic implementation
|
||||
-}
|
||||
class GenericInject f where
|
||||
genericInjectWith :: InterpretOptions -> InputType (f a)
|
||||
genericInjectWith :: InterpretOptions -> State Int (InputType (f a))
|
||||
|
||||
instance GenericInject f => GenericInject (M1 D d f) where
|
||||
genericInjectWith = fmap (contramap unM1) genericInjectWith
|
||||
genericInjectWith options = do
|
||||
res <- genericInjectWith options
|
||||
pure (contramap unM1 res)
|
||||
|
||||
instance GenericInject f => GenericInject (M1 C c f) where
|
||||
genericInjectWith = fmap (contramap unM1) genericInjectWith
|
||||
genericInjectWith options = do
|
||||
res <- genericInjectWith options
|
||||
pure (contramap unM1 res)
|
||||
|
||||
instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where
|
||||
genericInjectWith options@(InterpretOptions {..}) = InputType {..}
|
||||
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
||||
where
|
||||
embed (L1 (M1 l)) = UnionLit keyL (embedL l) Data.Map.empty
|
||||
embed (R1 (M1 r)) = UnionLit keyR (embedR r) Data.Map.empty
|
||||
|
|
@ -794,11 +788,11 @@ instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) =>
|
|||
keyL = constructorModifier (Data.Text.Lazy.pack (conName nL))
|
||||
keyR = constructorModifier (Data.Text.Lazy.pack (conName nR))
|
||||
|
||||
InputType embedL declaredL = genericInjectWith options
|
||||
InputType embedR declaredR = genericInjectWith options
|
||||
InputType embedL declaredL = evalState (genericInjectWith options) 1
|
||||
InputType embedR declaredR = evalState (genericInjectWith options) 1
|
||||
|
||||
instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInject ((f :+: g) :+: M1 C c h) where
|
||||
genericInjectWith options@(InterpretOptions {..}) = InputType {..}
|
||||
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
||||
where
|
||||
embed (L1 l) = UnionLit keyL valL (Data.Map.insert keyR declaredR ktsL')
|
||||
where
|
||||
|
|
@ -812,11 +806,11 @@ instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInj
|
|||
|
||||
declared = Union (Data.Map.insert keyR declaredR ktsL)
|
||||
|
||||
InputType embedL (Union ktsL) = genericInjectWith options
|
||||
InputType embedR declaredR = genericInjectWith options
|
||||
InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1
|
||||
InputType embedR declaredR = evalState (genericInjectWith options) 1
|
||||
|
||||
instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where
|
||||
genericInjectWith options@(InterpretOptions {..}) = InputType {..}
|
||||
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
||||
where
|
||||
embed (L1 (M1 l)) = UnionLit keyL (embedL l) ktsR
|
||||
embed (R1 r) = UnionLit keyR valR (Data.Map.insert keyL declaredL ktsR')
|
||||
|
|
@ -830,11 +824,11 @@ instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInj
|
|||
|
||||
declared = Union (Data.Map.insert keyL declaredL ktsR)
|
||||
|
||||
InputType embedL declaredL = genericInjectWith options
|
||||
InputType embedR (Union ktsR) = genericInjectWith options
|
||||
InputType embedL declaredL = evalState (genericInjectWith options) 1
|
||||
InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1
|
||||
|
||||
instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f :+: g) :+: (h :+: i)) where
|
||||
genericInjectWith options = InputType {..}
|
||||
genericInjectWith options = pure (InputType {..})
|
||||
where
|
||||
embed (L1 l) = UnionLit keyL valR (Data.Map.union ktsL' ktsR)
|
||||
where
|
||||
|
|
@ -845,44 +839,41 @@ instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f
|
|||
|
||||
declared = Union (Data.Map.union ktsL ktsR)
|
||||
|
||||
InputType embedL (Union ktsL) = genericInjectWith options
|
||||
InputType embedR (Union ktsR) = genericInjectWith options
|
||||
InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1
|
||||
InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1
|
||||
|
||||
instance (GenericInject f, GenericInject g) => GenericInject (f :*: g) where
|
||||
genericInjectWith options = InputType embedOut declaredOut
|
||||
where
|
||||
embedOut (l :*: r) = RecordLit (Data.Map.union mapL mapR)
|
||||
where
|
||||
RecordLit mapL = embedInL l
|
||||
RecordLit mapR = embedInR r
|
||||
genericInjectWith options = do
|
||||
InputType embedInL declaredInL <- genericInjectWith options
|
||||
InputType embedInR declaredInR <- genericInjectWith options
|
||||
|
||||
declaredOut = Record (Data.Map.union mapL mapR)
|
||||
where
|
||||
Record mapL = declaredInL
|
||||
Record mapR = declaredInR
|
||||
let embed (l :*: r) = RecordLit (Data.Map.union mapL mapR)
|
||||
where
|
||||
RecordLit mapL = embedInL l
|
||||
RecordLit mapR = embedInR r
|
||||
|
||||
InputType embedInL declaredInL = genericInjectWith options
|
||||
let declared = Record (Data.Map.union mapL mapR)
|
||||
where
|
||||
Record mapL = declaredInL
|
||||
Record mapR = declaredInR
|
||||
|
||||
InputType embedInR declaredInR = genericInjectWith options
|
||||
pure (InputType {..})
|
||||
|
||||
instance GenericInject U1 where
|
||||
genericInjectWith _ = InputType {..}
|
||||
genericInjectWith _ = pure (InputType {..})
|
||||
where
|
||||
embed _ = RecordLit Data.Map.empty
|
||||
|
||||
declared = Record Data.Map.empty
|
||||
|
||||
instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where
|
||||
genericInjectWith opts@(InterpretOptions {..}) =
|
||||
InputType embedOut declaredOut
|
||||
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 {..})
|
||||
where
|
||||
n :: M1 i s f a
|
||||
n = undefined
|
||||
|
||||
name = fieldModifier (Data.Text.Lazy.pack (selName n))
|
||||
|
||||
embedOut (M1 (K1 x)) = RecordLit (Data.Map.singleton name (embedIn x))
|
||||
|
||||
declaredOut = Record (Data.Map.singleton name declaredIn)
|
||||
|
||||
InputType embedIn declaredIn = injectWith opts
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ regressionTests =
|
|||
]
|
||||
|
||||
data Foo = Foo Integer Bool | Bar Bool Bool Bool | Baz Integer Integer
|
||||
deriving (Show, Dhall.Generic, Dhall.Interpret)
|
||||
deriving (Show, Dhall.Generic, Dhall.Interpret, Dhall.Inject)
|
||||
|
||||
unnamedFields :: TestTree
|
||||
unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do
|
||||
|
|
@ -35,6 +35,17 @@ unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do
|
|||
("_1",Dhall.Core.Integer),("_2",Dhall.Core.Integer)]))
|
||||
,("Foo",Dhall.Core.Record (Data.Map.fromList [
|
||||
("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool)]))]))
|
||||
|
||||
let inj = Dhall.inject @Foo
|
||||
Test.Tasty.HUnit.assertEqual "Good Inject" (Dhall.declared inj) (Dhall.expected ty)
|
||||
|
||||
let tu_ty = Dhall.auto @(Integer, Bool)
|
||||
Test.Tasty.HUnit.assertEqual "Auto Tuple" (Dhall.expected tu_ty) (Dhall.Core.Record (
|
||||
Data.Map.fromList [ ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool) ]))
|
||||
|
||||
let tu_in = Dhall.inject @(Integer, Bool)
|
||||
Test.Tasty.HUnit.assertEqual "Inj. Tuple" (Dhall.declared tu_in) (Dhall.expected tu_ty)
|
||||
|
||||
return () )
|
||||
|
||||
issue96 :: TestTree
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user