Added SingleConstructorWith and MultipleConstructorsWith to Dhall.TH

Author: mmhat

dhall/src/Dhall/TH.hs

@@ -61,7 +61,7 @@ import qualified Numeric.Natural
 import qualified Prettyprinter.Render.String as Pretty
 import qualified System.IO
 
-  
+
 {-| This fully resolves, type checks, and normalizes the expression, so the
     resulting AST is self-contained.
 
@@ -161,9 +161,9 @@ toNestedHaskellType typeParams haskellTypes = loop
       , "                                                                                \n"
       , "... which did not fit any of the above criteria."
       ]
-  
+
     message dhallType = Pretty.renderString (Dhall.Pretty.layout (document dhallType))
-  
+
     loop dhallType = case dhallType of
         Bool ->
             return (ConT ''Bool)
@@ -204,7 +204,7 @@ toNestedHaskellType typeParams haskellTypes = loop
             haskellElementType <- loop dhallElementType
 
             return (AppT haskellAppType haskellElementType)
-          
+
         Var v
             | Just (V param index) <- List.find (v ==) typeParams -> do
                 let name = Syntax.mkName $ (Text.unpack param) ++ (show index)
@@ -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,28 +270,32 @@ 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]
-    
-        fromMulti typeName typeParams dhallType = case dhallType of
+
+            toDataD generateOptions typeName typeParams [constructor]
+
+        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
-    
-            _ -> fail $ message dhallType 
+                toDataD generateOptions typeName typeParams constructors
+
+            _ -> fail $ message dhallType
 
         message dhallType = Pretty.renderString (Dhall.Pretty.layout $ document 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