{-# 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) 2018 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(..)
  , SumTypeFormat(..)
  , ExportMode(..)

  -- * Advanced options
  , 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.Types
import Data.Aeson.TypeScript.Util
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Proxy
import Data.String.Interpolate
import Data.Typeable
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'

  -- Plug in generic variables for all star free variables
  let starVars :: [Name]
starVars = [Name
name | (Type -> Maybe Name
isStarType -> Just Name
_) <- DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
datatypeInfo']
  let templateVarsToUse :: [Type]
templateVarsToUse = case [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
starVars of
        Int
1 -> [Name -> Type
ConT ''T]
        Int
_ -> Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
starVars) [Type]
allStarConstructors
  let subMap :: Map Name Type
subMap = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
starVars [Type]
templateVarsToUse
  let dti :: DatatypeInfo
dti = DatatypeInfo
datatypeInfo' { datatypeCons :: [ConstructorInfo]
datatypeCons = (ConstructorInfo -> ConstructorInfo)
-> [ConstructorInfo] -> [ConstructorInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Name Type -> ConstructorInfo -> ConstructorInfo
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subMap) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo')}

  -- 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 <- [[Type]] -> [Type]
forall a. Monoid a => [a] -> a
mconcat ([[Type]] -> [Type]) -> [[Type]] -> [Type]
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [[Type]]
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]
  let [Type]
constructorPreds' :: [Pred] = [Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
x | Type
x <- [[Type]] -> [Type]
forall a. Monoid a => [a] -> a
mconcat ([[Type]] -> [Type]) -> [[Type]] -> [Type]
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [[Type]]
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]
  let [Type]
typeVariablePreds :: [Pred] = [Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
x | Type
x <- DatatypeInfo -> [Type]
getDataTypeVars DatatypeInfo
dti]

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

  -- Build the declarations
  ([Exp]
types, [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos) <- WriterT [ExtraDeclOrGenericInfo] Q [Exp]
-> Q ([Exp], [ExtraDeclOrGenericInfo])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [ExtraDeclOrGenericInfo] Q [Exp]
 -> Q ([Exp], [ExtraDeclOrGenericInfo]))
-> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
-> Q ([Exp], [ExtraDeclOrGenericInfo])
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> [ConstructorInfo] -> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options
-> ExtraTypeScriptOptions
-> DatatypeInfo
-> [(Name, String)]
-> ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor Options
options ExtraTypeScriptOptions
extraOptions DatatypeInfo
dti [(Name, String)]
genericVariablesAndSuffixes) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dti)
  Exp
typeDeclaration <- [|TSTypeAlternatives $(TH.stringE $ getTypeName (datatypeName dti))
                                          $(genericVariablesListExpr True genericVariablesAndSuffixes)
                                          $(listE $ fmap return types)|]
  let extraDecls :: [Exp]
extraDecls = [Exp
x | ExtraDecl Exp
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos]
  let extraTopLevelDecls :: [Dec]
extraTopLevelDecls = [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat [[Dec]
x | ExtraTopLevelDecs [Dec]
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos]
  let predicates :: [Type]
predicates = [Type]
constructorPreds [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type]
constructorPreds' [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type]
typeVariablePreds [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type
x | ExtraConstraint Type
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos]

  Exp
declarationsFunctionBody <- [| $(return typeDeclaration) : $(listE (fmap return $ extraDecls)) |]

  let extraParentTypes :: [Type]
extraParentTypes = [Type
x | ExtraParentType Type
x <- [ExtraDeclOrGenericInfo]
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 <- [ExpQ] -> ExpQ
listE [ [|TSType (Proxy :: Proxy $(return t))|]
                             | Type
t <- ([[Type]] -> [Type]
forall a. Monoid a => [a] -> a
mconcat ([[Type]] -> [Type]) -> [[Type]] -> [Type]
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> [Type]
constructorFields (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo')) [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type]
extraParentTypes]
  let inst :: [Dec]
inst = [[Type] -> Type -> [Dec] -> Dec
mkInstance [Type]
predicates (Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) ((Type -> Type -> Type) -> Type -> [Type] -> Type
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) []]
                 ]]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
extraTopLevelDecls [Dec] -> [Dec] -> [Dec]
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 -> ExtraTypeScriptOptions -> DatatypeInfo -> [(Name, String)] -> ConstructorInfo -> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor :: Options
-> ExtraTypeScriptOptions
-> DatatypeInfo
-> [(Name, String)]
-> ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q Exp
handleConstructor Options
options ExtraTypeScriptOptions
extraOptions (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)]
genericVariables ci :: ConstructorInfo
ci@(ConstructorInfo {}) =
  if | ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
datatypeCons Int -> Int -> Bool
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 <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, String)] -> ExpQ
getBracketsExpression Bool
False [(Name, String)]
genericVariables
         ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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 (SumEncoding -> Bool) -> SumEncoding -> Bool
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 (SumEncoding -> Bool) -> SumEncoding -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, String)] -> ExpQ
getBracketsExpression Bool
False [(Name, String)]
genericVariables
         ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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 (SumEncoding -> Bool) -> SumEncoding -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, String)] -> ExpQ
getBracketsExpression Bool
False [(Name, String)]
genericVariables
         ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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 (SumEncoding -> Bool) -> SumEncoding -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> SumEncoding
sumEncoding Options
options -> do
         WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding
         Exp
brackets <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, String)] -> ExpQ
getBracketsExpression Bool
False [(Name, String)]
genericVariables
         ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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] <- Q [Exp] -> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Exp] -> WriterT [ExtraDeclOrGenericInfo] Q [Exp])
-> Q [Exp] -> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
forall a b. (a -> b) -> a -> b
$ case Options -> SumEncoding
sumEncoding Options
options of
           TaggedObject String
tagFieldName String
_ -> (Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: []) (Exp -> [Exp]) -> ExpQ -> Q [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|TSField False $(TH.stringE tagFieldName) $(TH.stringE [i|"#{constructorNameToUse options ci}"|])|]
           SumEncoding
_ -> [Exp] -> Q [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return []

         [Exp]
tsFields <- WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields
         Exp
decl <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
assembleInterfaceDeclaration ([Exp] -> Exp
ListE ([Exp]
tagField [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp]
tsFields))
         [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
decl]
         Exp
brackets <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> [(Name, String)] -> ExpQ
getBracketsExpression Bool
False [(Name, String)]
genericVariables
         ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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 = ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
TH.stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|]

    writeSingleConstructorEncoding :: WriterT [ExtraDeclOrGenericInfo] Q ()
writeSingleConstructorEncoding = if
      | ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
ci ConstructorVariant -> ConstructorVariant -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorVariant
NormalConstructor -> do
          Exp
encoding <- WriterT [ExtraDeclOrGenericInfo] Q Exp
tupleEncoding
          [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
encoding]
      | Bool
otherwise -> do
          [Exp]
tsFields <- WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields
          Exp
decl <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
assembleInterfaceDeclaration ([Exp] -> Exp
ListE [Exp]
tsFields)
          [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Exp -> ExtraDeclOrGenericInfo
ExtraDecl Exp
decl]

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

    tupleEncoding :: WriterT [ExtraDeclOrGenericInfo] Q Exp
tupleEncoding = do
      Type
tupleType <- ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
extraOptions (ConstructorInfo -> Type
contentsTupleType ConstructorInfo
ci)
      ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall a b. (a -> b) -> a -> b
$ [|TSTypeAlternatives $(TH.stringE interfaceName)
                                  $(genericVariablesListExpr True genericVariables)
                                  [getTypeScriptType (Proxy :: Proxy $(return tupleType))]|]

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

    getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]
    getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]
getTSFields = [(String, Type)]
-> ((String, Type) -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Options -> ConstructorInfo -> [(String, Type)]
namesAndTypes Options
options ConstructorInfo
ci) (((String, Type) -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
 -> WriterT [ExtraDeclOrGenericInfo] Q [Exp])
-> ((String, Type) -> WriterT [ExtraDeclOrGenericInfo] Q Exp)
-> WriterT [ExtraDeclOrGenericInfo] Q [Exp]
forall a b. (a -> b) -> a -> b
$ \(String
nameString, Type
typ') -> do
      Type
typ <- ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
extraOptions Type
typ'
      Bool
-> WriterT [ExtraDeclOrGenericInfo] Q ()
-> WriterT [ExtraDeclOrGenericInfo] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
typ') (WriterT [ExtraDeclOrGenericInfo] Q ()
 -> WriterT [ExtraDeclOrGenericInfo] Q ())
-> WriterT [ExtraDeclOrGenericInfo] Q ()
-> WriterT [ExtraDeclOrGenericInfo] Q ()
forall a b. (a -> b) -> a -> b
$ do
        let constraint :: Type
constraint = Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
typ
        [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Type -> ExtraDeclOrGenericInfo
ExtraConstraint Type
constraint]

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

transformTypeFamilies :: ExtraTypeScriptOptions -> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies :: ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies eo :: ExtraTypeScriptOptions
eo@(ExtraTypeScriptOptions {[Name]
typeFamiliesToMapToTypeScript :: ExtraTypeScriptOptions -> [Name]
typeFamiliesToMapToTypeScript :: [Name]
..}) (AppT (ConT Name
name) Type
typ)
  | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Name]
typeFamiliesToMapToTypeScript = Q Info -> WriterT [ExtraDeclOrGenericInfo] Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Q Info
reify Name
name) WriterT [ExtraDeclOrGenericInfo] Q Info
-> (Info -> WriterT [ExtraDeclOrGenericInfo] Q Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
eqns) [Dec]
_ -> do
        Name
name' <- Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name)
-> Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName (Name -> String
nameBase Name
typeFamilyName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'")

        Name
f <- Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name)
-> Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"f"
#if MIN_VERSION_template_haskell(2,17,0)
        let inst1 = DataD [] name' [PlainTV f ()] Nothing [] []
#else
        let inst1 :: Dec
inst1 = [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name' [Name -> TyVarBndrUnit
PlainTV Name
f] Maybe Type
forall a. Maybe a
Nothing [] []
#endif
        [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[Dec] -> ExtraDeclOrGenericInfo
ExtraTopLevelDecs [Dec
inst1]]

        [Type]
imageTypes <- Q [Type] -> WriterT [ExtraDeclOrGenericInfo] Q [Type]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Type] -> WriterT [ExtraDeclOrGenericInfo] Q [Type])
-> Q [Type] -> WriterT [ExtraDeclOrGenericInfo] Q [Type]
forall a b. (a -> b) -> a -> b
$ [TySynEqn] -> Q [Type]
getClosedTypeFamilyImage [TySynEqn]
eqns
        [Dec]
inst2 <- Q [Dec] -> WriterT [ExtraDeclOrGenericInfo] Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> WriterT [ExtraDeclOrGenericInfo] Q [Dec])
-> Q [Dec] -> WriterT [ExtraDeclOrGenericInfo] Q [Dec]
forall a b. (a -> b) -> a -> b
$ [d|instance (Typeable g, TypeScript g) => TypeScript ($(conT name') g) where
                             getTypeScriptType _ = $(TH.stringE $ nameBase name) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]"
                             getTypeScriptDeclarations _ = [$(getClosedTypeFamilyInterfaceDecl name eqns)]
                             getParentTypes _ = $(listE [ [|TSType (Proxy :: Proxy $(return x))|] | x <- imageTypes])
                        |]
        [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[Dec] -> ExtraDeclOrGenericInfo
ExtraTopLevelDecs [Dec]
inst2]

        [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Type -> ExtraDeclOrGenericInfo
ExtraParentType (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name') (Name -> Type
ConT ''T))]

        ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name') Type
typ)
      Info
_ -> Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
  | Bool
otherwise = Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
transformTypeFamilies ExtraTypeScriptOptions
eo (AppT Type
typ1 Type
typ2) = Type -> Type -> Type
AppT (Type -> Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ1 WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ2
transformTypeFamilies ExtraTypeScriptOptions
eo (SigT Type
typ Type
kind) = (Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
SigT Type
kind (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
transformTypeFamilies ExtraTypeScriptOptions
eo (InfixT Type
typ1 Name
n Type
typ2) = Type -> Name -> Type -> Type
InfixT (Type -> Name -> Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ1 WriterT [ExtraDeclOrGenericInfo] Q (Name -> Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Name
-> WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ2
transformTypeFamilies ExtraTypeScriptOptions
eo (UInfixT Type
typ1 Name
n Type
typ2) = Type -> Name -> Type -> Type
UInfixT (Type -> Name -> Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ1 WriterT [ExtraDeclOrGenericInfo] Q (Name -> Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Name
-> WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n WriterT [ExtraDeclOrGenericInfo] Q (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ2
transformTypeFamilies ExtraTypeScriptOptions
eo (ParensT Type
typ) = Type -> Type
ParensT (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
#if MIN_VERSION_template_haskell(2,15,0)
transformTypeFamilies ExtraTypeScriptOptions
eo (AppKindT Type
typ Type
kind) = (Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppKindT Type
kind (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
transformTypeFamilies ExtraTypeScriptOptions
eo (ImplicitParamT String
s Type
typ) = String -> Type -> Type
ImplicitParamT String
s (Type -> Type)
-> WriterT [ExtraDeclOrGenericInfo] Q Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo Type
typ
#endif
transformTypeFamilies ExtraTypeScriptOptions
_ Type
typ = Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ


searchForConstraints :: ExtraTypeScriptOptions -> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints :: ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints eo :: ExtraTypeScriptOptions
eo@(ExtraTypeScriptOptions {[Name]
typeFamiliesToMapToTypeScript :: [Name]
typeFamiliesToMapToTypeScript :: ExtraTypeScriptOptions -> [Name]
..}) (AppT (ConT Name
name) Type
typ) Name
var
  | Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
var Bool -> Bool -> Bool
&& (Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Name]
typeFamiliesToMapToTypeScript) = Q Info -> WriterT [GenericInfo] Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Q Info
reify Name
name) WriterT [GenericInfo] Q Info
-> (Info -> WriterT [GenericInfo] Q ())
-> WriterT [GenericInfo] Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_ -> do
        [GenericInfo] -> WriterT [GenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Name -> GenericInfoExtra -> GenericInfo
GenericInfo Name
var (Name -> GenericInfoExtra
TypeFamilyKey Name
typeFamilyName)]
        ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
      Info
_ -> ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
  | Bool
otherwise = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
searchForConstraints ExtraTypeScriptOptions
eo (AppT Type
typ1 Type
typ2) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ1 Name
var WriterT [GenericInfo] Q ()
-> WriterT [GenericInfo] Q () -> WriterT [GenericInfo] Q ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ2 Name
var
searchForConstraints ExtraTypeScriptOptions
eo (SigT Type
typ Type
_) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
searchForConstraints ExtraTypeScriptOptions
eo (InfixT Type
typ1 Name
_ Type
typ2) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ1 Name
var WriterT [GenericInfo] Q ()
-> WriterT [GenericInfo] Q () -> WriterT [GenericInfo] Q ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ2 Name
var
searchForConstraints ExtraTypeScriptOptions
eo (UInfixT Type
typ1 Name
_ Type
typ2) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ1 Name
var WriterT [GenericInfo] Q ()
-> WriterT [GenericInfo] Q () -> WriterT [GenericInfo] Q ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ2 Name
var
searchForConstraints ExtraTypeScriptOptions
eo (ParensT Type
typ) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
#if MIN_VERSION_template_haskell(2,15,0)
searchForConstraints ExtraTypeScriptOptions
eo (AppKindT Type
typ Type
_) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
searchForConstraints ExtraTypeScriptOptions
eo (ImplicitParamT String
_ Type
typ) Name
var = ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints ExtraTypeScriptOptions
eo Type
typ Name
var
#endif
searchForConstraints ExtraTypeScriptOptions
_ Type
_ Name
_ = () -> WriterT [GenericInfo] Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

hasFreeTypeVariable :: Type -> Bool
hasFreeTypeVariable :: Type -> Bool
hasFreeTypeVariable (VarT Name
_) = Bool
True
hasFreeTypeVariable (AppT Type
typ1 Type
typ2) = Type -> Bool
hasFreeTypeVariable Type
typ1 Bool -> Bool -> Bool
|| Type -> Bool
hasFreeTypeVariable Type
typ2
hasFreeTypeVariable (SigT Type
typ Type
_) = Type -> Bool
hasFreeTypeVariable Type
typ
hasFreeTypeVariable (InfixT Type
typ1 Name
_ Type
typ2) = Type -> Bool
hasFreeTypeVariable Type
typ1 Bool -> Bool -> Bool
|| Type -> Bool
hasFreeTypeVariable Type
typ2
hasFreeTypeVariable (UInfixT Type
typ1 Name
_ Type
typ2) = Type -> Bool
hasFreeTypeVariable Type
typ1 Bool -> Bool -> Bool
|| Type -> Bool
hasFreeTypeVariable Type
typ2
hasFreeTypeVariable (ParensT Type
typ) = Type -> Bool
hasFreeTypeVariable Type
typ
#if MIN_VERSION_template_haskell(2,15,0)
hasFreeTypeVariable (AppKindT Type
typ Type
_) = Type -> Bool
hasFreeTypeVariable Type
typ
hasFreeTypeVariable (ImplicitParamT String
_ Type
typ) = Type -> Bool
hasFreeTypeVariable Type
typ
#endif
hasFreeTypeVariable Type
_ = Bool
False

unifyGenericVariable :: [GenericInfo] -> String
unifyGenericVariable :: [GenericInfo] -> String
unifyGenericVariable [GenericInfo]
genericInfos = case [Name -> String
nameBase Name
name | GenericInfo Name
_ (TypeFamilyKey Name
name) <- [GenericInfo]
genericInfos] of
  [] -> String
""
  [String]
names -> String
" extends keyof " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" & " [String]
names)

-- * 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 = [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
(<>) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Options -> Name -> Q [Dec]
deriveTypeScript Options
options Name
name) Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
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 = [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
(<>) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveTypeScript' Options
options Name
name ExtraTypeScriptOptions
extraOptions) Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
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