{-# 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(..)
, SumTypeFormat(..)
, ExportMode(..)
, 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.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
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 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')}
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)
([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]
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)
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
| (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)] -> 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]
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)
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