{-# 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.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
keyType :: ExtraTypeScriptOptions -> Maybe String
typeFamiliesToMapToTypeScript :: ExtraTypeScriptOptions -> [Name]
keyType :: Maybe String
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 [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 (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 = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name' [Name -> TyVarBndr
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]]

            Cxt
imageTypes <- Q Cxt -> WriterT [ExtraDeclOrGenericInfo] Q Cxt
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 (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))]

            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 (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 (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