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

-- | Template Haskell utilities
module Dhall.TH
    ( -- * Template Haskell
      staticDhallExpression
    , makeHaskellTypeFromUnion
    , makeHaskellTypes
    , HaskellType(..)
    ) where

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

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

import Language.Haskell.TH.Syntax (DerivClause (..), DerivStrategy (..))

import qualified Data.List                               as List
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.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 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

{-| 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

derivingClauses :: [DerivClause]
derivingClauses :: [DerivClause]
derivingClauses =
    [ Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [ Name -> Type
ConT ''Generic ]
    , Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) [ Name -> Type
ConT ''FromDhall, Name -> Type
ConT ''ToDhall ]
    ]

-- | Convert a Dhall type to the corresponding Haskell datatype declaration
toDeclaration
    :: (Eq a, Pretty a)
    => [HaskellType (Expr s a)]
    -> HaskellType (Expr s a)
    -> Q Dec
toDeclaration :: [HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q Dec
toDeclaration [HaskellType (Expr s a)]
haskellTypes 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)

            [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 ([HaskellType (Expr s a)]
-> Text -> (Text, Maybe (Expr s a)) -> Q Con
forall a s.
(Eq a, Pretty a) =>
[HaskellType (Expr s a)]
-> Text -> (Text, Maybe (Expr s a)) -> Q Con
toConstructor [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 )

            Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con]
constructors [DerivClause]
derivingClauses)

        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 [HaskellType (Expr s a)]
haskellTypes 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)

    Con
constructor <- [HaskellType (Expr s a)]
-> Text -> (Text, Maybe (Expr s a)) -> Q Con
forall a s.
(Eq a, Pretty a) =>
[HaskellType (Expr s a)]
-> Text -> (Text, Maybe (Expr s a)) -> Q Con
toConstructor [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 -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con
constructor] [DerivClause]
derivingClauses)

-- | Convert a Dhall type to the corresponding Haskell constructor
toConstructor
    :: (Eq a, Pretty a)
    => [HaskellType (Expr s a)]
    -> Text
    -- ^ typeName
    -> (Text, Maybe (Expr s a))
    -- ^ @(constructorName, fieldType)@
    -> Q Con
toConstructor :: [HaskellType (Expr s a)]
-> Text -> (Text, Maybe (Expr s a)) -> Q Con
toConstructor [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
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
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` 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)

-- | 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 [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

    (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 ([HaskellType (Expr Src Void)]
-> HaskellType (Expr Src Void) -> Q Dec
forall a s.
(Eq a, Pretty a) =>
[HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q Dec
toDeclaration [HaskellType (Expr Src Void)]
haskellTypes') [HaskellType (Expr Src Void)]
haskellTypes'