{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}


module Data.Aeson.TypeScript.Transform (
  transformTypeFamilies
  ) where

import Control.Monad.Writer
import Data.Aeson.TypeScript.Lookup
import Data.Aeson.TypeScript.Types
import qualified Data.List as L
import Data.Typeable
import Language.Haskell.TH hiding (stringE)
import qualified Language.Haskell.TH.Lib as TH

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


-- | Search the given type for type families. For each one found, emit a declaration for a new
-- corresponding concrete type and a TypeScript instance for it which emits a lookup type.
-- Then, replace all occurrences of the given type family with the concrete type in the return value.
-- Thus the type becomes "de-family-ified".
transformTypeFamilies :: ExtraTypeScriptOptions -> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies :: ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies eo :: ExtraTypeScriptOptions
eo@(ExtraTypeScriptOptions {[Name]
Maybe String
String -> String
typeFamiliesToMapToTypeScript :: [Name]
keyType :: Maybe String
haddockModifier :: String -> String
typeFamiliesToMapToTypeScript :: ExtraTypeScriptOptions -> [Name]
keyType :: ExtraTypeScriptOptions -> Maybe String
haddockModifier :: ExtraTypeScriptOptions -> String -> String
..}) (AppT (ConT Name
name) Type
typ)
  | Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Name]
typeFamiliesToMapToTypeScript = Q Info -> WriterT [ExtraDeclOrGenericInfo] Q Info
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [ExtraDeclOrGenericInfo] m a
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q a
-> (a -> WriterT [ExtraDeclOrGenericInfo] Q b)
-> WriterT [ExtraDeclOrGenericInfo] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
eqns) [Dec]
_ -> Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type
handle Name
typeFamilyName [TySynEqn]
eqns

#if MIN_VERSION_template_haskell(2,15,0)
      FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
decs -> Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type
handle Name
typeFamilyName [TySynEqn
eqn | TySynInstD TySynEqn
eqn <- [Dec]
decs]
#else
      FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle typeFamilyName [eqn | TySynInstD _name eqn <- decs]
#endif

      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
        where
          handle :: Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type
          handle :: Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type
handle Name
typeFamilyName [TySynEqn]
eqns = do
            Name
name' <- Q Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [ExtraDeclOrGenericInfo] m a
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
forall (m :: * -> *). Quote m => String -> m 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 (m :: * -> *) a.
Monad m =>
m a -> WriterT [ExtraDeclOrGenericInfo] m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
#if MIN_VERSION_template_haskell(2,21,0)
            let inst1 = DataD [] name' [PlainTV f BndrReq] Nothing [] []
#elif MIN_VERSION_template_haskell(2,17,0)
            let inst1 :: Dec
inst1 = Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name' [Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f ()] Maybe Type
forall a. Maybe a
Nothing [] []
#else
            let inst1 = DataD [] name' [PlainTV f] Nothing [] []
#endif
            [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[Dec] -> ExtraDeclOrGenericInfo
ExtraTopLevelDecs [Dec
inst1]]

            Cxt
imageTypes <- Q Cxt -> WriterT [ExtraDeclOrGenericInfo] Q Cxt
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [ExtraDeclOrGenericInfo] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Cxt -> WriterT [ExtraDeclOrGenericInfo] Q Cxt)
-> Q Cxt -> WriterT [ExtraDeclOrGenericInfo] Q Cxt
forall a b. (a -> b) -> a -> b
$ [TySynEqn] -> Q Cxt
getClosedTypeFamilyImage [TySynEqn]
eqns
            [Dec]
inst2 <- Q [Dec] -> WriterT [ExtraDeclOrGenericInfo] Q [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [ExtraDeclOrGenericInfo] m a
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 ($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
name') g) where
                                 getTypeScriptType _ = $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]"
                                 getTypeScriptDeclarations _ = [$(Name -> [TySynEqn] -> Q Exp
getClosedTypeFamilyInterfaceDecl Name
name [TySynEqn]
eqns)]
                                 getParentTypes _ = $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ [|TSType (Proxy :: Proxy $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
x))|] | Type
x <- Cxt
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))]

            Type
ret <- ExtraTypeScriptOptions
-> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
transformTypeFamilies ExtraTypeScriptOptions
eo (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name') Type
typ)
            [ExtraDeclOrGenericInfo] -> WriterT [ExtraDeclOrGenericInfo] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Type -> ExtraDeclOrGenericInfo
ExtraConstraint (Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
ret)]
            Type -> WriterT [ExtraDeclOrGenericInfo] Q Type
forall a. a -> WriterT [ExtraDeclOrGenericInfo] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ret
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q (a -> b)
-> WriterT [ExtraDeclOrGenericInfo] Q a
-> WriterT [ExtraDeclOrGenericInfo] Q b
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q (a -> b)
-> WriterT [ExtraDeclOrGenericInfo] Q a
-> WriterT [ExtraDeclOrGenericInfo] Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall a. a -> WriterT [ExtraDeclOrGenericInfo] Q a
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q (a -> b)
-> WriterT [ExtraDeclOrGenericInfo] Q a
-> WriterT [ExtraDeclOrGenericInfo] Q b
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q (a -> b)
-> WriterT [ExtraDeclOrGenericInfo] Q a
-> WriterT [ExtraDeclOrGenericInfo] Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> WriterT [ExtraDeclOrGenericInfo] Q Name
forall a. a -> WriterT [ExtraDeclOrGenericInfo] Q a
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 a b.
WriterT [ExtraDeclOrGenericInfo] Q (a -> b)
-> WriterT [ExtraDeclOrGenericInfo] Q a
-> WriterT [ExtraDeclOrGenericInfo] Q b
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 a. a -> WriterT [ExtraDeclOrGenericInfo] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ