Skip to content

Commit b028082

Browse files
Gabriella439mergify[bot]
Gabriella439
authored and
mergify[bot]
committed
Generate Haskell datatype declarations from Dhall types (#1620)
* Generate Haskell datatype declarations from Dhall types Fixes #1616 This adds a new `Dhall.TH.makeHaskellType` utility which generates a Haskell datatype declaration corresponding to a Dhall type. This simplifies keeping Haskell and Dhall code in sync with one another. * Fix build for GHC 7.10.3 * Fix `nix-shell` for GHC 7.10.3 * Rename `makeHaskellType` to `makeHaskellTypeFromUnion` ... based on a suggestion from @sjakobi * Change `Smart` to be the default ... as suggested by @sjakobi
1 parent 15c1bfb commit b028082

File tree

10 files changed

+378
-93
lines changed

10 files changed

+378
-93
lines changed

‎dhall/dhall.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -402,6 +402,7 @@ Extra-Source-Files:
402402
tests/regression/*.dhall
403403
tests/tags/*.dhall
404404
tests/tags/*.tags
405+
tests/th/*.dhall
405406
tests/tutorial/*.dhall
406407

407408
Source-Repository head
@@ -587,6 +588,7 @@ Test-Suite tasty
587588
Dhall.Test.QuickCheck
588589
Dhall.Test.Regression
589590
Dhall.Test.SemanticHash
591+
Dhall.Test.TH
590592
Dhall.Test.Tutorial
591593
Dhall.Test.TypeInference
592594
Dhall.Test.Util

‎dhall/src/Dhall.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1225,15 +1225,15 @@ instance FromDhall (f (Result f)) => FromDhall (Result f) where
12251225
-- > \(Expr : Type)
12261226
-- > -> let ExprF =
12271227
-- > < LitF :
1228-
-- > { _1 : Natural }
1228+
-- > Natural
12291229
-- > | AddF :
12301230
-- > { _1 : Expr, _2 : Expr }
12311231
-- > | MulF :
12321232
-- > { _1 : Expr, _2 : Expr }
12331233
-- > >
12341234
-- >
12351235
-- > in \(Fix : ExprF -> Expr)
1236-
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x })
1236+
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x)
12371237
-- >
12381238
-- > let Add =
12391239
-- > \(x : Expr)
@@ -1291,7 +1291,6 @@ data InterpretOptions = InterpretOptions
12911291
-- corresponding Dhall alternative names
12921292
, singletonConstructors :: SingletonConstructors
12931293
-- ^ Specify how to handle constructors with only one field. The default is
1294-
-- `Wrapped` for backwards compatibility but will eventually be changed to
12951294
-- `Smart`
12961295
, inputNormalizer :: Dhall.Core.ReifiedNormalizer Void
12971296
-- ^ This is only used by the `FromDhall` instance for functions in order
@@ -1334,7 +1333,7 @@ defaultInterpretOptions = InterpretOptions
13341333
, constructorModifier =
13351334
id
13361335
, singletonConstructors =
1337-
Wrapped
1336+
Smart
13381337
, inputNormalizer =
13391338
Dhall.Core.ReifiedNormalizer (const (pure Nothing))
13401339
}

‎dhall/src/Dhall/TH.hs

Lines changed: 258 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,53 @@
1-
{-# LANGUAGE TemplateHaskell #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE TemplateHaskell #-}
24

3-
{-| This module provides `staticDhallExpression` which can be used to resolve
4-
all of an expression’s imports at compile time, allowing one to reference
5-
Dhall expressions from Haskell without having a runtime dependency on the
6-
location of Dhall files.
5+
-- | Template Haskell utilities
6+
module Dhall.TH
7+
( -- * Template Haskell
8+
staticDhallExpression
9+
, makeHaskellTypeFromUnion
10+
) where
11+
12+
import Data.Monoid ((<>))
13+
import Data.Text (Text)
14+
import Data.Text.Prettyprint.Doc (Pretty)
15+
import Dhall.Syntax (Expr(..))
16+
import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility.
17+
18+
import Language.Haskell.TH.Syntax
19+
( Con(..)
20+
, Dec(..)
21+
, Exp(..)
22+
, Q
23+
, Type(..)
24+
#if MIN_VERSION_template_haskell(2,11,0)
25+
, Bang(..)
26+
, SourceStrictness(..)
27+
, SourceUnpackedness(..)
28+
#else
29+
, Strict(..)
30+
#endif
31+
)
32+
33+
import qualified Data.Text as Text
34+
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
35+
import qualified Data.Typeable as Typeable
36+
import qualified Dhall
37+
import qualified Dhall.Map
38+
import qualified Dhall.Pretty
39+
import qualified Dhall.Util
40+
import qualified GHC.IO.Encoding
41+
import qualified Numeric.Natural
42+
import qualified System.IO
43+
import qualified Language.Haskell.TH.Syntax as Syntax
44+
45+
{-| This fully resolves, type checks, and normalizes the expression, so the
46+
resulting AST is self-contained.
47+
48+
This can be used to resolve all of an expression’s imports at compile time,
49+
allowing one to reference Dhall expressions from Haskell without having a
50+
runtime dependency on the location of Dhall files.
751
852
For example, given a file @".\/Some\/Type.dhall"@ containing
953
@@ -22,28 +66,217 @@
2266
at compile time with all imports resolved, making it easy to keep your Dhall
2367
configs and Haskell interpreters in sync.
2468
-}
25-
module Dhall.TH
26-
( -- * Template Haskell
27-
staticDhallExpression
28-
) where
29-
30-
import Data.Typeable
31-
import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility.
32-
import Language.Haskell.TH.Syntax
69+
staticDhallExpression :: Text -> Q Exp
70+
staticDhallExpression text = do
71+
Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)
3372

34-
import qualified Data.Text as Text
35-
import qualified Dhall
36-
import qualified GHC.IO.Encoding
37-
import qualified System.IO
73+
expression <- Syntax.runIO (Dhall.inputExpr text)
3874

39-
-- | This fully resolves, type checks, and normalizes the expression, so the
40-
-- resulting AST is self-contained.
41-
staticDhallExpression :: Text.Text -> Q Exp
42-
staticDhallExpression text = do
43-
runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)
44-
expression <- runIO (Dhall.inputExpr text)
45-
dataToExpQ (\a -> liftText <$> cast a) expression
75+
dataToExpQ (\a -> liftText <$> Typeable.cast a) expression
4676
where
4777
-- A workaround for a problem in TemplateHaskell (see
4878
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable)
49-
liftText = fmap (AppE (VarE 'Text.pack)) . lift . Text.unpack
79+
liftText = fmap (AppE (VarE 'Text.pack)) . Syntax.lift . Text.unpack
80+
81+
{-| Convert a Dhall type to a Haskell type that does not require any new
82+
data declarations
83+
-}
84+
toSimpleHaskellType :: Pretty a => Expr s a -> Q Type
85+
toSimpleHaskellType dhallType =
86+
case dhallType of
87+
Bool -> do
88+
return (ConT ''Bool)
89+
90+
Double -> do
91+
return (ConT ''Double)
92+
93+
Integer -> do
94+
return (ConT ''Integer)
95+
96+
Natural -> do
97+
return (ConT ''Numeric.Natural.Natural)
98+
99+
Text -> do
100+
return (ConT ''Text)
101+
102+
App List dhallElementType -> do
103+
haskellElementType <- toSimpleHaskellType dhallElementType
104+
105+
return (AppT (ConT ''[]) haskellElementType)
106+
107+
App Optional dhallElementType -> do
108+
haskellElementType <- toSimpleHaskellType dhallElementType
109+
110+
return (AppT (ConT ''Maybe) haskellElementType)
111+
112+
_ -> do
113+
let document =
114+
mconcat
115+
[ "Unsupported simple type\n"
116+
, " \n"
117+
, "Explanation: Not all Dhall alternative types can be converted to Haskell \n"
118+
, "constructor types. Specifically, only the following simple Dhall types are \n"
119+
, "supported as an alternative type or a field of an alternative type: \n"
120+
, " \n"
121+
, "• ❰Bool❱ \n"
122+
, "• ❰Double❱ \n"
123+
, "• ❰Integer❱ \n"
124+
, "• ❰Natural❱ \n"
125+
, "• ❰Text❱ \n"
126+
, "• ❰List a❱ (where ❰a❱ is also a simple type) \n"
127+
, "• ❰Optional a❱ (where ❰a❱ is also a simple type) \n"
128+
, " \n"
129+
, "The Haskell datatype generation logic encountered the following complex \n"
130+
, "Dhall type: \n"
131+
, " \n"
132+
, " " <> Dhall.Util.insert dhallType <> "\n"
133+
, " \n"
134+
, "... where a simpler type was expected."
135+
]
136+
137+
let message = Pretty.renderString (Dhall.Pretty.layout document)
138+
139+
fail message
140+
141+
-- | Convert a Dhall type to the corresponding Haskell constructor type
142+
toConstructor :: Pretty a => (Text, Maybe (Expr s a)) -> Q Con
143+
toConstructor (constructorName, maybeAlternativeType) = do
144+
let name = Syntax.mkName (Text.unpack constructorName)
145+
146+
#if MIN_VERSION_template_haskell(2,11,0)
147+
let bang = Bang NoSourceUnpackedness NoSourceStrictness
148+
#else
149+
let bang = NotStrict
150+
#endif
151+
152+
case maybeAlternativeType of
153+
Just (Record kts) -> do
154+
let process (key, dhallFieldType) = do
155+
haskellFieldType <- toSimpleHaskellType dhallFieldType
156+
157+
return (Syntax.mkName (Text.unpack key), bang, haskellFieldType)
158+
159+
varBangTypes <- traverse process (Dhall.Map.toList kts)
160+
161+
return (RecC name varBangTypes)
162+
163+
Just dhallAlternativeType -> do
164+
haskellAlternativeType <- toSimpleHaskellType dhallAlternativeType
165+
166+
return (NormalC name [ (bang, haskellAlternativeType) ])
167+
168+
Nothing -> do
169+
return (NormalC name [])
170+
171+
-- | Generate a Haskell datatype declaration from a Dhall union type where
172+
-- each union alternative corresponds to a Haskell constructor
173+
--
174+
-- This comes in handy if you need to keep a Dhall type and Haskell type in
175+
-- sync. You make the Dhall type the source of truth and use Template Haskell
176+
-- to generate the matching Haskell type declaration from the Dhall type.
177+
--
178+
-- For example, this Template Haskell splice:
179+
--
180+
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >"
181+
--
182+
-- ... generates this Haskell code:
183+
--
184+
-- > data T = A {x :: GHC.Types.Bool} | B
185+
--
186+
-- If you are starting from an existing record type that you want to convert to
187+
-- a Haskell type, wrap the record type in a union with one alternative, like
188+
-- this:
189+
--
190+
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : ./recordType.dhall >"
191+
--
192+
-- To add any desired instances (such as `Dhall.FromDhall`/`Dhall.ToDhall`),
193+
-- you can use the `StandaloneDeriving` language extension, like this:
194+
--
195+
-- > {-# LANGUAGE DeriveAnyClass #-}
196+
-- > {-# LANGUAGE DeriveGeneric #-}
197+
-- > {-# LANGUAGE OverloadedStrings #-}
198+
-- > {-# LANGUAGE StandaloneDeriving #-}
199+
-- > {-# LANGUAGE TemplateHaskell #-}
200+
-- >
201+
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >"
202+
-- >
203+
-- > deriving instance Generic T
204+
-- > deriving instance FromDhall T
205+
makeHaskellTypeFromUnion
206+
:: Text
207+
-- ^ Name of the generated Haskell type
208+
-> Text
209+
-- ^ Dhall code that evaluates to a union type
210+
-> Q [Dec]
211+
makeHaskellTypeFromUnion typeName text = do
212+
Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)
213+
214+
expression <- Syntax.runIO (Dhall.inputExpr text)
215+
216+
case expression of
217+
Union kts -> do
218+
let name = Syntax.mkName (Text.unpack typeName)
219+
220+
constructors <- traverse toConstructor (Dhall.Map.toList kts )
221+
222+
let declaration = DataD [] name []
223+
#if MIN_VERSION_template_haskell(2,11,0)
224+
Nothing
225+
#else
226+
#endif
227+
constructors []
228+
229+
return [ declaration ]
230+
231+
_ -> do
232+
let document =
233+
mconcat
234+
[ "Dhall.TH.makeHaskellTypeFromUnion: Unsupported Dhall type\n"
235+
, " \n"
236+
, "Explanation: This function only coverts Dhall union types to Haskell datatype \n"
237+
, "declarations. \n"
238+
, " \n"
239+
, "For example, this is a valid Dhall union type that this function would accept: \n"
240+
, " \n"
241+
, " \n"
242+
, " ┌──────────────────────────────────────────────────────────────────┐ \n"
243+
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : { x : Bool } | B >\" │ \n"
244+
, " └──────────────────────────────────────────────────────────────────┘ \n"
245+
, " \n"
246+
, " \n"
247+
, "... which corresponds to this Haskell type declaration: \n"
248+
, " \n"
249+
, " \n"
250+
, " ┌──────────────────────────────────────┐ \n"
251+
, " │ data T = A {x :: GHC.Types.Bool} | B │ \n"
252+
, " └──────────────────────────────────────┘ \n"
253+
, " \n"
254+
, " \n"
255+
, "... but the following Dhall type is rejected due to being a bare record type: \n"
256+
, " \n"
257+
, " \n"
258+
, " ┌──────────────────────────────────────────────────────┐ \n"
259+
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"{ x : Bool }\" │ Not valid \n"
260+
, " └──────────────────────────────────────────────────────┘ \n"
261+
, " \n"
262+
, " \n"
263+
, "If you are starting from a file containing only a record type and you want to \n"
264+
, "generate a Haskell type from that, then wrap the record type in a union with one\n"
265+
, "alternative, like this: \n"
266+
, " \n"
267+
, " \n"
268+
, " ┌──────────────────────────────────────────────────────────────────┐ \n"
269+
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : ./recordType.dhall >\" │ \n"
270+
, " └──────────────────────────────────────────────────────────────────┘ \n"
271+
, " \n"
272+
, " \n"
273+
, "The Haskell datatype generation logic encountered the following Dhall type: \n"
274+
, " \n"
275+
, " " <> Dhall.Util.insert expression <> "\n"
276+
, " \n"
277+
, "... which is not a union type."
278+
]
279+
280+
let message = Pretty.renderString (Dhall.Pretty.layout document)
281+
282+
fail message

0 commit comments

Comments
 (0)