{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE LambdaCase #-}

{-|
Module:      Data.Aeson.TypeScript.TH
Copyright:   (c) 2022 Tom McLaughlin
License:     BSD3
Stability:   experimental
Portability: portable

This library provides a way to generate TypeScript @.d.ts@ files that match your existing Aeson 'A.ToJSON' instances.
If you already use Aeson's Template Haskell support to derive your instances, then deriving TypeScript is as simple as

@
$('deriveTypeScript' myAesonOptions ''MyType)
@

For example,

@
data D a = Nullary
         | Unary Int
         | Product String Char a
         | Record { testOne   :: Double
                  , testTwo   :: Bool
                  , testThree :: D a
                  } deriving Eq
@

Next we derive the necessary instances.

@
$('deriveTypeScript' ('defaultOptions' {'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower}) ''D)
@

Now we can use the newly created instances.

@
>>> putStrLn $ 'formatTSDeclarations' $ 'getTypeScriptDeclarations' (Proxy :: Proxy (D T))

type D\<T\> = INullary\<T\> | IUnary\<T\> | IProduct\<T\> | IRecord\<T\>;

interface INullary\<T\> {
  tag: "nullary";
}

interface IUnary\<T\> {
  tag: "unary";
  contents: number;
}

interface IProduct\<T\> {
  tag: "product";
  contents: [string, string, T];
}

interface IRecord\<T\> {
  tag: "record";
  One: number;
  Two: boolean;
  Three: D\<T\>;
}
@

It's important to make sure your JSON and TypeScript are being derived with the same options. For this reason, we
include the convenience 'HasJSONOptions' typeclass, which lets you write the options only once, like this:

@
instance HasJSONOptions MyType where getJSONOptions _ = ('defaultOptions' {'fieldLabelModifier' = 'drop' 4})

$('deriveJSON' ('getJSONOptions' (Proxy :: Proxy MyType)) ''MyType)
$('deriveTypeScript' ('getJSONOptions' (Proxy :: Proxy MyType)) ''MyType)
@

Or, if you want to be even more concise and don't mind defining the instances in the same file,

@
myOptions = 'defaultOptions' {'fieldLabelModifier' = 'drop' 4}

$('deriveJSONAndTypeScript' myOptions ''MyType)
@

Remembering that the Template Haskell 'Q' monad is an ordinary monad, you can derive instances for several types at once like this:

@
$('mconcat' \<$\> 'traverse' ('deriveJSONAndTypeScript' myOptions) [''MyType1, ''MyType2, ''MyType3])
@

Once you've defined all necessary instances, you can write a main function to dump them out into a @.d.ts@ file. For example:

@
main = putStrLn $ 'formatTSDeclarations' (
  ('getTypeScriptDeclarations' (Proxy :: Proxy MyType1)) <>
  ('getTypeScriptDeclarations' (Proxy :: Proxy MyType2)) <>
  ...
)
@

-}

module Data.Aeson.TypeScript.TH (
  deriveTypeScript
  , deriveTypeScript'
  , deriveTypeScriptLookupType

  -- * The main typeclass
  , TypeScript(..)
  , TSType(..)

  , TSDeclaration(TSRawDeclaration)

  -- * Formatting declarations
  , formatTSDeclarations
  , formatTSDeclarations'
  , formatTSDeclaration
  , FormattingOptions(..)
  , defaultFormattingOptions
  , SumTypeFormat(..)
  , ExportMode(..)

  -- * Advanced options
  , defaultExtraTypeScriptOptions
  , keyType
  , typeFamiliesToMapToTypeScript
  , ExtraTypeScriptOptions

  -- * Convenience tools
  , HasJSONOptions(..)
  , deriveJSONAndTypeScript
  , deriveJSONAndTypeScript'

  , T(..)
  , T1(..)
  , T2(..)
  , T3(..)

  , module Data.Aeson.TypeScript.Instances
  ) where

import Control.Monad
import Control.Monad.Writer
import Data.Aeson as A
import Data.Aeson.TH as A
import Data.Aeson.TypeScript.Formatting
import Data.Aeson.TypeScript.Instances ()
import Data.Aeson.TypeScript.Lookup
import Data.Aeson.TypeScript.Transform
import Data.Aeson.TypeScript.TypeManipulation
import Data.Aeson.TypeScript.Types
import Data.Aeson.TypeScript.Util
import qualified Data.List as L
import Data.Maybe
import Data.Proxy
import Data.String.Interpolate
import Language.Haskell.TH hiding (stringE)
import Language.Haskell.TH.Datatype
import qualified Language.Haskell.TH.Lib as TH

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif

-- | Generates a 'TypeScript' instance declaration for the given data type.
deriveTypeScript' :: Options
                  -- ^ Encoding options.
                  -> Name
                  -- ^ Name of the type for which to generate a 'TypeScript' instance declaration.
                  -> ExtraTypeScriptOptions
                  -- ^ Extra options to control advanced features.
                  -> Q [Dec]
deriveTypeScript' :: Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveTypeScript' Options
options Name
name ExtraTypeScriptOptions
extraOptions = do
  DatatypeInfo
datatypeInfo' <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  DatatypeInfo -> Q ()
assertExtensionsTurnedOn DatatypeInfo
datatypeInfo'

  -- Figure out what the generic variables are
  let eligibleGenericVars :: [Name]
eligibleGenericVars = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
datatypeInfo') forall a b. (a -> b) -> a -> b
$ \case
        SigT (VarT Name
n) Type
StarT -> forall a. a -> Maybe a
Just Name
n
        Type
_ -> forall a. Maybe a
Nothing
  let varsAndTVars :: [(Name, String)]
varsAndTVars = case [Name]
eligibleGenericVars of
        [] -> []
        [Name
x] -> [(Name
x, String
"T")]
        [Name]
xs -> forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
xs [String]
allStarConstructors''
  [(Name, (String, String))]
genericVariablesAndSuffixes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, String)]
varsAndTVars forall a b. (a -> b) -> a -> b
$ \(Name
var, String
tvar) -> do
    (()
_, [GenericInfo]
genericInfos) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo') forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ci ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Options
-> [(Name, (String, String))]
-> ConstructorInfo
-> [(String, Type)]
namesAndTypes Options
options [] ConstructorInfo
ci) forall a b. (a -> b) -> a -> b
$ \(String
_, Type
typ) -> do
        ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
extraOptions Type
typ Name
var
    forall (m :: * -> *) a. Monad m => a -> m a
return (Name
var, ([GenericInfo] -> String
unifyGenericVariable [GenericInfo]
genericInfos, String
tvar))

  -- Plug in generic variables and de-family-ify
  ((\[ConstructorInfo]
x -> (DatatypeInfo
datatypeInfo' { datatypeCons :: [ConstructorInfo]
datatypeCons = [ConstructorInfo]
x })) -> DatatypeInfo
dti, [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfosInitial) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo') forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ci ->
    ((\[Type]
x -> ConstructorInfo
ci { constructorFields :: [Type]
constructorFields = [Type]
x }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci) forall a b. (a -> b) -> a -> b
$
      ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
extraOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, (String, String))] -> Type -> Type
mapType [(Name, (String, String))]
genericVariablesAndSuffixes

  -- Build constraints: a TypeScript constraint for every constructor type and one for every type variable.
  -- Probably overkill/not exactly right, but it's a start.
  let [Type]
constructorPreds :: [Pred] = [Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
x | Type
x <- forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> [Type]
constructorFields (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dti)
                                                               , Type -> Bool
hasFreeTypeVariable Type
x
                                                               , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Bool
coveredByDataTypeVars (DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
dti) Type
x
                                                               ]
  let [Type]
constructorPreds' :: [Pred] = [Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
x | Type
x <- forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> [Type]
constructorFields (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo')
                                                                , Type -> Bool
hasFreeTypeVariable Type
x
                                                                , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Bool
coveredByDataTypeVars (DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
dti) Type
x
                                                                ]
  let [Type]
typeVariablePreds :: [Pred] = [Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
x | Type
x <- DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
dti]

  -- Build the declarations
  ([Exp]
types, ([ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfosInitial forall a. Semigroup a => a -> a -> a
<>) -> [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options
-> DatatypeInfo
-> [(Name, (String, String))]
-> ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor Options
options DatatypeInfo
dti [(Name, (String, String))]
genericVariablesAndSuffixes) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dti)
  Exp
typeDeclaration <- [|TSTypeAlternatives $(TH.stringE $ getTypeName (datatypeName dti))
                                          $(genericVariablesListExpr True genericVariablesAndSuffixes)
                                          $(listE $ fmap return types)|]

  Exp
declarationsFunctionBody <- [| $(return typeDeclaration) : $(listE (fmap return [x | ExtraDecl x <- extraDeclsOrGenericInfos])) |]

  -- Couldn't figure out how to put the constraints for "instance TypeScript..." in the quasiquote above without
  -- introducing () when the constraints are empty, which causes "illegal tuple constraint" unless the user enables ConstraintKinds.
  -- So, just use our mkInstance function
  Exp
getTypeScriptTypeExp <- [|$(TH.stringE $ getTypeName (datatypeName dti)) <> $(getBracketsExpressionAllTypesNoSuffix genericVariablesAndSuffixes)|]
  Exp
getParentTypesExp <- forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ [|TSType (Proxy :: Proxy $(return t))|]
                             | Type
t <- (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> [Type]
constructorFields (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo')) forall a. Semigroup a => a -> a -> a
<> [Type
x | ExtraParentType Type
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos]]
  let predicates :: [Type]
predicates = forall a. Eq a => [a] -> [a]
L.nub ([Type]
constructorPreds forall a. Semigroup a => a -> a -> a
<> [Type]
constructorPreds' forall a. Semigroup a => a -> a -> a
<> [Type]
typeVariablePreds forall a. Semigroup a => a -> a -> a
<> [Type
x | ExtraConstraint Type
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos])
  [Dec]
keyTypeDecl <- case ExtraTypeScriptOptions -> Maybe String
keyType ExtraTypeScriptOptions
extraOptions of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
kt -> do
      Exp
keyTypeExp <- [|$(TH.stringE kt)|]
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name -> [Clause] -> Dec
FunD 'getTypeScriptKeyType [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
keyTypeExp) []]]
  let inst :: [Dec]
inst = [[Type] -> Type -> [Dec] -> Dec
mkInstance [Type]
predicates (Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) (DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
dti))) ([
                 Name -> [Clause] -> Dec
FunD 'getTypeScriptType [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
getTypeScriptTypeExp) []]
                 , Name -> [Clause] -> Dec
FunD 'getTypeScriptDeclarations [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
declarationsFunctionBody) []]
                 , Name -> [Clause] -> Dec
FunD 'getParentTypes [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
getParentTypesExp) []]
                 ] forall a. Semigroup a => a -> a -> a
<> [Dec]
keyTypeDecl)]
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => [a] -> a
mconcat [[Dec]
x | ExtraTopLevelDecs [Dec]
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos] forall a. Semigroup a => a -> a -> a
<> [Dec]
inst)

-- | Return a string to go in the top-level type declaration, plus an optional expression containing a declaration
handleConstructor :: Options -> DatatypeInfo -> [(Name, (Suffix, Var))] -> ConstructorInfo -> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor :: Options
-> DatatypeInfo
-> [(Name, (String, String))]
-> ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor Options
options (DatatypeInfo {[Type]
[TyVarBndrUnit]
[ConstructorInfo]
Name
DatatypeVariant
datatypeContext :: DatatypeInfo -> [Type]
datatypeName :: DatatypeInfo -> Name
datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeCons :: [ConstructorInfo]
datatypeVariant :: DatatypeVariant
datatypeInstTypes :: [Type]
datatypeVars :: [TyVarBndrUnit]
datatypeName :: Name
datatypeContext :: [Type]
datatypeCons :: DatatypeInfo -> [ConstructorInfo]
..}) [(Name, (String, String))]
genericVariables ConstructorInfo
ci = do
  if | (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
datatypeCons forall a. Eq a => a -> a -> Bool
== Int
1) Bool -> Bool -> Bool
&& Bool -> Bool
not (Options -> Bool
getTagSingleConstructors Options
options) -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, (String, String))] -> Q Exp
getBracketsExpression Bool
False [(Name, (String, String))]
genericVariables
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|$(TH.stringE interfaceName) <> $(return brackets)|]
     | [ConstructorInfo] -> Bool
allConstructorsAreNullary [ConstructorInfo]
datatypeCons Bool -> Bool -> Bool
&& Options -> Bool
allNullaryToStringTag Options
options -> WriterT [ExtraDeclOrGenericInfo] Q Exp
stringEncoding

     -- With UntaggedValue, nullary constructors are encoded as strings
     | (SumEncoding -> Bool
isUntaggedValue forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options) Bool -> Bool -> Bool
&& ConstructorInfo -> Bool
isConstructorNullary ConstructorInfo
ci -> WriterT [ExtraDeclOrGenericInfo] Q Exp
stringEncoding

     -- Treat as a sum
     | SumEncoding -> Bool
isObjectWithSingleField forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, (String, String))] -> Q Exp
getBracketsExpression Bool
False [(Name, (String, String))]
genericVariables
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|"{" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ": " <> $(TH.stringE interfaceName) <> $(return brackets) <> "}"|]
     | SumEncoding -> Bool
isTwoElemArray forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, (String, String))] -> Q Exp
getBracketsExpression Bool
False [(Name, (String, String))]
genericVariables
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|"[" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ", " <> $(TH.stringE interfaceName) <> $(return brackets) <> "]"|]
     | SumEncoding -> Bool
isUntaggedValue forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, (String, String))] -> Q Exp
getBracketsExpression Bool
False [(Name, (String, String))]
genericVariables
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|$(TH.stringE interfaceName) <> $(return brackets)|]
     | Bool
otherwise -> do
         [Exp]
tagField :: [Exp] <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ case Options -> SumEncoding
sumEncoding Options
options of
           TaggedObject String
tagFieldName String
_ -> (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|TSField False $(TH.stringE tagFieldName) $(TH.stringE [i|"#{constructorNameToUse options ci}"|])|]
           SumEncoding
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []

         [Exp]
tsFields <- WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields
         Exp
decl <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
assembleInterfaceDeclaration ([Exp] -> Exp
ListE ([Exp]
tagField forall a. [a] -> [a] -> [a]
++ [Exp]
tsFields))
         forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
decl]
         Exp
brackets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, (String, String))] -> Q Exp
getBracketsExpression Bool
False [(Name, (String, String))]
genericVariables
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|$(TH.stringE interfaceName) <> $(return brackets)|]

  where
    stringEncoding :: WriterT [ExtraDeclOrGenericInfo] Q Exp
stringEncoding = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|]

    writeSingleConstructorEncoding :: WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding = if
      | ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
ci forall a. Eq a => a -> a -> Bool
== ConstructorVariant
NormalConstructor -> do
          Exp
encoding <- WriterT [ExtraDeclOrGenericInfo] Q Exp
tupleEncoding
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
encoding]

#if MIN_VERSION_aeson(0,10,0)
      | Options -> Bool
unwrapUnaryRecords Options
options Bool -> Bool -> Bool
&& (ConstructorInfo -> Bool
isSingleRecordConstructor ConstructorInfo
ci) -> do
          let [Type
typ] = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci
          Exp
stringExp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ case Type
typ of
            (AppT (ConT Name
name) Type
t) | Name
name forall a. Eq a => a -> a -> Bool
== ''Maybe Bool -> Bool -> Bool
&& Bool -> Bool
not (Options -> Bool
omitNothingFields Options
options) -> [|$(getTypeAsStringExp t) <> " | null"|]
            Type
_ -> Type -> Q Exp
getTypeAsStringExp Type
typ
          Exp
alternatives <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|TSTypeAlternatives $(TH.stringE interfaceName)
                                                    $(genericVariablesListExpr True genericVariables)
                                                    [$(return stringExp)]|]
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
alternatives]
#endif

      | Bool
otherwise -> do
          [Exp]
tsFields <- WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields
          Exp
decl <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
assembleInterfaceDeclaration ([Exp] -> Exp
ListE [Exp]
tsFields)
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
decl]

    -- * Type declaration to use
    interfaceName :: String
interfaceName = String
"I" forall a. Semigroup a => a -> a -> a
<> (Name -> String
lastNameComponent' forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName ConstructorInfo
ci)

    tupleEncoding :: WriterT [ExtraDeclOrGenericInfo] Q Exp
tupleEncoding =
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|TSTypeAlternatives $(TH.stringE interfaceName)
                                $(genericVariablesListExpr True genericVariables)
                                [getTypeScriptType (Proxy :: Proxy $(return (contentsTupleTypeSubstituted genericVariables ci)))]|]

    assembleInterfaceDeclaration :: Exp -> Q Exp
assembleInterfaceDeclaration Exp
members = [|TSInterfaceDeclaration $(TH.stringE interfaceName)
                                                                    $(genericVariablesListExpr True genericVariables)
                                                                    $(return members)|]

    getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]
    getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Options
-> [(Name, (String, String))]
-> ConstructorInfo
-> [(String, Type)]
namesAndTypes Options
options [(Name, (String, String))]
genericVariables ConstructorInfo
ci) forall a b. (a -> b) -> a -> b
$ \(String
nameString, Type
typ) -> do
      (Exp
fieldTyp, Exp
optAsBool) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ case Type
typ of
        (AppT (ConT Name
name) Type
t) | Name
name forall a. Eq a => a -> a -> Bool
== ''Maybe Bool -> Bool -> Bool
&& Bool -> Bool
not (Options -> Bool
omitNothingFields Options
options) ->
          ( , ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|$(getTypeAsStringExp t) <> " | null"|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Exp
getOptionalAsBoolExp Type
t
        Type
_ -> ( , ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Exp
getTypeAsStringExp Type
typ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Exp
getOptionalAsBoolExp Type
typ
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [| TSField $(return optAsBool) $(TH.stringE nameString) $(return fieldTyp) |]

    isSingleRecordConstructor :: ConstructorInfo -> Bool
isSingleRecordConstructor (ConstructorInfo -> ConstructorVariant
constructorVariant -> RecordConstructor [Name
x]) = Bool
True
    isSingleRecordConstructor ConstructorInfo
_ = Bool
False

-- * Convenience functions

-- | Convenience function to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instances simultaneously, so the instances are guaranteed to be in sync.
--
-- This function is given mainly as an illustration.
-- If you want some other permutation of instances, such as 'A.ToJSON' and 'A.TypeScript' only, just take a look at the source and write your own version.
--
-- @since 0.1.0.4
deriveJSONAndTypeScript :: Options
                        -- ^ Encoding options.
                        -> Name
                        -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations.
                        -> Q [Dec]
deriveJSONAndTypeScript :: Options -> Name -> Q [Dec]
deriveJSONAndTypeScript Options
options Name
name = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Options -> Name -> Q [Dec]
deriveTypeScript Options
options Name
name) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Options -> Name -> Q [Dec]
A.deriveJSON Options
options Name
name)

deriveJSONAndTypeScript' :: Options
                         -- ^ Encoding options.
                         -> Name
                         -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations.
                         -> ExtraTypeScriptOptions
                         -- ^ Extra options to control advanced features.
                         -> Q [Dec]
deriveJSONAndTypeScript' :: Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveJSONAndTypeScript' Options
options Name
name ExtraTypeScriptOptions
extraOptions = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveTypeScript' Options
options Name
name ExtraTypeScriptOptions
extraOptions) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Options -> Name -> Q [Dec]
A.deriveJSON Options
options Name
name)

-- | Generates a 'TypeScript' instance declaration for the given data type.
deriveTypeScript :: Options
                 -- ^ Encoding options.
                 -> Name
                 -- ^ Name of the type for which to generate a 'TypeScript' instance declaration.
                 -> Q [Dec]
deriveTypeScript :: Options -> Name -> Q [Dec]
deriveTypeScript Options
options Name
name = Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveTypeScript' Options
options Name
name ExtraTypeScriptOptions
defaultExtraTypeScriptOptions