{-# 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.TypeManipulation (
  searchForConstraints
  , hasFreeTypeVariable
  , unifyGenericVariable
  ) where

import Control.Monad.Writer
import Data.Aeson.TypeScript.Types
import qualified Data.List as L
import Language.Haskell.TH

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


searchForConstraints :: ExtraTypeScriptOptions -> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints :: ExtraTypeScriptOptions
-> Type -> Name -> WriterT [GenericInfo] Q ()
searchForConstraints 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
var
  | Type
typ forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
var Bool -> Bool -> Bool
&& (Name
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Name]
typeFamiliesToMapToTypeScript) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Q Info
reify Name
name) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_ -> do
        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
      FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
typeFamilyName [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_ -> do
        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 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 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 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
_ = 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 " forall a. Semigroup a => a -> a -> a
<> (forall a. [a] -> [[a]] -> [a]
L.intercalate String
" & " [String]
names)