From caaf460cf9640e768549871958f5895fcb30779d Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 19 Apr 2023 15:10:49 +0200 Subject: [PATCH 1/7] Added SingleConstructorWith and MultipleConstructorsWith to Dhall.TH --- dhall/src/Dhall/TH.hs | 50 ++++++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 12 deletions(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index a27e5f8c5..e44f6d274 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -250,20 +250,18 @@ toDeclaration -> [HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q [Dec] -toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = +toDeclaration globalGenerateOptions haskellTypes typ = case typ of - SingleConstructor{..} -> uncurry (fromSingle typeName constructorName) $ getTypeParams code - MultipleConstructors{..} -> uncurry (fromMulti typeName) $ getTypeParams code + SingleConstructor{..} -> uncurry (fromSingle globalGenerateOptions typeName constructorName) $ getTypeParams code + SingleConstructorWith{..} -> uncurry (fromSingle options typeName constructorName) $ getTypeParams code + MultipleConstructors{..} -> uncurry (fromMulti globalGenerateOptions typeName) $ getTypeParams code + MultipleConstructorsWith{..} -> uncurry (fromMulti options typeName) $ getTypeParams code where getTypeParams = first numberConsecutive . getTypeParams_ [] getTypeParams_ acc (Lam _ (FunctionBinding _ v _ _ _) rest) = getTypeParams_ (v:acc) rest getTypeParams_ acc rest = (acc, rest) - derivingClauses = [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] - - interpretOptions = generateToInterpretOptions generateOptions typ - #if MIN_VERSION_template_haskell(2,21,0) toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis #elif MIN_VERSION_template_haskell(2,17,0) @@ -272,26 +270,30 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) #endif - toDataD typeName typeParams constructors = do + toDataD generateOptions@GenerateOptions{..} typeName typeParams constructors = do let name = Syntax.mkName (Text.unpack typeName) let params = fmap toTypeVar typeParams + let interpretOptions = generateToInterpretOptions generateOptions typ + + let derivingClauses = [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] + fmap concat . sequence $ [pure [DataD [] name params Nothing constructors derivingClauses]] <> [ fromDhallInstance name interpretOptions | generateFromDhallInstance ] <> [ toDhallInstance name interpretOptions | generateToDhallInstance ] - fromSingle typeName constructorName typeParams dhallType = do + fromSingle generateOptions typeName constructorName typeParams dhallType = do constructor <- toConstructor typeParams generateOptions haskellTypes typeName (constructorName, Just dhallType) - toDataD typeName typeParams [constructor] + toDataD generateOptions typeName typeParams [constructor] - fromMulti typeName typeParams dhallType = case dhallType of + fromMulti generateOptions typeName typeParams dhallType = case dhallType of Union kts -> do constructors <- traverse (toConstructor typeParams generateOptions haskellTypes typeName) (Dhall.Map.toList kts) - toDataD typeName typeParams constructors + toDataD generateOptions typeName typeParams constructors _ -> fail $ message dhallType @@ -437,6 +439,30 @@ data HaskellType code , code :: code -- ^ Dhall code that evaluates to a type } + -- | Generate a Haskell type with more than one constructor from a Dhall + -- union type. + | MultipleConstructorsWith + { options :: GenerateOptions + -- ^ The 'GenerateOptions' to use then generating the Haskell type. + , typeName :: Text + -- ^ Name of the generated Haskell type + , code :: code + -- ^ Dhall code that evaluates to a union type + } + -- | Generate a Haskell type with one constructor from any Dhall type. + -- + -- To generate a constructor with multiple named fields, supply a Dhall + -- record type. This does not support more than one anonymous field. + | SingleConstructorWith + { options :: GenerateOptions + -- ^ The 'GenerateOptions' to use then generating the Haskell type. + , typeName :: Text + -- ^ Name of the generated Haskell type + , constructorName :: Text + -- ^ Name of the constructor + , code :: code + -- ^ Dhall code that evaluates to a type + } deriving (Functor, Foldable, Traversable) -- | This data type holds various options that let you control several aspects From 87d0ab23d176e528830c932de26277143571093c Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 19 Apr 2023 16:15:33 +0200 Subject: [PATCH 2/7] Added Predefined to Dhall.TH --- dhall/src/Dhall/TH.hs | 77 ++++++++++++++++++++++++++----------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index e44f6d274..def1c35eb 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -20,7 +21,7 @@ module Dhall.TH , defaultGenerateOptions ) where -import Data.Bifunctor (first) +import Data.Map (Map) import Data.Text (Text) import Dhall (FromDhall, ToDhall) import Dhall.Syntax (Expr (..), FunctionBinding (..), Var (..)) @@ -165,6 +166,22 @@ toNestedHaskellType typeParams haskellTypes = loop message dhallType = Pretty.renderString (Dhall.Pretty.layout (document dhallType)) loop dhallType = case dhallType of + Var v + | Just (V param index) <- List.find (v ==) typeParams -> do + let name = Syntax.mkName $ (Text.unpack param) ++ (show index) + + return (VarT name) + + | otherwise -> fail $ message v + + _ | Just haskellType <- List.find (predicate dhallType) haskellTypes -> + case haskellType of + Predefined{..} -> return haskellSplice + _ -> do + let name = Syntax.mkName (Text.unpack (typeName haskellType)) + + return (ConT name) + Bool -> return (ConT ''Bool) @@ -205,19 +222,7 @@ toNestedHaskellType typeParams haskellTypes = loop return (AppT haskellAppType haskellElementType) - Var v - | Just (V param index) <- List.find (v ==) typeParams -> do - let name = Syntax.mkName $ (Text.unpack param) ++ (show index) - - return (VarT name) - - | otherwise -> fail $ message v - - _ | Just haskellType <- List.find (predicate dhallType) haskellTypes -> do - let name = Syntax.mkName (Text.unpack (typeName haskellType)) - - return (ConT name) - | otherwise -> fail $ message dhallType + _ -> fail $ message dhallType -- | A deriving clause for `Generic`. derivingGenericClause :: DerivClause @@ -256,12 +261,8 @@ toDeclaration globalGenerateOptions haskellTypes typ = SingleConstructorWith{..} -> uncurry (fromSingle options typeName constructorName) $ getTypeParams code MultipleConstructors{..} -> uncurry (fromMulti globalGenerateOptions typeName) $ getTypeParams code MultipleConstructorsWith{..} -> uncurry (fromMulti options typeName) $ getTypeParams code + Predefined{} -> return [] where - getTypeParams = first numberConsecutive . getTypeParams_ [] - - getTypeParams_ acc (Lam _ (FunctionBinding _ v _ _ _) rest) = getTypeParams_ (v:acc) rest - getTypeParams_ acc rest = (acc, rest) - #if MIN_VERSION_template_haskell(2,21,0) toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis #elif MIN_VERSION_template_haskell(2,17,0) @@ -337,13 +338,21 @@ toDeclaration globalGenerateOptions haskellTypes typ = , "... which is not a union type." ] --- | Number each variable, starting at 0 -numberConsecutive :: [Text.Text] -> [Var] -numberConsecutive = snd . List.mapAccumR go Map.empty . reverse +getTypeParams :: Expr s a -> ([Var], Expr s a) +getTypeParams = go [] where - go m k = - let (i, m') = Map.updateLookupWithKey (\_ j -> Just $ j + 1) k m - in maybe ((Map.insert k 0 m'), (V k 0)) (\i' -> (m', (V k i'))) i + go :: [Text] -> Expr s a -> ([Var], Expr s a) + go !acc (Lam _ (FunctionBinding _ v _ _ _) rest) = go (v:acc) rest + go !acc rest = (numberConsecutive $ reverse acc, rest) + + -- | Number each variable, starting at 0 + numberConsecutive :: [Text.Text] -> [Var] + numberConsecutive = snd . List.mapAccumR numberVar Map.empty + + numberVar :: Map Text Int -> Text -> (Map Text Int, Var) + numberVar m k = + let (i, m') = Map.updateLookupWithKey (\_ j -> Just $ j + 1) k m + in maybe ((Map.insert k 0 m'), (V k 0)) (\i' -> (m', (V k i'))) i -- | Convert a Dhall type to the corresponding Haskell constructor toConstructor @@ -439,8 +448,8 @@ data HaskellType code , code :: code -- ^ Dhall code that evaluates to a type } - -- | Generate a Haskell type with more than one constructor from a Dhall - -- union type. + -- | Like 'MultipleConstructors', but also takes some 'GenerateOptions' to + -- use for the generation of the Haskell type. | MultipleConstructorsWith { options :: GenerateOptions -- ^ The 'GenerateOptions' to use then generating the Haskell type. @@ -449,10 +458,8 @@ data HaskellType code , code :: code -- ^ Dhall code that evaluates to a union type } - -- | Generate a Haskell type with one constructor from any Dhall type. - -- - -- To generate a constructor with multiple named fields, supply a Dhall - -- record type. This does not support more than one anonymous field. + -- | Like 'SingleConstructor', but also takes some 'GenerateOptions' to use + -- for the generation of the Haskell type. | SingleConstructorWith { options :: GenerateOptions -- ^ The 'GenerateOptions' to use then generating the Haskell type. @@ -463,6 +470,14 @@ data HaskellType code , code :: code -- ^ Dhall code that evaluates to a type } + -- | Declare a predefined mapping from a Dhall type to an existing Haskell + -- type. + | Predefined + { haskellSplice :: Type + -- ^ An existing Haskell type + , code :: code + -- ^ Dhall code that evaluates to a type + } deriving (Functor, Foldable, Traversable) -- | This data type holds various options that let you control several aspects From 096b4a6be79d4a1f259aa6fc1d02caf8e801489a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 19 Apr 2023 16:34:43 +0200 Subject: [PATCH 3/7] Added Scoped to Dhall.TH --- dhall/src/Dhall/TH.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index def1c35eb..f03f72627 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -133,6 +133,7 @@ toNestedHaskellType -> Q Type toNestedHaskellType typeParams haskellTypes = loop where + predicate _ Scoped{} = False predicate dhallType haskellType = Core.judgmentallyEqual (code haskellType) dhallType document dhallType = @@ -262,6 +263,10 @@ toDeclaration globalGenerateOptions haskellTypes typ = MultipleConstructors{..} -> uncurry (fromMulti globalGenerateOptions typeName) $ getTypeParams code MultipleConstructorsWith{..} -> uncurry (fromMulti options typeName) $ getTypeParams code Predefined{} -> return [] + Scoped scopedHaskellTypes -> + let haskellTypes' = haskellTypes <> scopedHaskellTypes + in + concat <$> traverse (toDeclaration globalGenerateOptions haskellTypes') scopedHaskellTypes where #if MIN_VERSION_template_haskell(2,21,0) toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis @@ -374,7 +379,8 @@ toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constru case maybeAlternativeType of Just dhallType - | let predicate haskellType = + | let predicate Scoped{} = False + predicate haskellType = Core.judgmentallyEqual (code haskellType) dhallType && typeName haskellType /= outerTypeName , Just haskellType <- List.find predicate haskellTypes -> do @@ -478,6 +484,8 @@ data HaskellType code , code :: code -- ^ Dhall code that evaluates to a type } + -- | Generate some Haskell types within a restricted scope. + | Scoped [HaskellType code] deriving (Functor, Foldable, Traversable) -- | This data type holds various options that let you control several aspects @@ -520,6 +528,8 @@ defaultGenerateOptions = GenerateOptions -- I.e. those `Dhall.InterpretOptions` reflect the mapping done by -- `constructorModifier` and `fieldModifier` on the value level. generateToInterpretOptions :: GenerateOptions -> HaskellType (Expr s a) -> Q Exp +generateToInterpretOptions _ SingleConstructorWith{..} = generateToInterpretOptions options SingleConstructor{..} +generateToInterpretOptions _ MultipleConstructorsWith{..} = generateToInterpretOptions options MultipleConstructors{..} generateToInterpretOptions GenerateOptions{..} haskellType = [| Dhall.InterpretOptions { Dhall.fieldModifier = \ $(pure nameP) -> $(toCases fieldModifier $ fields haskellType) From 5f3baa2de5ca89e6f35aaf17a527b3cf059fc36f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 19 Apr 2023 17:28:02 +0200 Subject: [PATCH 4/7] Added tests --- dhall/src/Dhall/TH.hs | 2 +- dhall/tests/Dhall/Test/TH.hs | 68 +++++++++++++++++++++++++++++++++--- 2 files changed, 64 insertions(+), 6 deletions(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index f03f72627..9e5c6f54c 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -264,7 +264,7 @@ toDeclaration globalGenerateOptions haskellTypes typ = MultipleConstructorsWith{..} -> uncurry (fromMulti options typeName) $ getTypeParams code Predefined{} -> return [] Scoped scopedHaskellTypes -> - let haskellTypes' = haskellTypes <> scopedHaskellTypes + let haskellTypes' = scopedHaskellTypes <> haskellTypes in concat <$> traverse (toDeclaration globalGenerateOptions haskellTypes') scopedHaskellTypes where diff --git a/dhall/tests/Dhall/Test/TH.hs b/dhall/tests/Dhall/Test/TH.hs index b61a47e56..c6c548026 100644 --- a/dhall/tests/Dhall/Test/TH.hs +++ b/dhall/tests/Dhall/Test/TH.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,11 +15,14 @@ import Data.Time (TimeOfDay (..), TimeZone (..), fromGregorian) import Dhall.TH (HaskellType (..)) import Test.Tasty (TestTree) +import qualified Data.Map +import qualified Data.Sequence import qualified Data.Text import qualified Dhall import qualified Dhall.TH -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Language.Haskell.TH as TH +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit Dhall.TH.makeHaskellTypeFromUnion "T" "./tests/th/example.dhall" @@ -88,7 +92,7 @@ makeHaskellTypeFromUnion = Tasty.HUnit.testCase "makeHaskellTypeFromUnion" $ do tod = TimeOfDay { todHour = 21, todMin = 12, todSec = 0 } day = fromGregorian 1976 4 1 tz = TimeZone { timeZoneMinutes = 300, timeZoneSummerOnly = False, timeZoneName = "" } - + Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions { Dhall.TH.constructorModifier = ("My" <>) @@ -99,7 +103,7 @@ Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions , SingleConstructor "MyEmployee" "Employee" "./tests/th/Employee.dhall" ] - + deriving instance Eq MyT deriving instance Eq MyDepartment deriving instance Eq MyEmployee @@ -107,7 +111,7 @@ deriving instance Show MyT deriving instance Show MyDepartment deriving instance Show MyEmployee - + Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions { Dhall.TH.constructorModifier = ("My" <>) , Dhall.TH.fieldModifier = ("my" <>) . Data.Text.toTitle @@ -217,3 +221,57 @@ Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions }) [ MultipleConstructors "StrictFields" "./tests/th/example.dhall" ] + +Dhall.TH.makeHaskellTypes + [ let options = Dhall.TH.defaultGenerateOptions + { Dhall.TH.fieldModifier = ("singleConstructorWithTest_" <>) + } + expr = "{ field : Bool }" + in + SingleConstructorWith options "SingleConstructorWithTest" "SingleConstructorWithTest" expr + , let options = Dhall.TH.defaultGenerateOptions + { Dhall.TH.fieldModifier = ("multipleConstructorsWithTest_" <>) + } + expr = "< MultipleConstructorsWithTest1 : { field1 : Bool } | MultipleConstructorsWithTest2 : { field2 : Bool } >" + in + MultipleConstructorsWith options "MultipleConstructorsWithTest" expr + ] + +singleConstructorWithTest :: SingleConstructorWithTest -> Bool +singleConstructorWithTest = singleConstructorWithTest_field + +multipleConstructorsWithTest :: MultipleConstructorsWithTest -> Bool +multipleConstructorsWithTest MultipleConstructorsWithTest1{..} = multipleConstructorsWithTest_field1 +multipleConstructorsWithTest MultipleConstructorsWithTest2{..} = multipleConstructorsWithTest_field2 + +Dhall.TH.makeHaskellTypes + [ Predefined (TH.ConT ''Data.Sequence.Seq `TH.AppT` TH.ConT ''Bool) "List Bool" + , SingleConstructor "PredefinedTest1" "PredefinedTest1" "{ predefinedField1 : List Bool }" + , Predefined (TH.ConT ''Data.Map.Map `TH.AppT` TH.ConT ''Data.Text.Text `TH.AppT` TH.ConT ''Bool) "List { mapKey : Text, mapValue : Bool }" + , SingleConstructor "PredefinedTest2" "PredefinedTest2" "{ predefinedField2 : List { mapKey : Text, mapValue : Bool } }" + ] + +predefinedTest1 :: PredefinedTest1 -> Data.Sequence.Seq Bool +predefinedTest1 (PredefinedTest1 xs) = xs + +predefinedTest2 :: PredefinedTest2 -> Data.Map.Map Data.Text.Text Bool +predefinedTest2 (PredefinedTest2 xs) = xs + +Dhall.TH.makeHaskellTypes + [ SingleConstructor "ScopedTestEmbedded1" "ScopedTestEmbedded1" "{ scopedTestField : Bool }" + , SingleConstructor "ScopedTest1" "ScopedTest1" "{ scopedTestField1 : { scopedTestField : Bool } }" + , Scoped + [ SingleConstructor "ScopedTestEmbedded2" "ScopedTestEmbedded2" "{ scopedTestField : Bool }" + , SingleConstructor "ScopedTest2" "ScopedTest2" "{ scopedTestField2 : { scopedTestField : Bool } }" + ] + , SingleConstructor "ScopedTest3" "ScopedTest3" "{ scopedField3 : { scopedTestField : Bool } }" + ] + +scopedTest1 :: ScopedTest1 -> ScopedTestEmbedded1 +scopedTest1 (ScopedTest1 xs) = xs + +scopedTest2 :: ScopedTest2 -> ScopedTestEmbedded2 +scopedTest2 (ScopedTest2 xs) = xs + +scopedTest3 :: ScopedTest3 -> ScopedTestEmbedded1 +scopedTest3 (ScopedTest3 xs) = xs From f65d339a6c4b3b9e35176c22fab3356c449238d7 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 21 Apr 2023 16:31:56 +0200 Subject: [PATCH 5/7] Fixed: Predefined was not respected in a codepath in toConstructor --- dhall/src/Dhall/TH.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index 9e5c6f54c..d2b7d39d4 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -379,15 +379,17 @@ toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constru case maybeAlternativeType of Just dhallType - | let predicate Scoped{} = False + | let predicate haskellType@Predefined{} = Core.judgmentallyEqual (code haskellType) dhallType + predicate Scoped{} = False predicate haskellType = Core.judgmentallyEqual (code haskellType) dhallType && typeName haskellType /= outerTypeName , Just haskellType <- List.find predicate haskellTypes -> do - let innerName = - Syntax.mkName (Text.unpack (typeName haskellType)) + let inner = case haskellType of + Predefined{..} -> haskellSplice + _ -> ConT (Syntax.mkName (Text.unpack (typeName haskellType))) - return (NormalC name [ (bang, ConT innerName) ]) + return (NormalC name [ (bang, inner) ]) Just (Record kts) -> do let process (key, dhallFieldType) = do From e366f9aea75a17a410b84f5739d379df9ec3c890 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Sun, 24 Sep 2023 00:37:52 +0200 Subject: [PATCH 6/7] Added more documentation for Scoped --- dhall/src/Dhall/TH.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index d2b7d39d4..403ac9635 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -487,6 +487,30 @@ data HaskellType code -- ^ Dhall code that evaluates to a type } -- | Generate some Haskell types within a restricted scope. + -- + -- Suppose generate your types using the following code: + -- + -- > data MyBool = MyFalse | MyTrue + -- > + -- > Dhall.TH.makeHaskellTypes + -- > [ SingleConstructor "ListOfBool" "ListOfBool" "List Bool" + -- > , Scoped + -- > [ Predefined (TH.ConT ''MyBool) "Bool" + -- > , SingleConstructor "ListOfMyBool" "ListOfMyBool" "List Bool" + -- > ] + -- > , SingleConstructor "ListOfBoolAgain" "ListOfBoolAgain" "List Bool" + -- > ] + -- + -- This generates the following Haskell types: + -- + -- > data ListOfBool = ListOfBool Bool + -- > data ListOfMyBool = ListOfMyBool MyBool + -- > data ListOfBoolAgain = ListOfBoolAgain Bool + -- + -- Therefore @Scoped@ allows you to override the type mapping locally. This + -- is especially handy in conjunction with @Predefined@, as it allows you to + -- use different representations of a Dhall type, e.g. a Dhall @List@ can be + -- a Haskell @Vector@, @Seq@ or a good old linked list. | Scoped [HaskellType code] deriving (Functor, Foldable, Traversable) From bc0732dfa57e1b636330143da51eb59d81401b4a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 19 Nov 2024 15:33:11 +0100 Subject: [PATCH 7/7] Dhall.TH: Allow overriding the Haskell type of a particular record field --- dhall/src/Dhall/TH.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index 403ac9635..ebc0ba231 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -393,7 +393,9 @@ toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constru Just (Record kts) -> do let process (key, dhallFieldType) = do - haskellFieldType <- toNestedHaskellType typeParams haskellTypes dhallFieldType + haskellFieldType <- case fieldType key of + Nothing -> toNestedHaskellType typeParams haskellTypes dhallFieldType + Just haskellFieldType -> return haskellFieldType return (Syntax.mkName (Text.unpack $ fieldModifier key), bang, haskellFieldType) @@ -525,6 +527,8 @@ data GenerateOptions = GenerateOptions -- Note: The `constructorName` of `SingleConstructor` will be passed to this function, too. , fieldModifier :: Text -> Text -- ^ How to map a Dhall record field names to a Haskell record field names. + , fieldType :: Text -> Maybe Type + -- ^ Override the Haskell type used for a particular field of a Dhall record. , generateFromDhallInstance :: Bool -- ^ Generate a `FromDhall` instance for the Haskell type , generateToDhallInstance :: Bool @@ -544,6 +548,7 @@ defaultGenerateOptions :: GenerateOptions defaultGenerateOptions = GenerateOptions { constructorModifier = id , fieldModifier = id + , fieldType = const Nothing , generateFromDhallInstance = True , generateToDhallInstance = True , makeStrict = False