Skip to content

Commit

Permalink
Generate Haskell datatype declarations from Dhall types (#1620)
Browse files Browse the repository at this point in the history 
* 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
  • Loading branch information
@Gabriella439 @mergify
Gabriella439 authored and mergify[bot] committed Jan 5, 2020
1 parent 15c1bfb commit b028082
Show file tree
Hide file tree
Showing 10 changed files with 378 additions and 93 deletions.
2 changes: 2 additions & 0 deletions dhall/dhall.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -402,6 +402,7 @@ Extra-Source-Files:
tests/regression/*.dhall
tests/tags/*.dhall
tests/tags/*.tags
tests/th/*.dhall
tests/tutorial/*.dhall

Source-Repository head
Expand Down Expand Up @@ -587,6 +588,7 @@ Test-Suite tasty
Dhall.Test.QuickCheck
Dhall.Test.Regression
Dhall.Test.SemanticHash
Dhall.Test.TH
Dhall.Test.Tutorial
Dhall.Test.TypeInference
Dhall.Test.Util
Expand Down
7 changes: 3 additions & 4 deletions dhall/src/Dhall.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1225,15 +1225,15 @@ instance FromDhall (f (Result f)) => FromDhall (Result f) where
-- > \(Expr : Type)
-- > -> let ExprF =
-- > < LitF :
-- > { _1 : Natural }
-- > Natural
-- > | AddF :
-- > { _1 : Expr, _2 : Expr }
-- > | MulF :
-- > { _1 : Expr, _2 : Expr }
-- > >
-- >
-- > in \(Fix : ExprF -> Expr)
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x })
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x)
-- >
-- > let Add =
-- > \(x : Expr)
Expand Down Expand Up @@ -1291,7 +1291,6 @@ data InterpretOptions = InterpretOptions
-- corresponding Dhall alternative names
, singletonConstructors :: SingletonConstructors
-- ^ Specify how to handle constructors with only one field. The default is
-- `Wrapped` for backwards compatibility but will eventually be changed to
-- `Smart`
, inputNormalizer :: Dhall.Core.ReifiedNormalizer Void
-- ^ This is only used by the `FromDhall` instance for functions in order
Expand Down Expand Up @@ -1334,7 +1333,7 @@ defaultInterpretOptions = InterpretOptions
, constructorModifier =
id
, singletonConstructors =
Wrapped
Smart
, inputNormalizer =
Dhall.Core.ReifiedNormalizer (const (pure Nothing))
}
Expand Down
283 changes: 258 additions & 25 deletions dhall/src/Dhall/TH.hs
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,53 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-| This module provides `staticDhallExpression` which can be used to resolve
all of an expression’s imports at compile time, allowing one to reference
Dhall expressions from Haskell without having a runtime dependency on the
location of Dhall files.
-- | Template Haskell utilities
module Dhall.TH
( -- * Template Haskell
staticDhallExpression
, makeHaskellTypeFromUnion
) where

import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty)
import Dhall.Syntax (Expr(..))
import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility.

import Language.Haskell.TH.Syntax
( Con(..)
, Dec(..)
, Exp(..)
, Q
, Type(..)
#if MIN_VERSION_template_haskell(2,11,0)
, Bang(..)
, SourceStrictness(..)
, SourceUnpackedness(..)
#else
, Strict(..)
#endif
)

import qualified Data.Text as Text
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
import qualified Data.Typeable as Typeable
import qualified Dhall
import qualified Dhall.Map
import qualified Dhall.Pretty
import qualified Dhall.Util
import qualified GHC.IO.Encoding
import qualified Numeric.Natural
import qualified System.IO
import qualified Language.Haskell.TH.Syntax as Syntax

{-| This fully resolves, type checks, and normalizes the expression, so the
resulting AST is self-contained.
This can be used to resolve all of an expression’s imports at compile time,
allowing one to reference Dhall expressions from Haskell without having a
runtime dependency on the location of Dhall files.
For example, given a file @".\/Some\/Type.dhall"@ containing
Expand All @@ -22,28 +66,217 @@
at compile time with all imports resolved, making it easy to keep your Dhall
configs and Haskell interpreters in sync.
-}
module Dhall.TH
( -- * Template Haskell
staticDhallExpression
) where

import Data.Typeable
import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility.
import Language.Haskell.TH.Syntax
staticDhallExpression :: Text -> Q Exp
staticDhallExpression text = do
Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)

import qualified Data.Text as Text
import qualified Dhall
import qualified GHC.IO.Encoding
import qualified System.IO
expression <- Syntax.runIO (Dhall.inputExpr text)

-- | This fully resolves, type checks, and normalizes the expression, so the
-- resulting AST is self-contained.
staticDhallExpression :: Text.Text -> Q Exp
staticDhallExpression text = do
runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)
expression <- runIO (Dhall.inputExpr text)
dataToExpQ (\a -> liftText <$> cast a) expression
dataToExpQ (\a -> liftText <$> Typeable.cast a) expression
where
-- A workaround for a problem in TemplateHaskell (see
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable)
liftText = fmap (AppE (VarE 'Text.pack)) . lift . Text.unpack
liftText = fmap (AppE (VarE 'Text.pack)) . Syntax.lift . Text.unpack

{-| Convert a Dhall type to a Haskell type that does not require any new
data declarations
-}
toSimpleHaskellType :: Pretty a => Expr s a -> Q Type
toSimpleHaskellType dhallType =
case dhallType of
Bool -> do
return (ConT ''Bool)

Double -> do
return (ConT ''Double)

Integer -> do
return (ConT ''Integer)

Natural -> do
return (ConT ''Numeric.Natural.Natural)

Text -> do
return (ConT ''Text)

App List dhallElementType -> do
haskellElementType <- toSimpleHaskellType dhallElementType

return (AppT (ConT ''[]) haskellElementType)

App Optional dhallElementType -> do
haskellElementType <- toSimpleHaskellType dhallElementType

return (AppT (ConT ''Maybe) haskellElementType)

_ -> do
let document =
mconcat
[ "Unsupported simple type\n"
, " \n"
, "Explanation: Not all Dhall alternative types can be converted to Haskell \n"
, "constructor types. Specifically, only the following simple Dhall types are \n"
, "supported as an alternative type or a field of an alternative type: \n"
, " \n"
, "• ❰Bool❱ \n"
, "• ❰Double❱ \n"
, "• ❰Integer❱ \n"
, "• ❰Natural❱ \n"
, "• ❰Text❱ \n"
, "• ❰List a❱ (where ❰a❱ is also a simple type) \n"
, "• ❰Optional a❱ (where ❰a❱ is also a simple type) \n"
, " \n"
, "The Haskell datatype generation logic encountered the following complex \n"
, "Dhall type: \n"
, " \n"
, " " <> Dhall.Util.insert dhallType <> "\n"
, " \n"
, "... where a simpler type was expected."
]

let message = Pretty.renderString (Dhall.Pretty.layout document)

fail message

-- | Convert a Dhall type to the corresponding Haskell constructor type
toConstructor :: Pretty a => (Text, Maybe (Expr s a)) -> Q Con
toConstructor (constructorName, maybeAlternativeType) = do
let name = Syntax.mkName (Text.unpack constructorName)

#if MIN_VERSION_template_haskell(2,11,0)
let bang = Bang NoSourceUnpackedness NoSourceStrictness
#else
let bang = NotStrict
#endif

case maybeAlternativeType of
Just (Record kts) -> do
let process (key, dhallFieldType) = do
haskellFieldType <- toSimpleHaskellType dhallFieldType

return (Syntax.mkName (Text.unpack key), bang, haskellFieldType)

varBangTypes <- traverse process (Dhall.Map.toList kts)

return (RecC name varBangTypes)

Just dhallAlternativeType -> do
haskellAlternativeType <- toSimpleHaskellType dhallAlternativeType

return (NormalC name [ (bang, haskellAlternativeType) ])

Nothing -> do
return (NormalC name [])

-- | Generate a Haskell datatype declaration from a Dhall union type where
-- each union alternative corresponds to a Haskell constructor
--
-- This comes in handy if you need to keep a Dhall type and Haskell type in
-- sync. You make the Dhall type the source of truth and use Template Haskell
-- to generate the matching Haskell type declaration from the Dhall type.
--
-- For example, this Template Haskell splice:
--
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >"
--
-- ... generates this Haskell code:
--
-- > data T = A {x :: GHC.Types.Bool} | B
--
-- If you are starting from an existing record type that you want to convert to
-- a Haskell type, wrap the record type in a union with one alternative, like
-- this:
--
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : ./recordType.dhall >"
--
-- To add any desired instances (such as `Dhall.FromDhall`/`Dhall.ToDhall`),
-- you can use the `StandaloneDeriving` language extension, like this:
--
-- > {-# LANGUAGE DeriveAnyClass #-}
-- > {-# LANGUAGE DeriveGeneric #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE StandaloneDeriving #-}
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >"
-- >
-- > deriving instance Generic T
-- > deriving instance FromDhall T
makeHaskellTypeFromUnion
:: Text
-- ^ Name of the generated Haskell type
-> Text
-- ^ Dhall code that evaluates to a union type
-> Q [Dec]
makeHaskellTypeFromUnion typeName text = do
Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8)

expression <- Syntax.runIO (Dhall.inputExpr text)

case expression of
Union kts -> do
let name = Syntax.mkName (Text.unpack typeName)

constructors <- traverse toConstructor (Dhall.Map.toList kts )

let declaration = DataD [] name []
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#else
#endif
constructors []

return [ declaration ]

_ -> do
let document =
mconcat
[ "Dhall.TH.makeHaskellTypeFromUnion: Unsupported Dhall type\n"
, " \n"
, "Explanation: This function only coverts Dhall union types to Haskell datatype \n"
, "declarations. \n"
, " \n"
, "For example, this is a valid Dhall union type that this function would accept: \n"
, " \n"
, " \n"
, " ┌──────────────────────────────────────────────────────────────────┐ \n"
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : { x : Bool } | B >\" │ \n"
, " └──────────────────────────────────────────────────────────────────┘ \n"
, " \n"
, " \n"
, "... which corresponds to this Haskell type declaration: \n"
, " \n"
, " \n"
, " ┌──────────────────────────────────────┐ \n"
, " │ data T = A {x :: GHC.Types.Bool} | B │ \n"
, " └──────────────────────────────────────┘ \n"
, " \n"
, " \n"
, "... but the following Dhall type is rejected due to being a bare record type: \n"
, " \n"
, " \n"
, " ┌──────────────────────────────────────────────────────┐ \n"
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"{ x : Bool }\" │ Not valid \n"
, " └──────────────────────────────────────────────────────┘ \n"
, " \n"
, " \n"
, "If you are starting from a file containing only a record type and you want to \n"
, "generate a Haskell type from that, then wrap the record type in a union with one\n"
, "alternative, like this: \n"
, " \n"
, " \n"
, " ┌──────────────────────────────────────────────────────────────────┐ \n"
, " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : ./recordType.dhall >\" │ \n"
, " └──────────────────────────────────────────────────────────────────┘ \n"

This comment has been minimized.

Sign in to view

Copy link
@Profpatsch

Profpatsch Jan 14, 2020

Member

Love this guide message.
, " \n"
, " \n"
, "The Haskell datatype generation logic encountered the following Dhall type: \n"
, " \n"
, " " <> Dhall.Util.insert expression <> "\n"
, " \n"
, "... which is not a union type."
]

let message = Pretty.renderString (Dhall.Pretty.layout document)

fail message
Loading

0 comments on commit b028082

Please sign in to comment.