diff --git a/dhall/src/Dhall/Marshal/Decode.hs b/dhall/src/Dhall/Marshal/Decode.hs index 1e0fdbed2..cf6b65283 100644 --- a/dhall/src/Dhall/Marshal/Decode.hs +++ b/dhall/src/Dhall/Marshal/Decode.hs @@ -93,6 +93,7 @@ module Dhall.Marshal.Decode , GenericFromDhallUnion(..) , genericAuto , genericAutoWith + , genericAutoWithInputNormalizer -- * Decoding errors , DhallErrors(..) @@ -224,8 +225,8 @@ fromList [("a",False),("b",True)] implement `Generic`. This does not auto-generate an instance for recursive types. - The default instance can be tweaked using 'genericAutoWith' and custom - 'InterpretOptions', or using + The default instance can be tweaked using 'genericAutoWith'/'genericAutoWithInputNormalizer' + and custom 'InterpretOptions', or using [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} @@ -699,7 +700,13 @@ genericAuto = genericAutoWith defaultInterpretOptions {-| `genericAutoWith` is a configurable version of `genericAuto`. -} genericAutoWith :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> Decoder a -genericAutoWith options = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p defaultInputNormalizer options) 1)) +genericAutoWith options = genericAutoWithInputNormalizer options defaultInputNormalizer + +{-| `genericAutoWithInputNormalizer` is like `genericAutoWith`, but instead of + using the `defaultInputNormalizer` it expects an custom `InputNormalizer`. +-} +genericAutoWithInputNormalizer :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> InputNormalizer -> Decoder a +genericAutoWithInputNormalizer options inputNormalizer = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p inputNormalizer options) 1)) where withProxy :: (Proxy a -> Decoder a) -> Decoder a withProxy f = f Proxy diff --git a/dhall/src/Dhall/Marshal/Encode.hs b/dhall/src/Dhall/Marshal/Encode.hs index 5223ef763..07f303c4e 100644 --- a/dhall/src/Dhall/Marshal/Encode.hs +++ b/dhall/src/Dhall/Marshal/Encode.hs @@ -41,6 +41,7 @@ module Dhall.Marshal.Encode , GenericToDhall(..) , genericToDhall , genericToDhallWith + , genericToDhallWithInputNormalizer , InterpretOptions(..) , SingletonConstructors(..) , defaultInterpretOptions @@ -127,8 +128,8 @@ instance Contravariant Encoder where implement `Generic`. This does not auto-generate an instance for recursive types. - The default instance can be tweaked using 'genericToDhallWith' and custom - 'InterpretOptions', or using + The default instance can be tweaked using 'genericToDhallWith'/'genericToDhallWithInputNormalizer' + and custom 'InterpretOptions', or using [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} @@ -745,8 +746,16 @@ want to define orphan instances for. -} genericToDhallWith :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a -genericToDhallWith options - = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer defaultInputNormalizer options) 1) +genericToDhallWith options = genericToDhallWithInputNormalizer options defaultInputNormalizer + +{-| `genericToDhallWithInputNormalizer` is like `genericToDhallWith`, but + instead of using the `defaultInputNormalizer` it expects an custom + `InputNormalizer`. +-} +genericToDhallWithInputNormalizer + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputNormalizer -> Encoder a +genericToDhallWithInputNormalizer options inputNormalizer + = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer inputNormalizer options) 1) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index caf0ca37d..cd265d9b1 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -6,12 +6,16 @@ -- | Template Haskell utilities module Dhall.TH - ( -- * Template Haskell + ( -- * Embedding Dhall in Haskell staticDhallExpression , dhall + -- * Generating Haskell from Dhall expressions , makeHaskellTypeFromUnion , makeHaskellTypes + , makeHaskellTypesWith , HaskellType(..) + , GenerateOptions(..) + , defaultGenerateOptions ) where import Data.Text (Text) @@ -23,9 +27,12 @@ import Prettyprinter (Pretty) import Language.Haskell.TH.Syntax ( Bang (..) + , Body (..) , Con (..) , Dec (..) , Exp (..) + , Match (..) + , Pat (..) , Q , SourceStrictness (..) , SourceUnpackedness (..) @@ -35,6 +42,7 @@ import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax (DerivClause (..), DerivStrategy (..)) import qualified Data.List as List +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Typeable as Typeable import qualified Dhall @@ -179,26 +187,53 @@ toNestedHaskellType haskellTypes = loop predicate haskellType = Core.judgmentallyEqual (code haskellType) dhallType -derivingClauses :: [DerivClause] -derivingClauses = - [ DerivClause (Just StockStrategy) [ ConT ''Generic ] - , DerivClause (Just AnyclassStrategy) [ ConT ''FromDhall, ConT ''ToDhall ] - ] +-- | A deriving clause for `Generic`. +derivingGenericClause :: DerivClause +derivingGenericClause = DerivClause (Just StockStrategy) [ ConT ''Generic ] + +-- | Generates a `FromDhall` instances. +fromDhallInstance + :: Syntax.Name -- ^ The name of the type the instances is for + -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` + -> Q [Dec] +fromDhallInstance n interpretOptions = [d| + instance FromDhall $(pure $ ConT n) where + autoWith = Dhall.genericAutoWithInputNormalizer $(interpretOptions) + |] + +-- | Generates a `ToDhall` instances. +toDhallInstance + :: Syntax.Name -- ^ The name of the type the instances is for + -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` + -> Q [Dec] +toDhallInstance n interpretOptions = [d| + instance ToDhall $(pure $ ConT n) where + injectWith = Dhall.genericToDhallWithInputNormalizer $(interpretOptions) + |] -- | Convert a Dhall type to the corresponding Haskell datatype declaration toDeclaration :: (Eq a, Pretty a) - => [HaskellType (Expr s a)] + => GenerateOptions + -> [HaskellType (Expr s a)] -> HaskellType (Expr s a) - -> Q Dec -toDeclaration haskellTypes MultipleConstructors{..} = + -> Q [Dec] +toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ@MultipleConstructors{..} = case code of Union kts -> do let name = Syntax.mkName (Text.unpack typeName) - constructors <- traverse (toConstructor haskellTypes typeName) (Dhall.Map.toList kts ) + let derivingClauses = + [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] - return (DataD [] name [] Nothing constructors derivingClauses) + constructors <- traverse (toConstructor generateOptions haskellTypes typeName) (Dhall.Map.toList kts) + + let interpretOptions = generateToInterpretOptions generateOptions typ + + fmap concat . sequence $ + [pure [DataD [] name [] Nothing constructors derivingClauses]] <> + [ fromDhallInstance name interpretOptions | generateFromDhallInstance ] <> + [ toDhallInstance name interpretOptions | generateToDhallInstance ] _ -> do let document = @@ -242,24 +277,33 @@ toDeclaration haskellTypes MultipleConstructors{..} = let message = Pretty.renderString (Dhall.Pretty.layout document) fail message -toDeclaration haskellTypes SingleConstructor{..} = do +toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ@SingleConstructor{..} = do let name = Syntax.mkName (Text.unpack typeName) - constructor <- toConstructor haskellTypes typeName (constructorName, Just code) + let derivingClauses = + [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] + + let interpretOptions = generateToInterpretOptions generateOptions typ - return (DataD [] name [] Nothing [constructor] derivingClauses) + constructor <- toConstructor generateOptions haskellTypes typeName (constructorName, Just code) + + fmap concat . sequence $ + [pure [DataD [] name [] Nothing [constructor] derivingClauses]] <> + [ fromDhallInstance name interpretOptions | generateFromDhallInstance ] <> + [ toDhallInstance name interpretOptions | generateToDhallInstance ] -- | Convert a Dhall type to the corresponding Haskell constructor toConstructor :: (Eq a, Pretty a) - => [HaskellType (Expr s a)] + => GenerateOptions + -> [HaskellType (Expr s a)] -> Text -- ^ typeName -> (Text, Maybe (Expr s a)) -- ^ @(constructorName, fieldType)@ -> Q Con -toConstructor haskellTypes outerTypeName (constructorName, maybeAlternativeType) = do - let name = Syntax.mkName (Text.unpack constructorName) +toConstructor GenerateOptions{..} haskellTypes outerTypeName (constructorName, maybeAlternativeType) = do + let name = Syntax.mkName (Text.unpack $ constructorModifier constructorName) let bang = Bang NoSourceUnpackedness NoSourceStrictness @@ -278,7 +322,7 @@ toConstructor haskellTypes outerTypeName (constructorName, maybeAlternativeType) let process (key, dhallFieldType) = do haskellFieldType <- toNestedHaskellType haskellTypes dhallFieldType - return (Syntax.mkName (Text.unpack key), bang, haskellFieldType) + return (Syntax.mkName (Text.unpack $ fieldModifier key), bang, haskellFieldType) varBangTypes <- traverse process (Dhall.Map.toList $ Core.recordFieldValue <$> kts) @@ -316,17 +360,18 @@ makeHaskellTypeFromUnion makeHaskellTypeFromUnion typeName code = makeHaskellTypes [ MultipleConstructors{..} ] --- | Used by `makeHaskellTypes` to specify how to generate Haskell types +-- | Used by `makeHaskellTypes` and `makeHaskellTypesWith` to specify how to +-- generate Haskell types. data HaskellType code -- | Generate a Haskell type with more than one constructor from a Dhall - -- union type + -- union type. = MultipleConstructors { 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 + -- | 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. @@ -340,8 +385,82 @@ data HaskellType code } deriving (Functor, Foldable, Traversable) +-- | This data type holds various options that let you control several aspects +-- how Haskell code is generated. In particular you can +-- +-- * disable the generation of `FromDhall`/`ToDhall` instances. +-- * modify how a Dhall union field translates to a Haskell data constructor. +data GenerateOptions = GenerateOptions + { constructorModifier :: Text -> Text + -- ^ How to map a Dhall union field name to a Haskell constructor. + -- 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. + , generateFromDhallInstance :: Bool + -- ^ Generate a `FromDhall` instance for the Haskell type + , generateToDhallInstance :: Bool + -- ^ Generate a `ToDhall` instance for the Haskell type + } + +-- | A default set of options used by `makeHaskellTypes`. That means: +-- +-- * Constructors and fields are passed unmodified. +-- * Both `FromDhall` and `ToDhall` instances are generated. +defaultGenerateOptions :: GenerateOptions +defaultGenerateOptions = GenerateOptions + { constructorModifier = id + , fieldModifier = id + , generateFromDhallInstance = True + , generateToDhallInstance = True + } + +-- | This function generates `Dhall.InterpretOptions` that can be used for the +-- marshalling of the Haskell type generated according to the `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 GenerateOptions{..} haskellType = [| Dhall.InterpretOptions + { Dhall.fieldModifier = \ $(pure nameP) -> + $(toCases fieldModifier $ fields haskellType) + , Dhall.constructorModifier = \ $(pure nameP) -> + $(toCases constructorModifier $ constructors haskellType) + , Dhall.singletonConstructors = Dhall.singletonConstructors Dhall.defaultInterpretOptions + }|] + where + constructors :: HaskellType (Expr s a) -> [Text] + constructors SingleConstructor{..} = [constructorName] + constructors MultipleConstructors{..} | Union kts <- code = Dhall.Map.keys kts + constructors _ = [] + + fields :: HaskellType (Expr s a) -> [Text] + fields SingleConstructor{..} | Record kts <- code = Dhall.Map.keys kts + fields MultipleConstructors{..} | Union kts <- code = Set.toList $ mconcat + [ Dhall.Map.keysSet kts' + | (_, Just (Record kts')) <- Dhall.Map.toList kts + ] + fields _ = [] + + toCases :: (Text -> Text) -> [Text] -> Q Exp + toCases f xs = do + err <- [| Core.internalError $ "Unmatched " <> Text.pack (show $(pure nameE)) |] + pure $ CaseE nameE $ map mkMatch xs <> [Match WildP (NormalB err) []] + where + mkMatch n = Match (textToPat $ f n) (NormalB $ textToExp n) [] + + nameE :: Exp + nameE = Syntax.VarE $ Syntax.mkName "n" + + nameP :: Pat + nameP = Syntax.VarP $ Syntax.mkName "n" + + textToExp :: Text -> Exp + textToExp = Syntax.LitE . Syntax.StringL . Text.unpack + + textToPat :: Text -> Pat + textToPat = Syntax.LitP . Syntax.StringL . Text.unpack + -- | Generate a Haskell datatype declaration with one constructor from a Dhall --- type +-- type. -- -- This comes in handy if you need to keep Dhall types and Haskell types in -- sync. You make the Dhall types the source of truth and use Template Haskell @@ -416,9 +535,18 @@ data HaskellType code -- > deriving instance Ord Employee -- > deriving instance Show Employee makeHaskellTypes :: [HaskellType Text] -> Q [Dec] -makeHaskellTypes haskellTypes = do +makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions + +-- | Like `makeHaskellTypes`, but with the ability to customize the generated +-- Haskell code by passing `GenerateOptions`. +-- +-- For instance, `makeHaskellTypes` is implemented using this function: +-- +-- > makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions +makeHaskellTypesWith :: GenerateOptions -> [HaskellType Text] -> Q [Dec] +makeHaskellTypesWith generateOptions haskellTypes = do Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) haskellTypes' <- traverse (traverse (Syntax.runIO . Dhall.inputExpr)) haskellTypes - traverse (toDeclaration haskellTypes') haskellTypes' + concat <$> traverse (toDeclaration generateOptions haskellTypes') haskellTypes' diff --git a/dhall/tests/Dhall/Test/TH.hs b/dhall/tests/Dhall/Test/TH.hs index 7ef45d621..0824a6bfc 100644 --- a/dhall/tests/Dhall/Test/TH.hs +++ b/dhall/tests/Dhall/Test/TH.hs @@ -7,9 +7,12 @@ module Dhall.Test.TH where +import Control.Exception (throwIO) +import Data.Either.Validation (Validation(..)) import Dhall.TH (HaskellType (..)) import Test.Tasty (TestTree) +import qualified Data.Text import qualified Dhall import qualified Dhall.TH import qualified Test.Tasty as Tasty @@ -70,3 +73,83 @@ makeHaskellTypeFromUnion = Tasty.HUnit.testCase "makeHaskellTypeFromUnion" $ do qux <- Dhall.input Dhall.auto "let T = ./tests/th/issue2066.dhall in T.Qux.Foo { foo = +2, bar = { baz = +3 } }" Tasty.HUnit.assertEqual "" qux (Foo MakeFoo{ foo = 2, bar = MakeBar{ baz = 3 } }) + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("My" <>) + , Dhall.TH.fieldModifier = ("my" <>) . Data.Text.toTitle + }) + [ MultipleConstructors "MyT" "./tests/th/example.dhall" + , MultipleConstructors "MyDepartment" "./tests/th/Department.dhall" + , SingleConstructor "MyEmployee" "Employee" "./tests/th/Employee.dhall" + ] + +deriving instance Eq MyT +deriving instance Eq MyDepartment +deriving instance Eq MyEmployee +deriving instance Show MyT +deriving instance Show MyDepartment +deriving instance Show MyEmployee + +testMakeHaskellTypesWith :: TestTree +testMakeHaskellTypesWith = Tasty.HUnit.testCase "makeHaskellTypesWith" $ do + let text0 = "let T = ./tests/th/example.dhall in T.A { x = True, y = [] : List Text }" + ref0 = MyA{ myX = True, myY = [] } + myTest text0 ref0 + + let text1 = "let T = ./tests/th/example.dhall in T.B (None (List Natural))" + ref1 = MyB Nothing + myTest text1 ref1 + + let text2 = "let T = ./tests/th/example.dhall in T.C" + ref2 = MyC + myTest text2 ref2 + + let textDepartment = "let T = ./tests/th/Department.dhall in T.Sales" + refDepartment = MySales + myTest textDepartment refDepartment + + let textEmployee = "let T = ./tests/th/Department.dhall in T.Sales" + refEmployee = MyEmployee{ myName = "", myDepartment = MySales } + myTest textEmployee refEmployee + where + myTest text ref = do + expr <- Dhall.inputExpr text + t <- case Dhall.extract Dhall.auto expr of + Failure e -> throwIO e + Success t -> return t + + Tasty.HUnit.assertEqual "" t ref + Tasty.HUnit.assertEqual "" expr $ Dhall.embed Dhall.inject ref + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoFromDhall" <>) + , Dhall.TH.fieldModifier = ("noFromDhall" <>) . Data.Text.toTitle + , Dhall.TH.generateFromDhallInstance = False + }) + [ MultipleConstructors "NoFromDhallT" "./tests/th/example.dhall" + ] + +instance Dhall.FromDhall NoFromDhallT + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoToDhall" <>) + , Dhall.TH.fieldModifier = ("noToDhall" <>) . Data.Text.toTitle + , Dhall.TH.generateToDhallInstance = False + }) + [ MultipleConstructors "NoToDhallT" "./tests/th/example.dhall" + ] + +instance Dhall.ToDhall NoToDhallT + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoInstances" <>) + , Dhall.TH.fieldModifier = ("noInstances" <>) . Data.Text.toTitle + , Dhall.TH.generateFromDhallInstance = False + , Dhall.TH.generateToDhallInstance = False + }) + [ MultipleConstructors "NoInstancesT" "./tests/th/example.dhall" + ] + +deriving instance Dhall.Generic NoInstancesT +instance Dhall.FromDhall NoInstancesT +instance Dhall.ToDhall NoInstancesT