{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# 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.Bifunctor            (first)
import Data.Text                 (Text)
import Dhall                     (FromDhall, ToDhall)
import Dhall.Syntax              (Expr (..), FunctionBinding (..), Var (..))
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.Map                    as Map
import qualified Data.Set                    as Set
import qualified Data.Text                   as Text
import qualified Data.Time                   as Time
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
    forall a. IO a -> Q a
Syntax.runIO (TextEncoding -> IO ()
GHC.IO.Encoding.setLocaleEncoding TextEncoding
System.IO.utf8)

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

    forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Text.pack)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
Syntax.lift 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
    { quoteExp :: String -> Q Exp
quoteExp = Text -> Q Exp
staticDhallExpression forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    , quotePat :: String -> Q Pat
quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"dhall quasi-quoter: Quoting patterns is not supported!"
    , quoteType :: String -> Q Type
quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"dhall quasi-quoter: Quoting types is not supported!"
    , quoteDec :: String -> Q [Dec]
quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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)
    => [Var]
    -> [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 :: forall a s.
(Eq a, Pretty a) =>
[Var] -> [HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [Var]
typeParams [HaskellType (Expr s a)]
haskellTypes = forall {m :: * -> *} {t}. MonadFail m => Expr t a -> m Type
loop
  where
    predicate :: Expr t a -> HaskellType (Expr s a) -> Bool
predicate Expr t a
dhallType HaskellType (Expr s a)
haskellType = forall a s t. Eq a => Expr s a -> Expr t a -> Bool
Core.judgmentallyEqual (forall code. HaskellType code -> code
code HaskellType (Expr s a)
haskellType) Expr t a
dhallType

    document :: a -> Doc Ann
document a
dhallType =
      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
"• ❰Date❱                                                                        \n"
      , Doc Ann
"• ❰TimeOfDay❱                                                                   \n"
      , Doc Ann
"• ❰TimeZone❱                                                                    \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
"• A bound type variable                                                         \n"
      , Doc Ann
"                                                                                \n"
      , Doc Ann
"The Haskell datatype generation logic encountered the following Dhall type:     \n"
      , Doc Ann
"                                                                                \n"
      , Doc Ann
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert a
dhallType forall a. Semigroup a => a -> a -> a
<> Doc Ann
"\n"
      , Doc Ann
"                                                                                \n"
      , Doc Ann
"... which did not fit any of the above criteria."
      ]
  
    message :: a -> String
message a
dhallType = forall ann. SimpleDocStream ann -> String
Pretty.renderString (forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout (forall a. Pretty a => a -> Doc Ann
document a
dhallType))
  
    loop :: Expr t a -> m Type
loop Expr t a
dhallType = case Expr t a
dhallType of
        Expr t a
Bool ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Bool)

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

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

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

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

        Expr t a
Date ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Time.Day)

        Expr t a
Time ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Time.TimeOfDay)

        Expr t a
TimeZone ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Time.TimeZone)

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

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

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

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

        App Expr t a
dhallAppType Expr t a
dhallElementType -> do
            Type
haskellAppType <- Expr t a -> m Type
loop Expr t a
dhallAppType
            Type
haskellElementType <- Expr t a -> m Type
loop Expr t a
dhallElementType

            forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppT Type
haskellAppType Type
haskellElementType)
          
        Var Var
v
            | Just (V Text
param Int
index) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Var
v forall a. Eq a => a -> a -> Bool
==) [Var]
typeParams -> do
                let name :: Name
name = String -> Name
Syntax.mkName forall a b. (a -> b) -> a -> b
$ (Text -> String
Text.unpack Text
param) forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Int
index)

                forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT Name
name)

            | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall {a}. Pretty a => a -> String
message Var
v

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

                forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
name)
            | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall {a}. Pretty a => a -> String
message Expr t a
dhallType

-- | A deriving clause for `Generic`.
derivingGenericClause :: DerivClause
derivingGenericClause :: DerivClause
derivingGenericClause = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (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 :: forall a s.
(Eq a, Pretty a) =>
GenerateOptions
-> [HaskellType (Expr s a)] -> HaskellType (Expr s a) -> Q [Dec]
toDeclaration generateOptions :: GenerateOptions
generateOptions@GenerateOptions{Bool
Text -> Text
makeStrict :: GenerateOptions -> Bool
generateToDhallInstance :: GenerateOptions -> Bool
generateFromDhallInstance :: GenerateOptions -> Bool
fieldModifier :: GenerateOptions -> Text -> Text
constructorModifier :: GenerateOptions -> Text -> Text
makeStrict :: Bool
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
..} [HaskellType (Expr s a)]
haskellTypes HaskellType (Expr s a)
typ =
    case HaskellType (Expr s a)
typ of
        SingleConstructor{Text
Expr s a
constructorName :: forall code. HaskellType code -> Text
code :: Expr s a
constructorName :: Text
typeName :: Text
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> Text -> [Var] -> Expr s a -> Q [Dec]
fromSingle Text
typeName Text
constructorName) forall a b. (a -> b) -> a -> b
$ forall {s} {a}. Expr s a -> ([Var], Expr s a)
getTypeParams Expr s a
code
        MultipleConstructors{Text
Expr s a
code :: Expr s a
typeName :: Text
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> [Var] -> Expr s a -> Q [Dec]
fromMulti Text
typeName) forall a b. (a -> b) -> a -> b
$ forall {s} {a}. Expr s a -> ([Var], Expr s a)
getTypeParams Expr s a
code
    where
        getTypeParams :: Expr s a -> ([Var], Expr s a)
getTypeParams = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Text] -> [Var]
numberConsecutive forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall {s} {a}. [Text] -> Expr s a -> ([Text], Expr s a)
getTypeParams_ []
    
        getTypeParams_ :: [Text] -> Expr s a -> ([Text], Expr s a)
getTypeParams_ [Text]
acc (Lam Maybe CharacterSet
_ (FunctionBinding Maybe s
_ Text
v Maybe s
_ Maybe s
_ Expr s a
_) Expr s a
rest) = [Text] -> Expr s a -> ([Text], Expr s a)
getTypeParams_ (Text
vforall a. a -> [a] -> [a]
:[Text]
acc) Expr s a
rest
        getTypeParams_ [Text]
acc Expr s a
rest = ([Text]
acc, Expr s a
rest)

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

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

#if MIN_VERSION_template_haskell(2,21,0)
        toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis
#elif MIN_VERSION_template_haskell(2,17,0)
        toTypeVar :: Var -> TyVarBndr ()
toTypeVar (V Text
n Int
i) = forall flag. Name -> flag -> TyVarBndr flag
Syntax.PlainTV (String -> Name
Syntax.mkName (Text -> String
Text.unpack Text
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)) ()
#else
        toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i))
#endif

        toDataD :: Text -> [Var] -> [Con] -> Q [Dec]
toDataD Text
typeName [Var]
typeParams [Con]
constructors = do
            let name :: Name
name = String -> Name
Syntax.mkName (Text -> String
Text.unpack Text
typeName)

            let params :: [TyVarBndr ()]
params = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> TyVarBndr ()
toTypeVar [Var]
typeParams

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

        fromSingle :: Text -> Text -> [Var] -> Expr s a -> Q [Dec]
fromSingle Text
typeName Text
constructorName [Var]
typeParams Expr s a
dhallType = do
            Con
constructor <- forall a s.
(Eq a, Pretty a) =>
[Var]
-> GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor [Var]
typeParams GenerateOptions
generateOptions [HaskellType (Expr s a)]
haskellTypes Text
typeName (Text
constructorName, forall a. a -> Maybe a
Just Expr s a
dhallType)
    
            Text -> [Var] -> [Con] -> Q [Dec]
toDataD Text
typeName [Var]
typeParams [Con
constructor]
    
        fromMulti :: Text -> [Var] -> Expr s a -> Q [Dec]
fromMulti Text
typeName [Var]
typeParams Expr s a
dhallType = case Expr s a
dhallType of
            Union Map Text (Maybe (Expr s a))
kts -> do
                [Con]
constructors <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a s.
(Eq a, Pretty a) =>
[Var]
-> GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor [Var]
typeParams GenerateOptions
generateOptions [HaskellType (Expr s a)]
haskellTypes Text
typeName) (forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList Map Text (Maybe (Expr s a))
kts)

                Text -> [Var] -> [Con] -> Q [Dec]
toDataD Text
typeName [Var]
typeParams [Con]
constructors
    
            Expr s a
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall {a}. Pretty a => a -> String
message Expr s a
dhallType 

        message :: a -> String
message a
dhallType = forall ann. SimpleDocStream ann -> String
Pretty.renderString (forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc Ann
document a
dhallType)

        document :: a -> Doc Ann
document a
dhallType =
            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
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert a
dhallType forall a. Semigroup a => a -> a -> a
<> Doc Ann
"\n"
                , Doc Ann
"                                                                                \n"
                , Doc Ann
"... which is not a union type."
                ]

-- | Number each variable, starting at 0
numberConsecutive :: [Text.Text] -> [Var]
numberConsecutive :: [Text] -> [Var]
numberConsecutive = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumR Map Text Int -> Text -> (Map Text Int, Var)
go forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
      go :: Map Text Int -> Text -> (Map Text Int, Var)
go Map Text Int
m Text
k =
          let (Maybe Int
i, Map Text Int
m') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Text
_ Int
j -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
j forall a. Num a => a -> a -> a
+ Int
1) Text
k Map Text Int
m
          in forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
k Int
0 Map Text Int
m'), (Text -> Int -> Var
V Text
k Int
0)) (\Int
i' -> (Map Text Int
m', (Text -> Int -> Var
V Text
k Int
i'))) Maybe Int
i

-- | Convert a Dhall type to the corresponding Haskell constructor
toConstructor
    :: (Eq a, Pretty a)
    => [Var]
    -> GenerateOptions
    -> [HaskellType (Expr s a)]
    -> Text
    -- ^ typeName
    -> (Text, Maybe (Expr s a))
    -- ^ @(constructorName, fieldType)@
    -> Q Con
toConstructor :: forall a s.
(Eq a, Pretty a) =>
[Var]
-> GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
toConstructor [Var]
typeParams GenerateOptions{Bool
Text -> Text
makeStrict :: Bool
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
makeStrict :: GenerateOptions -> Bool
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 forall a b. (a -> b) -> a -> b
$ Text -> Text
constructorModifier Text
constructorName)

    let strictness :: SourceStrictness
strictness = if Bool
makeStrict then SourceStrictness
SourceStrict else SourceStrictness
NoSourceStrictness

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

    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 =
                    forall a s t. Eq a => Expr s a -> Expr t a -> Bool
Core.judgmentallyEqual (forall code. HaskellType code -> code
code HaskellType (Expr s a)
haskellType) Expr s a
dhallType
                    Bool -> Bool -> Bool
&& forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType forall a. Eq a => a -> a -> Bool
/= Text
outerTypeName
            , Just HaskellType (Expr s a)
haskellType <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find 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 (forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType))

                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 <- forall a s.
(Eq a, Pretty a) =>
[Var] -> [HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [Var]
typeParams [HaskellType (Expr s a)]
haskellTypes Expr s a
dhallFieldType

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

            [(Name, Bang, Type)]
varBangTypes <- 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 (forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList forall a b. (a -> b) -> a -> b
$ forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s a)
kts)

            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 <- forall a s.
(Eq a, Pretty a) =>
[Var] -> [HaskellType (Expr s a)] -> Expr s a -> Q Type
toNestedHaskellType [Var]
typeParams [HaskellType (Expr s a)]
haskellTypes Expr s a
dhallAlternativeType

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

        Maybe (Expr s a)
Nothing ->
            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{Text
code :: Text
typeName :: Text
typeName :: Text
code :: 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
        { forall code. HaskellType code -> Text
typeName :: Text
        -- ^ Name of the generated Haskell type
        , forall code. 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
        , forall code. HaskellType code -> Text
constructorName :: Text
        -- ^ Name of the constructor
        , code :: code
        -- ^ Dhall code that evaluates to a type
        }
    deriving (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
<$ :: forall a b. a -> HaskellType b -> HaskellType a
$c<$ :: forall a b. a -> HaskellType b -> HaskellType a
fmap :: forall a b. (a -> b) -> HaskellType a -> HaskellType b
$cfmap :: forall a b. (a -> b) -> HaskellType a -> HaskellType b
Functor, 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 :: forall a. Num a => HaskellType a -> a
$cproduct :: forall a. Num a => HaskellType a -> a
sum :: forall a. Num a => HaskellType a -> a
$csum :: forall a. Num a => HaskellType a -> a
minimum :: forall a. Ord a => HaskellType a -> a
$cminimum :: forall a. Ord a => HaskellType a -> a
maximum :: forall a. Ord a => HaskellType a -> a
$cmaximum :: forall a. Ord a => HaskellType a -> a
elem :: forall a. Eq a => a -> HaskellType a -> Bool
$celem :: forall a. Eq a => a -> HaskellType a -> Bool
length :: forall a. HaskellType a -> Int
$clength :: forall a. HaskellType a -> Int
null :: forall a. HaskellType a -> Bool
$cnull :: forall a. HaskellType a -> Bool
toList :: forall a. HaskellType a -> [a]
$ctoList :: forall a. HaskellType a -> [a]
foldl1 :: forall a. (a -> a -> a) -> HaskellType a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldr1 :: forall a. (a -> a -> a) -> HaskellType a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> HaskellType a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
fold :: forall m. Monoid m => HaskellType m -> m
$cfold :: forall m. Monoid m => HaskellType m -> m
Foldable, Functor HaskellType
Foldable HaskellType
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 :: forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
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
    , GenerateOptions -> Bool
makeStrict :: Bool
    -- ^ Make all fields strict.
    }

-- | A default set of options used by `makeHaskellTypes`. That means:
--
--     * Constructors and fields are passed unmodified.
--     * Both `FromDhall` and `ToDhall` instances are generated.
--
--   Note: `From/ToDhall` should be `False` if importing higher-kinded types.
--   In these cases one should use a standalone declaration.
defaultGenerateOptions :: GenerateOptions
defaultGenerateOptions :: GenerateOptions
defaultGenerateOptions = GenerateOptions
    { constructorModifier :: Text -> Text
constructorModifier = forall a. a -> a
id
    , fieldModifier :: Text -> Text
fieldModifier = forall a. a -> a
id
    , generateFromDhallInstance :: Bool
generateFromDhallInstance = Bool
True
    , generateToDhallInstance :: Bool
generateToDhallInstance = Bool
True
    , makeStrict :: Bool
makeStrict = Bool
False
    }

-- | 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 :: forall s a. GenerateOptions -> HaskellType (Expr s a) -> Q Exp
generateToInterpretOptions GenerateOptions{Bool
Text -> Text
makeStrict :: Bool
generateToDhallInstance :: Bool
generateFromDhallInstance :: Bool
fieldModifier :: Text -> Text
constructorModifier :: Text -> Text
makeStrict :: GenerateOptions -> Bool
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 :: forall s a. 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
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} = [Text
constructorName]
        constructors MultipleConstructors{Text
Expr s a
code :: Expr s a
typeName :: Text
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} | Union Map Text (Maybe (Expr s a))
kts <- Expr s a
code = 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 :: forall s a. 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
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} | Record Map Text (RecordField s a)
kts <- Expr s a
code = 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
typeName :: forall code. HaskellType code -> Text
code :: forall code. HaskellType code -> code
..} | Union Map Text (Maybe (Expr s a))
kts <- Expr s a
code = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ 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')) <- 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)) |]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
nameE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Match
mkMatch [Text]
xs 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 forall a b. (a -> b) -> a -> b
$ Text -> Text
f Text
n) (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Text -> Exp
textToExp Text
n) []

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

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

        textToExp :: Text -> Exp
        textToExp :: Text -> Exp
textToExp = Lit -> Exp
Syntax.LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
Syntax.StringL 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
Syntax.StringL 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
    forall a. IO a -> Q a
Syntax.runIO (TextEncoding -> IO ()
GHC.IO.Encoding.setLocaleEncoding TextEncoding
System.IO.utf8)

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

    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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'