{-# 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 (
deriveTypeScript
, deriveTypeScript'
, deriveTypeScriptLookupType
, TypeScript(..)
, TSType(..)
, TSDeclaration(TSRawDeclaration)
, formatTSDeclarations
, formatTSDeclarations'
, formatTSDeclaration
, FormattingOptions(..)
, defaultFormattingOptions
, SumTypeFormat(..)
, ExportMode(..)
, defaultExtraTypeScriptOptions
, keyType
, typeFamiliesToMapToTypeScript
, ExtraTypeScriptOptions
, 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
deriveTypeScript' :: Options
-> Name
-> ExtraTypeScriptOptions
-> 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'
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
datatypeInfo') ((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
let varsAndTVars :: [(Name, String)]
varsAndTVars = case [Name]
eligibleGenericVars of
[] -> []
[Name
x] -> [(Name
x, String
"T")]
[Name]
xs -> [Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
xs [String]
allStarConstructors''
[(Name, (String, String))]
genericVariablesAndSuffixes <- [(Name, String)]
-> ((Name, String) -> Q (Name, (String, String)))
-> Q [(Name, (String, String))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, String)]
varsAndTVars (((Name, String) -> Q (Name, (String, String)))
-> Q [(Name, (String, String))])
-> ((Name, String) -> Q (Name, (String, String)))
-> Q [(Name, (String, String))]
forall a b. (a -> b) -> a -> b
$ \(Name
var, String
tvar) -> 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
-> [(Name, (String, String))]
-> 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, String)) -> Q (Name, (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
var, ([GenericInfo] -> String
unifyGenericVariable [GenericInfo]
genericInfos, String
tvar))
((\[ConstructorInfo]
x -> (DatatypeInfo
datatypeInfo' { datatypeCons :: [ConstructorInfo]
datatypeCons = [ConstructorInfo]
x })) -> DatatypeInfo
dti, [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfosInitial) <- WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo]
-> Q ([ConstructorInfo], [ExtraDeclOrGenericInfo])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo]
-> Q ([ConstructorInfo], [ExtraDeclOrGenericInfo]))
-> WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo]
-> Q ([ConstructorInfo], [ExtraDeclOrGenericInfo])
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo]
-> (ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo)
-> WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
datatypeInfo') ((ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo)
-> WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo])
-> (ConstructorInfo
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo)
-> WriterT [ExtraDeclOrGenericInfo] Q [ConstructorInfo]
forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ci ->
((\[Type]
x -> ConstructorInfo
ci { constructorFields :: [Type]
constructorFields = [Type]
x }) ([Type] -> ConstructorInfo)
-> WriterT [ExtraDeclOrGenericInfo] Q [Type]
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (WriterT [ExtraDeclOrGenericInfo] Q [Type]
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo)
-> WriterT [ExtraDeclOrGenericInfo] Q [Type]
-> WriterT [ExtraDeclOrGenericInfo] Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ [Type]
-> (Type -> WriterT [ExtraDeclOrGenericInfo] Q Type)
-> WriterT [ExtraDeclOrGenericInfo] Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci) ((Type -> WriterT [ExtraDeclOrGenericInfo] Q Type)
-> WriterT [ExtraDeclOrGenericInfo] Q [Type])
-> (Type -> WriterT [ExtraDeclOrGenericInfo] Q Type)
-> WriterT [ExtraDeclOrGenericInfo] Q [Type]
forall a b. (a -> b) -> a -> b
$
ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
extraOptions (Type -> WriterT [ExtraDeclOrGenericInfo] Q Type)
-> (Type -> Type)
-> Type
-> WriterT [ExtraDeclOrGenericInfo] Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, (String, String))] -> Type -> Type
mapType [(Name, (String, String))]
genericVariablesAndSuffixes
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
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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 <- [[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
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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]
([Exp]
types, ([ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfosInitial [ExtraDeclOrGenericInfo]
-> [ExtraDeclOrGenericInfo] -> [ExtraDeclOrGenericInfo]
forall a. Semigroup a => a -> a -> a
<>) -> [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
-> 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])) |]
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
x | ExtraParentType Type
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos]]
let predicates :: [Type]
predicates = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
L.nub ([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])
[Dec]
keyTypeDecl <- case ExtraTypeScriptOptions -> Maybe String
keyType ExtraTypeScriptOptions
extraOptions of
Maybe String
Nothing -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just String
kt -> do
Exp
keyTypeExp <- [|$(TH.stringE kt)|]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
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) ((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] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
keyTypeDecl)]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat [[Dec]
x | ExtraTopLevelDecs [Dec]
x <- [ExtraDeclOrGenericInfo]
extraDeclsOrGenericInfos] [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
inst)
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 | ([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, String))] -> ExpQ
getBracketsExpression Bool
False [(Name, (String, 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
| (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
| 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, String))] -> ExpQ
getBracketsExpression Bool
False [(Name, (String, 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, String))] -> ExpQ
getBracketsExpression Bool
False [(Name, (String, 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, String))] -> ExpQ
getBracketsExpression Bool
False [(Name, (String, 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, String))] -> ExpQ
getBracketsExpression Bool
False [(Name, (String, 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]
#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 <- 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
$ 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) -> [|$(getTypeAsStringExp t) <> " | null"|]
Type
_ -> Type -> ExpQ
getTypeAsStringExp Type
typ
Exp
alternatives <- ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [|TSTypeAlternatives $(TH.stringE interfaceName)
$(genericVariablesListExpr True genericVariables)
[$(return stringExp)]|]
[ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
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 <- 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]
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 =
ExpQ -> WriterT [ExtraDeclOrGenericInfo] Q Exp
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 -> 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
-> [(Name, (String, String))]
-> ConstructorInfo
-> [(String, Type)]
namesAndTypes Options
options [(Name, (String, String))]
genericVariables 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
(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) |]
isSingleRecordConstructor :: ConstructorInfo -> Bool
isSingleRecordConstructor (ConstructorInfo -> ConstructorVariant
constructorVariant -> RecordConstructor [Name
x]) = Bool
True
isSingleRecordConstructor ConstructorInfo
_ = Bool
False
deriveJSONAndTypeScript :: Options
-> Name
-> 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
-> Name
-> ExtraTypeScriptOptions
-> 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)
deriveTypeScript :: Options
-> Name
-> Q [Dec]
deriveTypeScript :: Options -> Name -> Q [Dec]
deriveTypeScript Options
options Name
name = Options -> Name -> ExtraTypeScriptOptions -> Q [Dec]
deriveTypeScript' Options
options Name
name ExtraTypeScriptOptions
defaultExtraTypeScriptOptions