{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}

-- | Template Haskell utilities
module Dhall.TH
    ( -- * Embedding Dhall in Haskell
      staticDhallExpression
    , dhall
      -- * Generating Haskell from Dhall expressions
    , makeHaskellTypeFromUnion
    , makeHaskellTypes
    , makeHaskellTypesWith
    , HaskellType(..)
    , GenerateOptions(..)
    , defaultGenerateOptions
    ) where

import Data.Text                 (Text)
import Dhall                     (FromDhall, ToDhall)
import Dhall.Syntax              (Expr (..))
import GHC.Generics              (Generic)
import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ)
import Prettyprinter             (Pretty)

import Language.Haskell.TH.Syntax
    ( Bang (..)
    , Body (..)
    , Con (..)
    , Dec (..)
    , Exp (..)
    , Match (..)
    , Pat (..)
    , Q
    , SourceStrictness (..)
    , SourceUnpackedness (..)
    , Type (..)
    )

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
import qualified Dhall.Core                  as Core
import qualified Dhall.Map
import qualified Dhall.Pretty
import qualified Dhall.Util
import qualified GHC.IO.Encoding
import qualified Language.Haskell.TH.Syntax  as Syntax
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.

    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

    > < This : Natural | Other : ../Other/Type.dhall >

    ... rather than duplicating the AST manually in a Haskell `Dhall.Type`, you
    can do:

    > Dhall.Type
    > (\case
    >     UnionLit "This" _ _  -> ...
    >     UnionLit "Other" _ _ -> ...)
    > $(staticDhallExpression "./Some/Type.dhall")

    This would create the Dhall Expr AST from the @".\/Some\/Type.dhall"@ file
    at compile time with all imports resolved, making it easy to keep your Dhall
    configs and Haskell interpreters in sync.
-}
staticDhallExpression :: Text -> Q Exp
staticDhallExpression :: Text -> Q Exp
staticDhallExpression Text
text = do
    IO () -> Q ()
forall a. IO a -> Q a
Syntax.runIO (TextEncoding -> IO ()
GHC.IO.Encoding.setLocaleEncoding TextEncoding
System.IO.utf8)

    Expr Src Void
expression <- IO (Expr Src Void) -> Q (Expr Src Void)
forall a. IO a -> Q a
Syntax.runIO (Text -> IO (Expr Src Void)
Dhall.inputExpr Text
text)

    (forall b. Data b => b -> Maybe (Q Exp)) -> Expr Src Void -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
dataToExpQ ((Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText (Maybe Text -> Maybe (Q Exp))
-> (b -> Maybe Text) -> b -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast) Expr Src Void
expression
  where
    -- A workaround for a problem in TemplateHaskell (see
    -- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable)
    liftText :: Text -> Q Exp
liftText = (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Text.pack)) (Q Exp -> Q Exp) -> (Text -> Q Exp) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
forall t. Lift t => t -> Q Exp
Syntax.lift (String -> Q Exp) -> (Text -> String) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

{-| A quasi-quoter for Dhall expressions.

    This quoter is build on top of 'staticDhallExpression'. Therefore consult the
    documentation of that function for further information.

    This quoter is meant to be used in expression context only; Other contexts
    like pattern contexts or declaration contexts are not supported and will
    result in an error.
-}
dhall :: QuasiQuoter
dhall :: QuasiQuoter
dhall = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = Text -> Q Exp
staticDhallExpression (Text -> Q Exp) -> (String -> Text) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    , quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. HasCallStack => String -> a
error String
"dhall quasi-quoter: Quoting patterns is not supported!"
    , quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. HasCallStack => String -> a
error String
"dhall quasi-quoter: Quoting types is not supported!"
    , quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"dhall quasi-quoter: Quoting declarations is not supported!"
    }

{-| Convert a Dhall type to a Haskell type that does not require any new
    data declarations beyond the data declarations supplied as the first
    argument
-}
toNestedHaskellType
    :: (Eq a, Pretty a)
    => [HaskellType (Expr s a)]
    -- ^ All Dhall-derived data declarations
    --
    -- Used to replace complex types with references to one of these
    -- data declarations when the types match
    -> Expr s a
    -- ^ Dhall expression to convert to a simple Haskell type
    -> Q Type
toNestedHaskellType :: [HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [HaskellType (Expr s a)]
haskellTypes = Expr s a -> Q Type
forall (m :: * -> *) s. MonadFail m => Expr s a -> m Type
loop
  where
    loop :: Expr s a -> m Type
loop Expr s a
dhallType = case Expr s a
dhallType of
        Expr s a
Bool ->
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Bool)

        Expr s a
Double ->
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Double)

        Expr s a
Integer ->
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Integer)

        Expr s a
Natural ->
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Numeric.Natural.Natural)

        Expr s a
Text ->
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Text)

        App Expr s a
List Expr s a
dhallElementType -> do
            Type
haskellElementType <- Expr s a -> m Type
loop Expr s a
dhallElementType

            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppT (Name -> Type
ConT ''[]) Type
haskellElementType)

        App Expr s a
Optional Expr s a
dhallElementType -> do
            Type
haskellElementType <- Expr s a -> m Type
loop Expr s a
dhallElementType

            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) Type
haskellElementType)

        Expr s a
_   | Just HaskellType (Expr s a)
haskellType <- (HaskellType (Expr s a) -> Bool)
-> [HaskellType (Expr s a)] -> Maybe (HaskellType (Expr s a))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find HaskellType (Expr s a) -> Bool
forall s. HaskellType (Expr s a) -> Bool
predicate [HaskellType (Expr s a)]
haskellTypes -> do
                let name :: Name
name = String -> Name
Syntax.mkName (Text -> String
Text.unpack (HaskellType (Expr s a) -> Text
forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType))

                Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
name)
            | Bool
otherwise -> do
            let document :: Doc Ann
document =
                    [Doc Ann] -> Doc Ann
forall a. Monoid a => [a] -> a
mconcat
                    [ Doc Ann
"Unsupported nested type\n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"Explanation: Not all Dhall types can be nested within Haskell datatype          \n"
                    , Doc Ann
"declarations.  Specifically, only the following simple Dhall types are supported\n"
                    , Doc Ann
"as a nested type inside of a data declaration:                                  \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"• ❰Bool❱                                                                        \n"
                    , Doc Ann
"• ❰Double❱                                                                      \n"
                    , Doc Ann
"• ❰Integer❱                                                                     \n"
                    , Doc Ann
"• ❰Natural❱                                                                     \n"
                    , Doc Ann
"• ❰Text❱                                                                        \n"
                    , Doc Ann
"• ❰List a❱     (where ❰a❱ is also a valid nested type)                          \n"
                    , Doc Ann
"• ❰Optional a❱ (where ❰a❱ is also a valid nested type)                          \n"
                    , Doc Ann
"• Another matching datatype declaration                                         \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"The Haskell datatype generation logic encountered the following Dhall type:     \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
" " Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Expr s a -> Doc Ann
forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert Expr s a
dhallType Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
"\n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"... which did not fit any of the above criteria."
                    ]

            let message :: String
message = SimpleDocStream Ann -> String
forall ann. SimpleDocStream ann -> String
Pretty.renderString (Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
document)

            String -> m Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
message
          where
            predicate :: HaskellType (Expr s a) -> Bool
predicate HaskellType (Expr s a)
haskellType =
                Expr s a -> Expr s a -> Bool
forall a s t. Eq a => Expr s a -> Expr t a -> Bool
Core.judgmentallyEqual (HaskellType (Expr s a) -> Expr s a
forall code. HaskellType code -> code
code HaskellType (Expr s a)
haskellType) Expr s a
dhallType

-- | A deriving clause for `Generic`.
derivingGenericClause :: DerivClause
derivingGenericClause :: DerivClause
derivingGenericClause = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [ Name -> Type
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 :: Name -> Q Exp -> Q [Dec]
fromDhallInstance Name
n Q Exp
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 :: Name -> Q Exp -> Q [Dec]
toDhallInstance Name
n Q Exp
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)
    => GenerateOptions
    -> [HaskellType (Expr s a)]
    -> HaskellType (Expr s a)
    -> Q [Dec]
toDeclaration :: GenerateOptions
-> [HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q [Dec]
toDeclaration generateOptions :: GenerateOptions
generateOptions@GenerateOptions{Bool
Text -> Text
generateToDhallInstance :: GenerateOptions -> Bool
generateFromDhallInstance :: GenerateOptions -> Bool
fieldModifier :: GenerateOptions -> Text -> Text
constructorModifier :: GenerateOptions -> Text -> Text
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
..} [HaskellType (Expr s a)]
haskellTypes typ :: HaskellType (Expr s a)
typ@MultipleConstructors{Text
Expr s a
code :: Expr s a
typeName :: Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} =
    case Expr s a
code of
        Union Map Text (Maybe (Expr s a))
kts -> do
            let name :: Name
name = String -> Name
Syntax.mkName (Text -> String
Text.unpack Text
typeName)

            let derivingClauses :: [DerivClause]
derivingClauses =
                    [ DerivClause
derivingGenericClause | Bool
generateFromDhallInstance Bool -> Bool -> Bool
|| Bool
generateToDhallInstance ]

            [Con]
constructors <- ((Text, Maybe (Expr s a)) -> Q Con)
-> [(Text, Maybe (Expr s a))] -> Q [Con]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
forall a s.
(Eq a, Pretty a) =>
GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor GenerateOptions
generateOptions [HaskellType (Expr s a)]
haskellTypes Text
typeName) (Map Text (Maybe (Expr s a)) -> [(Text, Maybe (Expr s a))]
forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList Map Text (Maybe (Expr s a))
kts)

            let interpretOptions :: Q Exp
interpretOptions = GenerateOptions -> HaskellType (Expr s a) -> Q Exp
forall s a. GenerateOptions -> HaskellType (Expr s a) -> Q Exp
generateToInterpretOptions GenerateOptions
generateOptions HaskellType (Expr s a)
typ

            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
                [[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con]
constructors [DerivClause]
derivingClauses]] [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. Semigroup a => a -> a -> a
<>
                [ Name -> Q Exp -> Q [Dec]
fromDhallInstance Name
name Q Exp
interpretOptions | Bool
generateFromDhallInstance ] [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. Semigroup a => a -> a -> a
<>
                [ Name -> Q Exp -> Q [Dec]
toDhallInstance Name
name Q Exp
interpretOptions | Bool
generateToDhallInstance ]

        Expr s a
_ -> do
            let document :: Doc Ann
document =
                    [Doc Ann] -> Doc Ann
forall a. Monoid a => [a] -> a
mconcat
                    [ Doc Ann
"Dhall.TH.makeHaskellTypes: Not a union type\n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"Explanation: This function expects the ❰code❱ field of ❰MultipleConstructors❱ to\n"
                    , Doc Ann
"evaluate to a union type.                                                       \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"For example, this is a valid Dhall union type that this function would accept:  \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"    ┌──────────────────────────────────────────────────────────────────┐        \n"
                    , Doc Ann
"    │ Dhall.TH.makeHaskellTypes (MultipleConstructors \"T\" \"< A | B >\") │        \n"
                    , Doc Ann
"    └──────────────────────────────────────────────────────────────────┘        \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"... which corresponds to this Haskell type declaration:                         \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"    ┌────────────────┐                                                          \n"
                    , Doc Ann
"    │ data T = A | B │                                                          \n"
                    , Doc Ann
"    └────────────────┘                                                          \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"... but the following Dhall type is rejected due to being a bare record type:   \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"    ┌──────────────────────────────────────────────┐                            \n"
                    , Doc Ann
"    │ Dhall.TH.makeHaskellTypes \"T\" \"{ x : Bool }\" │  Not valid                 \n"
                    , Doc Ann
"    └──────────────────────────────────────────────┘                            \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"The Haskell datatype generation logic encountered the following Dhall type:     \n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
" " Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Expr s a -> Doc Ann
forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert Expr s a
code Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
"\n"
                    , Doc Ann
"                                                                                \n"
                    , Doc Ann
"... which is not a union type."
                    ]

            let message :: String
message = SimpleDocStream Ann -> String
forall ann. SimpleDocStream ann -> String
Pretty.renderString (Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
document)

            String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
message
toDeclaration generateOptions :: GenerateOptions
generateOptions@GenerateOptions{Bool
Text -> Text
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
generateToDhallInstance :: GenerateOptions -> Bool
generateFromDhallInstance :: GenerateOptions -> Bool
fieldModifier :: GenerateOptions -> Text -> Text
constructorModifier :: GenerateOptions -> Text -> Text
..} [HaskellType (Expr s a)]
haskellTypes typ :: HaskellType (Expr s a)
typ@SingleConstructor{Text
Expr s a
constructorName :: forall code. HaskellType code -> Text
code :: Expr s a
constructorName :: Text
typeName :: Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} = do
    let name :: Name
name = String -> Name
Syntax.mkName (Text -> String
Text.unpack Text
typeName)

    let derivingClauses :: [DerivClause]
derivingClauses =
            [ DerivClause
derivingGenericClause | Bool
generateFromDhallInstance Bool -> Bool -> Bool
|| Bool
generateToDhallInstance ]

    let interpretOptions :: Q Exp
interpretOptions = GenerateOptions -> HaskellType (Expr s a) -> Q Exp
forall s a. GenerateOptions -> HaskellType (Expr s a) -> Q Exp
generateToInterpretOptions GenerateOptions
generateOptions HaskellType (Expr s a)
typ

    Con
constructor <- GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
forall a s.
(Eq a, Pretty a) =>
GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor GenerateOptions
generateOptions [HaskellType (Expr s a)]
haskellTypes Text
typeName (Text
constructorName, Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
code)

    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
        [[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con
constructor] [DerivClause]
derivingClauses]] [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. Semigroup a => a -> a -> a
<>
        [ Name -> Q Exp -> Q [Dec]
fromDhallInstance Name
name Q Exp
interpretOptions | Bool
generateFromDhallInstance ] [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. Semigroup a => a -> a -> a
<>
        [ Name -> Q Exp -> Q [Dec]
toDhallInstance Name
name Q Exp
interpretOptions | Bool
generateToDhallInstance ]

-- | Convert a Dhall type to the corresponding Haskell constructor
toConstructor
    :: (Eq a, Pretty a)
    => GenerateOptions
    -> [HaskellType (Expr s a)]
    -> Text
    -- ^ typeName
    -> (Text, Maybe (Expr s a))
    -- ^ @(constructorName, fieldType)@
    -> Q Con
toConstructor :: GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor GenerateOptions{Bool
Text -> Text
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
generateToDhallInstance :: GenerateOptions -> Bool
generateFromDhallInstance :: GenerateOptions -> Bool
fieldModifier :: GenerateOptions -> Text -> Text
constructorModifier :: GenerateOptions -> Text -> Text
..} [HaskellType (Expr s a)]
haskellTypes Text
outerTypeName (Text
constructorName, Maybe (Expr s a)
maybeAlternativeType) = do
    let name :: Name
name = String -> Name
Syntax.mkName (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
constructorModifier Text
constructorName)

    let bang :: Bang
bang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

    case Maybe (Expr s a)
maybeAlternativeType of
        Just Expr s a
dhallType
            | let predicate :: HaskellType (Expr s a) -> Bool
predicate HaskellType (Expr s a)
haskellType =
                    Expr s a -> Expr s a -> Bool
forall a s t. Eq a => Expr s a -> Expr t a -> Bool
Core.judgmentallyEqual (HaskellType (Expr s a) -> Expr s a
forall code. HaskellType code -> code
code HaskellType (Expr s a)
haskellType) Expr s a
dhallType
                    Bool -> Bool -> Bool
&& HaskellType (Expr s a) -> Text
forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
outerTypeName
            , Just HaskellType (Expr s a)
haskellType <- (HaskellType (Expr s a) -> Bool)
-> [HaskellType (Expr s a)] -> Maybe (HaskellType (Expr s a))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find HaskellType (Expr s a) -> Bool
forall s. HaskellType (Expr s a) -> Bool
predicate [HaskellType (Expr s a)]
haskellTypes -> do
                let innerName :: Name
innerName =
                        String -> Name
Syntax.mkName (Text -> String
Text.unpack (HaskellType (Expr s a) -> Text
forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType))

                Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [BangType] -> Con
NormalC Name
name [ (Bang
bang, Name -> Type
ConT Name
innerName) ])

        Just (Record Map Text (RecordField s a)
kts) -> do
            let process :: (Text, Expr s a) -> Q (Name, Bang, Type)
process (Text
key, Expr s a
dhallFieldType) = do
                    Type
haskellFieldType <- [HaskellType (Expr s a)] -> Expr s a -> Q Type
forall a s.
(Eq a, Pretty a) =>
[HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [HaskellType (Expr s a)]
haskellTypes Expr s a
dhallFieldType

                    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Name
Syntax.mkName (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldModifier Text
key), Bang
bang, Type
haskellFieldType)

            [(Name, Bang, Type)]
varBangTypes <- ((Text, Expr s a) -> Q (Name, Bang, Type))
-> [(Text, Expr s a)] -> Q [(Name, Bang, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text, Expr s a) -> Q (Name, Bang, Type)
process (Map Text (Expr s a) -> [(Text, Expr s a)]
forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList (Map Text (Expr s a) -> [(Text, Expr s a)])
-> Map Text (Expr s a) -> [(Text, Expr s a)]
forall a b. (a -> b) -> a -> b
$ RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s a -> Expr s a)
-> Map Text (RecordField s a) -> Map Text (Expr s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s a)
kts)

            Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [(Name, Bang, Type)] -> Con
RecC Name
name [(Name, Bang, Type)]
varBangTypes)

        Just Expr s a
dhallAlternativeType -> do
            Type
haskellAlternativeType <- [HaskellType (Expr s a)] -> Expr s a -> Q Type
forall a s.
(Eq a, Pretty a) =>
[HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [HaskellType (Expr s a)]
haskellTypes Expr s a
dhallAlternativeType

            Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [BangType] -> Con
NormalC Name
name [ (Bang
bang, Type
haskellAlternativeType) ])

        Maybe (Expr s a)
Nothing ->
            Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [BangType] -> Con
NormalC Name
name [])

-- | Generate a Haskell datatype declaration from a Dhall union type where
-- each union alternative corresponds to a Haskell constructor
--
-- 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
--
-- This is a special case of `Dhall.TH.makeHaskellTypes`:
--
-- > makeHaskellTypeFromUnion typeName code =
-- >     makeHaskellTypes [ MultipleConstructors{..} ]
makeHaskellTypeFromUnion
    :: Text
    -- ^ Name of the generated Haskell type
    -> Text
    -- ^ Dhall code that evaluates to a union type
    -> Q [Dec]
makeHaskellTypeFromUnion :: Text -> Text -> Q [Dec]
makeHaskellTypeFromUnion Text
typeName Text
code =
    [HaskellType Text] -> Q [Dec]
makeHaskellTypes [ MultipleConstructors :: forall code. Text -> code -> HaskellType code
MultipleConstructors{Text
code :: Text
typeName :: Text
code :: Text
typeName :: Text
..} ]

-- | 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.
    = MultipleConstructors
        { HaskellType code -> Text
typeName :: Text
        -- ^ Name of the generated Haskell type
        , HaskellType code -> 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.
    | SingleConstructor
        { typeName :: Text
        -- ^ Name of the generated Haskell type
        , HaskellType code -> Text
constructorName :: Text
        -- ^ Name of the constructor
        , code :: code
        -- ^ Dhall code that evaluates to a type
        }
    deriving (a -> HaskellType b -> HaskellType a
(a -> b) -> HaskellType a -> HaskellType b
(forall a b. (a -> b) -> HaskellType a -> HaskellType b)
-> (forall a b. a -> HaskellType b -> HaskellType a)
-> Functor HaskellType
forall a b. a -> HaskellType b -> HaskellType a
forall a b. (a -> b) -> HaskellType a -> HaskellType b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> HaskellType b -> HaskellType a
$c<$ :: forall a b. a -> HaskellType b -> HaskellType a
fmap :: (a -> b) -> HaskellType a -> HaskellType b
$cfmap :: forall a b. (a -> b) -> HaskellType a -> HaskellType b
Functor, HaskellType a -> Bool
(a -> m) -> HaskellType a -> m
(a -> b -> b) -> b -> HaskellType a -> b
(forall m. Monoid m => HaskellType m -> m)
-> (forall m a. Monoid m => (a -> m) -> HaskellType a -> m)
-> (forall m a. Monoid m => (a -> m) -> HaskellType a -> m)
-> (forall a b. (a -> b -> b) -> b -> HaskellType a -> b)
-> (forall a b. (a -> b -> b) -> b -> HaskellType a -> b)
-> (forall b a. (b -> a -> b) -> b -> HaskellType a -> b)
-> (forall b a. (b -> a -> b) -> b -> HaskellType a -> b)
-> (forall a. (a -> a -> a) -> HaskellType a -> a)
-> (forall a. (a -> a -> a) -> HaskellType a -> a)
-> (forall a. HaskellType a -> [a])
-> (forall a. HaskellType a -> Bool)
-> (forall a. HaskellType a -> Int)
-> (forall a. Eq a => a -> HaskellType a -> Bool)
-> (forall a. Ord a => HaskellType a -> a)
-> (forall a. Ord a => HaskellType a -> a)
-> (forall a. Num a => HaskellType a -> a)
-> (forall a. Num a => HaskellType a -> a)
-> Foldable HaskellType
forall a. Eq a => a -> HaskellType a -> Bool
forall a. Num a => HaskellType a -> a
forall a. Ord a => HaskellType a -> a
forall m. Monoid m => HaskellType m -> m
forall a. HaskellType a -> Bool
forall a. HaskellType a -> Int
forall a. HaskellType a -> [a]
forall a. (a -> a -> a) -> HaskellType a -> a
forall m a. Monoid m => (a -> m) -> HaskellType a -> m
forall b a. (b -> a -> b) -> b -> HaskellType a -> b
forall a b. (a -> b -> b) -> b -> HaskellType a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: HaskellType a -> a
$cproduct :: forall a. Num a => HaskellType a -> a
sum :: HaskellType a -> a
$csum :: forall a. Num a => HaskellType a -> a
minimum :: HaskellType a -> a
$cminimum :: forall a. Ord a => HaskellType a -> a
maximum :: HaskellType a -> a
$cmaximum :: forall a. Ord a => HaskellType a -> a
elem :: a -> HaskellType a -> Bool
$celem :: forall a. Eq a => a -> HaskellType a -> Bool
length :: HaskellType a -> Int
$clength :: forall a. HaskellType a -> Int
null :: HaskellType a -> Bool
$cnull :: forall a. HaskellType a -> Bool
toList :: HaskellType a -> [a]
$ctoList :: forall a. HaskellType a -> [a]
foldl1 :: (a -> a -> a) -> HaskellType a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldr1 :: (a -> a -> a) -> HaskellType a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldl' :: (b -> a -> b) -> b -> HaskellType a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
foldl :: (b -> a -> b) -> b -> HaskellType a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
foldr' :: (a -> b -> b) -> b -> HaskellType a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
foldr :: (a -> b -> b) -> b -> HaskellType a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
foldMap' :: (a -> m) -> HaskellType a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
foldMap :: (a -> m) -> HaskellType a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
fold :: HaskellType m -> m
$cfold :: forall m. Monoid m => HaskellType m -> m
Foldable, Functor HaskellType
Foldable HaskellType
Functor HaskellType
-> Foldable HaskellType
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> HaskellType a -> f (HaskellType b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    HaskellType (f a) -> f (HaskellType a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> HaskellType a -> m (HaskellType b))
-> (forall (m :: * -> *) a.
    Monad m =>
    HaskellType (m a) -> m (HaskellType a))
-> Traversable HaskellType
(a -> f b) -> HaskellType a -> f (HaskellType b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
sequence :: HaskellType (m a) -> m (HaskellType a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
mapM :: (a -> m b) -> HaskellType a -> m (HaskellType b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
sequenceA :: HaskellType (f a) -> f (HaskellType a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
traverse :: (a -> f b) -> HaskellType a -> f (HaskellType b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
$cp2Traversable :: Foldable HaskellType
$cp1Traversable :: Functor HaskellType
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
    { GenerateOptions -> Text -> Text
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.
    , GenerateOptions -> Text -> Text
fieldModifier :: Text -> Text
    -- ^ How to map a Dhall record field names to a Haskell record field names.
    , GenerateOptions -> Bool
generateFromDhallInstance :: Bool
    -- ^ Generate a `FromDhall` instance for the Haskell type
    , GenerateOptions -> Bool
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
defaultGenerateOptions = GenerateOptions :: (Text -> Text) -> (Text -> Text) -> Bool -> Bool -> GenerateOptions
GenerateOptions
    { constructorModifier :: Text -> Text
constructorModifier = Text -> Text
forall a. a -> a
id
    , fieldModifier :: Text -> Text
fieldModifier = Text -> Text
forall a. a -> a
id
    , generateFromDhallInstance :: Bool
generateFromDhallInstance = Bool
True
    , generateToDhallInstance :: Bool
generateToDhallInstance = Bool
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 (Expr s a) -> Q Exp
generateToInterpretOptions GenerateOptions{Bool
Text -> Text
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
generateToDhallInstance :: GenerateOptions -> Bool
generateFromDhallInstance :: GenerateOptions -> Bool
fieldModifier :: GenerateOptions -> Text -> Text
constructorModifier :: GenerateOptions -> Text -> Text
..} HaskellType (Expr s a)
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 :: HaskellType (Expr s a) -> [Text]
constructors SingleConstructor{Text
Expr s a
code :: Expr s a
constructorName :: Text
typeName :: Text
constructorName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} = [Text
constructorName]
        constructors MultipleConstructors{Text
Expr s a
code :: Expr s a
typeName :: Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} | Union Map Text (Maybe (Expr s a))
kts <- Expr s a
code = Map Text (Maybe (Expr s a)) -> [Text]
forall k v. Map k v -> [k]
Dhall.Map.keys Map Text (Maybe (Expr s a))
kts
        constructors HaskellType (Expr s a)
_ = []

        fields :: HaskellType (Expr s a) -> [Text]
        fields :: HaskellType (Expr s a) -> [Text]
fields SingleConstructor{Text
Expr s a
code :: Expr s a
constructorName :: Text
typeName :: Text
constructorName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} | Record Map Text (RecordField s a)
kts <- Expr s a
code = Map Text (RecordField s a) -> [Text]
forall k v. Map k v -> [k]
Dhall.Map.keys Map Text (RecordField s a)
kts
        fields MultipleConstructors{Text
Expr s a
code :: Expr s a
typeName :: Text
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
..} | Union Map Text (Maybe (Expr s a))
kts <- Expr s a
code = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Set Text] -> Set Text
forall a. Monoid a => [a] -> a
mconcat
            [ Map Text (RecordField s a) -> Set Text
forall k v. Map k v -> Set k
Dhall.Map.keysSet Map Text (RecordField s a)
kts'
            | (Text
_, Just (Record Map Text (RecordField s a)
kts')) <- Map Text (Maybe (Expr s a)) -> [(Text, Maybe (Expr s a))]
forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList Map Text (Maybe (Expr s a))
kts
            ]
        fields HaskellType (Expr s a)
_ = []

        toCases :: (Text -> Text) -> [Text] -> Q Exp
        toCases :: (Text -> Text) -> [Text] -> Q Exp
toCases Text -> Text
f [Text]
xs = do
            Exp
err <- [| Core.internalError $ "Unmatched " <> Text.pack (show $(pure nameE)) |]
            Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
nameE ([Match] -> Exp) -> [Match] -> Exp
forall a b. (a -> b) -> a -> b
$ (Text -> Match) -> [Text] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Match
mkMatch [Text]
xs [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
err) []]
            where
                mkMatch :: Text -> Match
mkMatch Text
n = Pat -> Body -> [Dec] -> Match
Match (Text -> Pat
textToPat (Text -> Pat) -> Text -> Pat
forall a b. (a -> b) -> a -> b
$ Text -> Text
f Text
n) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Text -> Exp
textToExp Text
n) []

        nameE :: Exp
        nameE :: Exp
nameE = Name -> Exp
Syntax.VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
Syntax.mkName String
"n"

        nameP :: Pat
        nameP :: Pat
nameP = Name -> Pat
Syntax.VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
Syntax.mkName String
"n"

        textToExp :: Text -> Exp
        textToExp :: Text -> Exp
textToExp = Lit -> Exp
Syntax.LitE (Lit -> Exp) -> (Text -> Lit) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
Syntax.StringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

        textToPat :: Text -> Pat
        textToPat :: Text -> Pat
textToPat = Lit -> Pat
Syntax.LitP (Lit -> Pat) -> (Text -> Lit) -> Text -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
Syntax.StringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

-- | Generate a Haskell datatype declaration with one constructor from a Dhall
-- 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
-- to generate the matching Haskell type declarations from the Dhall types.
--
-- For example, given this Dhall code:
--
-- > -- ./Department.dhall
-- > < Sales | Engineering | Marketing >
--
-- > -- ./Employee.dhall
-- > { name : Text, department : ./Department.dhall }
--
-- ... this Template Haskell splice:
--
-- > {-# LANGUAGE DeriveAnyClass     #-}
-- > {-# LANGUAGE DeriveGeneric      #-}
-- > {-# LANGUAGE DerivingStrategies #-}
-- > {-# LANGUAGE OverloadedStrings  #-}
-- > {-# LANGUAGE TemplateHaskell    #-}
-- >
-- > Dhall.TH.makeHaskellTypes
-- >     [ MultipleConstructors "Department" "./tests/th/Department.dhall"
-- >     , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall"
-- >     ]
--
-- ... generates this Haskell code:
--
-- > data Department = Engineering | Marketing | Sales
-- >   deriving stock (GHC.Generics.Generic)
-- >   deriving anyclass (Dhall.FromDhall, Dhall.ToDhall)
-- >
-- > data Employee
-- >   = MakeEmployee {department :: Department,
-- >                   name :: Data.Text.Internal.Text}
-- >   deriving stock (GHC.Generics.Generic)
-- >   deriving anyclass (Dhall.FromDhall, Dhall.ToDhall)
--
-- Carefully note that the conversion makes a best-effort attempt to
-- auto-detect when a Dhall type (like @./Employee.dhall@) refers to another
-- Dhall type (like @./Department.dhall@) and replaces that reference with the
-- corresponding Haskell type.
--
-- This Template Haskell splice requires you to enable the following extensions:
--
-- * @DeriveGeneric@
-- * @DerivingAnyClass@
-- * @DerivingStrategies@
--
-- By default, the generated types only derive `GHC.Generics.Generic`,
-- `Dhall.FromDhall`, and `Dhall.ToDhall`.  To add any desired instances (such
-- as `Eq`\/`Ord`\/`Show`), you can use the @StandaloneDeriving@ language
-- extension, like this:
--
-- > {-# LANGUAGE DeriveAnyClass     #-}
-- > {-# LANGUAGE DeriveGeneric      #-}
-- > {-# LANGUAGE DerivingStrategies #-}
-- > {-# LANGUAGE OverloadedStrings  #-}
-- > {-# LANGUAGE StandaloneDeriving #-}
-- > {-# LANGUAGE TemplateHaskell    #-}
-- >
-- > Dhall.TH.makeHaskellTypes
-- >     [ MultipleConstructors "Department" "./tests/th/Department.dhall"
-- >     , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall"
-- >     ]
-- >
-- > deriving instance Eq   Department
-- > deriving instance Ord  Department
-- > deriving instance Show Department
-- >
-- > deriving instance Eq   Employee
-- > deriving instance Ord  Employee
-- > deriving instance Show Employee
makeHaskellTypes :: [HaskellType Text] -> Q [Dec]
makeHaskellTypes :: [HaskellType Text] -> Q [Dec]
makeHaskellTypes = GenerateOptions -> [HaskellType Text] -> Q [Dec]
makeHaskellTypesWith GenerateOptions
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 -> [HaskellType Text] -> Q [Dec]
makeHaskellTypesWith GenerateOptions
generateOptions [HaskellType Text]
haskellTypes = do
    IO () -> Q ()
forall a. IO a -> Q a
Syntax.runIO (TextEncoding -> IO ()
GHC.IO.Encoding.setLocaleEncoding TextEncoding
System.IO.utf8)

    [HaskellType (Expr Src Void)]
haskellTypes' <- (HaskellType Text -> Q (HaskellType (Expr Src Void)))
-> [HaskellType Text] -> Q [HaskellType (Expr Src Void)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Text -> Q (Expr Src Void))
-> HaskellType Text -> Q (HaskellType (Expr Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (IO (Expr Src Void) -> Q (Expr Src Void)
forall a. IO a -> Q a
Syntax.runIO (IO (Expr Src Void) -> Q (Expr Src Void))
-> (Text -> IO (Expr Src Void)) -> Text -> Q (Expr Src Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO (Expr Src Void)
Dhall.inputExpr)) [HaskellType Text]
haskellTypes

    [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HaskellType (Expr Src Void) -> Q [Dec])
-> [HaskellType (Expr Src Void)] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (GenerateOptions
-> [HaskellType (Expr Src Void)]
-> HaskellType (Expr Src Void)
-> Q [Dec]
forall a s.
(Eq a, Pretty a) =>
GenerateOptions
-> [HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q [Dec]
toDeclaration GenerateOptions
generateOptions [HaskellType (Expr Src Void)]
haskellTypes') [HaskellType (Expr Src Void)]
haskellTypes'