{-# 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 Control.Monad             (forM_)
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 Lens.Family               (view)
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.Import
import qualified Dhall.Map
import qualified Dhall.Pretty
import qualified Dhall.Util
import qualified GHC.IO.Encoding
import qualified Language.Haskell.TH.Syntax  as TH
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
TH.runIO (TextEncoding -> IO ()
GHC.IO.Encoding.setLocaleEncoding TextEncoding
System.IO.utf8)

    (Expr Src Void
expression, Status
status) <- IO (Expr Src Void, Status) -> Q (Expr Src Void, Status)
forall a. IO a -> Q a
TH.runIO (IO (Expr Src Void, Status) -> Q (Expr Src Void, Status))
-> IO (Expr Src Void, Status) -> Q (Expr Src Void, Status)
forall a b. (a -> b) -> a -> b
$ do
        Expr Src Import
parsed <- InputSettings -> Text -> IO (Expr Src Import)
forall (m :: * -> *).
MonadThrow m =>
InputSettings -> Text -> m (Expr Src Import)
Dhall.parseWithSettings InputSettings
Dhall.defaultInputSettings Text
text

        (Expr Src Void
resolved, Status
status) <- InputSettings -> Expr Src Import -> IO (Expr Src Void, Status)
Dhall.resolveAndStatusWithSettings InputSettings
Dhall.defaultInputSettings Expr Src Import
parsed

        ()
_ <- InputSettings -> Expr Src Void -> IO ()
forall (m :: * -> *).
MonadThrow m =>
InputSettings -> Expr Src Void -> m ()
Dhall.typecheckWithSettings InputSettings
Dhall.defaultInputSettings Expr Src Void
resolved

        let normalized :: Expr Src Void
normalized = InputSettings -> Expr Src Void -> Expr Src Void
Dhall.normalizeWithSettings InputSettings
Dhall.defaultInputSettings Expr Src Void
resolved

        (Expr Src Void, Status) -> IO (Expr Src Void, Status)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr Src Void
normalized, Status
status)

    [Chained] -> (Chained -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Chained ImportSemantics -> [Chained]
forall k v. Map k v -> [k]
Dhall.Map.keys (FoldLike
  (Map Chained ImportSemantics)
  Status
  Status
  (Map Chained ImportSemantics)
  (Map Chained ImportSemantics)
-> Status -> Map Chained ImportSemantics
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike
  (Map Chained ImportSemantics)
  Status
  Status
  (Map Chained ImportSemantics)
  (Map Chained ImportSemantics)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (Map Chained ImportSemantics)
Dhall.Import.cache Status
status)) ((Chained -> Q ()) -> Q ()) -> (Chained -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \Chained
chained ->
        case Chained -> Import
Dhall.Import.chainedImport Chained
chained of
            Core.Import
                { importHashed :: Import -> ImportHashed
importHashed = Core.ImportHashed
                    { importType :: ImportHashed -> ImportType
importType = Core.Local FilePrefix
prefix File
file
                    }
                } -> do
                    FilePath
fp <- FilePrefix -> File -> Q FilePath
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io FilePath
Dhall.Import.localToPath FilePrefix
prefix File
file
                    FilePath -> Q ()
TH.addDependentFile FilePath
fp
            Import
_ -> () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    (forall b. Data b => b -> Maybe (Q Exp)) -> Expr Src Void -> Q Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a b. (a -> b) -> Q a -> Q b
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
. FilePath -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => FilePath -> m Exp
TH.lift (FilePath -> Q Exp) -> (Text -> FilePath) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
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 :: FilePath -> Q Exp
quoteExp = Text -> Q Exp
staticDhallExpression (Text -> Q Exp) -> (FilePath -> Text) -> FilePath -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack
    , quotePat :: FilePath -> Q Pat
quotePat = Q Pat -> FilePath -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> FilePath -> Q Pat) -> Q Pat -> FilePath -> Q Pat
forall a b. (a -> b) -> a -> b
$ FilePath -> Q Pat
forall a. HasCallStack => FilePath -> a
error FilePath
"dhall quasi-quoter: Quoting patterns is not supported!"
    , quoteType :: FilePath -> Q Type
quoteType = Q Type -> FilePath -> Q Type
forall a b. a -> b -> a
const (Q Type -> FilePath -> Q Type) -> Q Type -> FilePath -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Q Type
forall a. HasCallStack => FilePath -> a
error FilePath
"dhall quasi-quoter: Quoting types is not supported!"
    , quoteDec :: FilePath -> Q [Dec]
quoteDec = Q [Dec] -> FilePath -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> FilePath -> Q [Dec]) -> Q [Dec] -> FilePath -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ FilePath -> Q [Dec]
forall a. HasCallStack => FilePath -> a
error FilePath
"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 = Expr s a -> Q Type
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 = Expr s a -> Expr t 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 t a
dhallType

    document :: a -> Doc Ann
document a
dhallType =
      [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
"• ❰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
" " Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc Ann
forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert 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."
      ]

    message :: a -> FilePath
message a
dhallType = SimpleDocStream Ann -> FilePath
forall ann. SimpleDocStream ann -> FilePath
Pretty.renderString (Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout (a -> Doc Ann
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 ->
            Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT ''Bool)

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

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

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

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

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

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

        Expr t a
TimeZone ->
            Type -> m Type
forall a. a -> m a
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

            Type -> m Type
forall a. a -> m a
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

            Type -> m Type
forall a. a -> m a
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

            Type -> m Type
forall a. a -> m a
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) <- (Var -> Bool) -> [Var] -> Maybe Var
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
==) [Var]
typeParams -> do
                let name :: Name
name = FilePath -> Name
TH.mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ (Text -> FilePath
Text.unpack Text
param) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
index)

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

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

        Expr t 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 (Expr t a -> HaskellType (Expr s a) -> Bool
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 = FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack (HaskellType (Expr s a) -> Text
forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType))

                Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
name)
            | Bool
otherwise -> FilePath -> m Type
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m Type) -> FilePath -> m Type
forall a b. (a -> b) -> a -> b
$ Expr t a -> FilePath
forall {a}. Pretty a => a -> FilePath
message Expr t 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
    :: TH.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 $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
n) where
        autoWith = Dhall.genericAutoWithInputNormalizer $(Q Exp
interpretOptions)
    |]

-- | Generates a `ToDhall` instances.
toDhallInstance
    :: TH.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 $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
n) where
        injectWith = Dhall.genericToDhallWithInputNormalizer $(Q Exp
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
constructorModifier :: Text -> Text
fieldModifier :: Text -> Text
generateFromDhallInstance :: Bool
generateToDhallInstance :: Bool
makeStrict :: Bool
constructorModifier :: GenerateOptions -> Text -> Text
fieldModifier :: GenerateOptions -> Text -> Text
generateFromDhallInstance :: GenerateOptions -> Bool
generateToDhallInstance :: GenerateOptions -> Bool
makeStrict :: GenerateOptions -> Bool
..} [HaskellType (Expr s a)]
haskellTypes HaskellType (Expr s a)
typ =
    case HaskellType (Expr s a)
typ of
        SingleConstructor{Text
Expr s a
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
typeName :: Text
constructorName :: Text
code :: Expr s a
constructorName :: forall code. HaskellType code -> Text
..} -> ([Var] -> Expr s a -> Q [Dec]) -> ([Var], Expr s a) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> Text -> [Var] -> Expr s a -> Q [Dec]
fromSingle Text
typeName Text
constructorName) (([Var], Expr s a) -> Q [Dec]) -> ([Var], Expr s a) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Expr s a -> ([Var], Expr s a)
forall {s} {a}. Expr s a -> ([Var], Expr s a)
getTypeParams Expr s a
code
        MultipleConstructors{Text
Expr s a
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
typeName :: Text
code :: Expr s a
..} -> ([Var] -> Expr s a -> Q [Dec]) -> ([Var], Expr s a) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> [Var] -> Expr s a -> Q [Dec]
fromMulti Text
typeName) (([Var], Expr s a) -> Q [Dec]) -> ([Var], Expr s a) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Expr s a -> ([Var], Expr s a)
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 = ([Text] -> [Var]) -> ([Text], Expr s a) -> ([Var], Expr s a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Text] -> [Var]
numberConsecutive (([Text], Expr s a) -> ([Var], Expr s a))
-> (Expr s a -> ([Text], Expr s a))
-> Expr s a
-> ([Var], Expr s a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [Text] -> Expr s a -> ([Text], Expr s a)
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
vText -> [Text] -> [Text]
forall 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 = 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

#if MIN_VERSION_template_haskell(2,21,0)
        toTypeVar (V n i) = TH.PlainTV (TH.mkName (Text.unpack n ++ show i)) TH.BndrReq
#elif MIN_VERSION_template_haskell(2,17,0)
        toTypeVar :: Var -> TyVarBndr ()
toTypeVar (V Text
n Int
i) = Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV (FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack Text
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i)) ()
#else
        toTypeVar (V n i) = TH.PlainTV (TH.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 = FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack Text
typeName)

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

            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
                [[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [TyVarBndr ()]
params 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 ]

        fromSingle :: Text -> Text -> [Var] -> Expr s a -> Q [Dec]
fromSingle Text
typeName Text
constructorName [Var]
typeParams Expr s a
dhallType = do
            Con
constructor <- [Var]
-> GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
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, Expr s a -> Maybe (Expr s a)
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 <- ((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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Var]
-> GenerateOptions
-> [HaskellType (Expr s a)]
-> Text
-> (Text, Maybe (Expr s a))
-> Q Con
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) (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)

                Text -> [Var] -> [Con] -> Q [Dec]
toDataD Text
typeName [Var]
typeParams [Con]
constructors

            Expr s a
_ -> FilePath -> Q [Dec]
forall a. FilePath -> Q a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q [Dec]) -> FilePath -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Expr s a -> FilePath
forall {a}. Pretty a => a -> FilePath
message Expr s a
dhallType

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

        document :: a -> Doc Ann
document a
dhallType =
            [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
<> a -> Doc Ann
forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert a
dhallType 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."
                ]

-- | Number each variable, starting at 0
numberConsecutive :: [Text.Text] -> [Var]
numberConsecutive :: [Text] -> [Var]
numberConsecutive = (Map Text Int, [Var]) -> [Var]
forall a b. (a, b) -> b
snd ((Map Text Int, [Var]) -> [Var])
-> ([Text] -> (Map Text Int, [Var])) -> [Text] -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text Int -> Text -> (Map Text Int, Var))
-> Map Text Int -> [Text] -> (Map Text Int, [Var])
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 Map Text Int
forall k a. Map k a
Map.empty ([Text] -> (Map Text Int, [Var]))
-> ([Text] -> [Text]) -> [Text] -> (Map Text Int, [Var])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
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') = (Text -> Int -> Maybe Int)
-> Text -> Map Text Int -> (Maybe Int, Map Text Int)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Text
_ Int
j -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
k Map Text Int
m
          in (Map Text Int, Var)
-> (Int -> (Map Text Int, Var)) -> Maybe Int -> (Map Text Int, Var)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Text -> Int -> Map Text Int -> Map Text Int
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
constructorModifier :: GenerateOptions -> Text -> Text
fieldModifier :: GenerateOptions -> Text -> Text
generateFromDhallInstance :: GenerateOptions -> Bool
generateToDhallInstance :: GenerateOptions -> Bool
makeStrict :: GenerateOptions -> Bool
constructorModifier :: Text -> Text
fieldModifier :: Text -> Text
generateFromDhallInstance :: Bool
generateToDhallInstance :: Bool
makeStrict :: Bool
..} [HaskellType (Expr s a)]
haskellTypes Text
outerTypeName (Text
constructorName, Maybe (Expr s a)
maybeAlternativeType) = do
    let name :: Name
name = FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
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 =
                    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 =
                        FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack (HaskellType (Expr s a) -> Text
forall code. HaskellType code -> Text
typeName HaskellType (Expr s a)
haskellType))

                Con -> Q Con
forall a. a -> Q a
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 <- [Var] -> [HaskellType (Expr s a)] -> Expr s a -> Q Type
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

                    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Name
TH.mkName (Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 a. a -> Q a
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 <- [Var] -> [HaskellType (Expr s a)] -> Expr s a -> Q Type
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

            Con -> Q Con
forall a. a -> Q a
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 a. a -> Q a
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 -> 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
$cfmap :: forall a b. (a -> b) -> HaskellType a -> HaskellType b
fmap :: forall a b. (a -> b) -> HaskellType a -> HaskellType b
$c<$ :: forall a b. a -> HaskellType b -> HaskellType a
<$ :: forall a b. a -> HaskellType b -> HaskellType a
Functor, (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
$cfold :: forall m. Monoid m => HaskellType m -> m
fold :: forall m. Monoid m => HaskellType m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> HaskellType a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> HaskellType a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldr1 :: forall a. (a -> a -> a) -> HaskellType a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HaskellType a -> a
foldl1 :: forall a. (a -> a -> a) -> HaskellType a -> a
$ctoList :: forall a. HaskellType a -> [a]
toList :: forall a. HaskellType a -> [a]
$cnull :: forall a. HaskellType a -> Bool
null :: forall a. HaskellType a -> Bool
$clength :: forall a. HaskellType a -> Int
length :: forall a. HaskellType a -> Int
$celem :: forall a. Eq a => a -> HaskellType a -> Bool
elem :: forall a. Eq a => a -> HaskellType a -> Bool
$cmaximum :: forall a. Ord a => HaskellType a -> a
maximum :: forall a. Ord a => HaskellType a -> a
$cminimum :: forall a. Ord a => HaskellType a -> a
minimum :: forall a. Ord a => HaskellType a -> a
$csum :: forall a. Num a => HaskellType a -> a
sum :: forall a. Num a => HaskellType a -> a
$cproduct :: forall a. Num a => HaskellType a -> a
product :: forall a. Num a => HaskellType a -> a
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
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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HaskellType (f a) -> f (HaskellType a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HaskellType a -> m (HaskellType b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HaskellType (m a) -> m (HaskellType a)
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 = 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
    , 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
constructorModifier :: GenerateOptions -> Text -> Text
fieldModifier :: GenerateOptions -> Text -> Text
generateFromDhallInstance :: GenerateOptions -> Bool
generateToDhallInstance :: GenerateOptions -> Bool
makeStrict :: GenerateOptions -> Bool
constructorModifier :: Text -> Text
fieldModifier :: Text -> Text
generateFromDhallInstance :: Bool
generateToDhallInstance :: Bool
makeStrict :: Bool
..} HaskellType (Expr s a)
haskellType = [| Dhall.InterpretOptions
    { Dhall.fieldModifier = \ $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
nameP) ->
        $((Text -> Text) -> [Text] -> Q Exp
toCases Text -> Text
fieldModifier ([Text] -> Q Exp) -> [Text] -> Q Exp
forall a b. (a -> b) -> a -> b
$ HaskellType (Expr s a) -> [Text]
forall s a. HaskellType (Expr s a) -> [Text]
fields HaskellType (Expr s a)
haskellType)
    , Dhall.constructorModifier = \ $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
nameP) ->
        $((Text -> Text) -> [Text] -> Q Exp
toCases Text -> Text
constructorModifier ([Text] -> Q Exp) -> [Text] -> Q Exp
forall a b. (a -> b) -> a -> b
$ HaskellType (Expr s a) -> [Text]
forall s a. HaskellType (Expr s a) -> [Text]
constructors HaskellType (Expr s a)
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 :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
constructorName :: forall code. HaskellType code -> Text
typeName :: Text
constructorName :: Text
code :: Expr s a
..} = [Text
constructorName]
        constructors MultipleConstructors{Text
Expr s a
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
typeName :: Text
code :: Expr s a
..} | 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 :: forall s a. HaskellType (Expr s a) -> [Text]
fields SingleConstructor{Text
Expr s a
code :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
constructorName :: forall code. HaskellType code -> Text
typeName :: Text
constructorName :: Text
code :: Expr s a
..} | 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 :: forall code. HaskellType code -> code
typeName :: forall code. HaskellType code -> Text
typeName :: Text
code :: Expr s a
..} | 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 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
nameE)) |]
            Exp -> Q Exp
forall a. a -> Q a
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
TH.VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
TH.mkName FilePath
"n"

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

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

        textToPat :: Text -> Pat
        textToPat :: Text -> Pat
textToPat = Lit -> Pat
TH.LitP (Lit -> Pat) -> (Text -> Lit) -> Text -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
TH.StringL (FilePath -> Lit) -> (Text -> FilePath) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
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
TH.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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HaskellType a -> f (HaskellType b)
traverse (IO (Expr Src Void) -> Q (Expr Src Void)
forall a. IO a -> Q a
TH.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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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'