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

module Data.Aeson.TypeScript.Recursive (
  -- * Getting declarations recursively
  getTransitiveClosure
  , getTypeScriptDeclarationsRecursively

  -- * Deriving missing instances recursively
  , recursivelyDeriveMissingTypeScriptInstancesFor
  , recursivelyDeriveMissingInstancesFor
  , deriveInstanceIfNecessary
  , doesTypeScriptInstanceExist
  , getAllParentTypes
  ) where

import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
import Data.Aeson.TypeScript.Instances ()
import Data.Aeson.TypeScript.TH
import Data.Aeson.TypeScript.Util (nothingOnFail)
import Data.Bifunctor
import Data.Function
import qualified Data.List as L
import Data.Maybe
import Data.Proxy
import qualified Data.Set as S
import Data.String.Interpolate
import Language.Haskell.TH as TH
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Syntax hiding (lift)


getTransitiveClosure :: S.Set TSType -> S.Set TSType
getTransitiveClosure :: Set TSType -> Set TSType
getTransitiveClosure = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Set TSType -> Set TSType
loop Set TSType
items ->
  let items' :: Set TSType
items' = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (Set TSType
items forall a. a -> [a] -> [a]
: [TSType -> Set TSType
getMore TSType
x | TSType
x <- forall a. Set a -> [a]
S.toList Set TSType
items])
   in if
          | Set TSType
items' forall a. Eq a => a -> a -> Bool
== Set TSType
items -> Set TSType
items
          | Bool
otherwise -> Set TSType -> Set TSType
loop Set TSType
items'

  where getMore :: TSType -> S.Set TSType
        getMore :: TSType -> Set TSType
getMore (TSType Proxy a
x) = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). TypeScript a => Proxy a -> [TSType]
getParentTypes Proxy a
x

getTypeScriptDeclarationsRecursively :: (TypeScript a) => Proxy a -> [TSDeclaration]
getTypeScriptDeclarationsRecursively :: forall {k} (a :: k). TypeScript a => Proxy a -> [TSDeclaration]
getTypeScriptDeclarationsRecursively Proxy a
initialType = forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList [TSDeclaration]
declarations
  where
    closure :: Set TSType
closure = Set TSType -> Set TSType
getTransitiveClosure (forall a. Ord a => [a] -> Set a
S.fromList [forall {k} (a :: k).
(Typeable a, TypeScript a) =>
Proxy a -> TSType
TSType Proxy a
initialType])
    declarations :: [TSDeclaration]
declarations = forall a. Monoid a => [a] -> a
mconcat [forall {k} (a :: k). TypeScript a => Proxy a -> [TSDeclaration]
getTypeScriptDeclarations Proxy a
x | TSType Proxy a
x <- forall a. Set a -> [a]
S.toList Set TSType
closure]


-- * Recursively deriving missing TypeScript interfaces

recursivelyDeriveMissingTypeScriptInstancesFor :: (Monoid w) => Name -> (Name -> Q w) -> Q w
recursivelyDeriveMissingTypeScriptInstancesFor :: forall w. Monoid w => Name -> (Name -> Q w) -> Q w
recursivelyDeriveMissingTypeScriptInstancesFor = forall w.
Monoid w =>
(Name -> Q Bool) -> Name -> (Name -> Q w) -> Q w
recursivelyDeriveMissingInstancesFor Name -> Q Bool
doesTypeScriptInstanceExist

recursivelyDeriveMissingInstancesFor :: (Monoid w) => (Name -> Q Bool) -> Name -> (Name -> Q w) -> Q w
recursivelyDeriveMissingInstancesFor :: forall w.
Monoid w =>
(Name -> Q Bool) -> Name -> (Name -> Q w) -> Q w
recursivelyDeriveMissingInstancesFor Name -> Q Bool
doesInstanceExist Name
name Name -> Q w
deriveFn = forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$ do
  forall w. Monoid w => Name -> (Name -> Q w) -> WriterT w Q ()
deriveInstanceIfNecessary Name
name Name -> Q w
deriveFn

  [Name]
names <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> (Name -> Q Bool) -> Q [Name]
getAllParentTypes Name
name Name -> Q Bool
doesInstanceExist
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
names forall a b. (a -> b) -> a -> b
$ \Name
n -> forall w. Monoid w => Name -> (Name -> Q w) -> WriterT w Q ()
deriveInstanceIfNecessary Name
n Name -> Q w
deriveFn

deriveInstanceIfNecessary :: (Monoid w) => Name -> (Name -> Q w) -> WriterT w Q ()
deriveInstanceIfNecessary :: forall w. Monoid w => Name -> (Name -> Q w) -> WriterT w Q ()
deriveInstanceIfNecessary Name
name Name -> Q w
deriveFn = do
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Q Bool
doesTypeScriptInstanceExist Name
name) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Bool
False -> do
      (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Q a -> Q (Maybe a)
nothingOnFail (Name -> Q w
deriveFn Name
name)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe w
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning [i|Failed to derive decls for name '#{name}'|]
        Just w
x -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
x

doesTypeScriptInstanceExist :: Name -> Q Bool
doesTypeScriptInstanceExist :: Name -> Q Bool
doesTypeScriptInstanceExist Name
name = do
  Maybe Bool
result :: Maybe Bool <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    (DatatypeInfo {[Type]
[TyVarBndrUnit]
[ConstructorInfo]
Name
DatatypeVariant
datatypeContext :: DatatypeInfo -> [Type]
datatypeName :: DatatypeInfo -> Name
datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons :: [ConstructorInfo]
datatypeVariant :: DatatypeVariant
datatypeInstTypes :: [Type]
datatypeVars :: [TyVarBndrUnit]
datatypeName :: Name
datatypeContext :: [Type]
..}) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. Q a -> Q (Maybe a)
nothingOnFail forall a b. (a -> b) -> a -> b
$ Name -> Q DatatypeInfo
reifyDatatype Name
name

    -- Skip names with type parameters for now
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TyVarBndrUnit]
datatypeVars forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""

    forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. Q a -> Q (Maybe a)
nothingOnFail forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q Bool
isInstance ''TypeScript [Name -> Type
ConT Name
name]

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
True Maybe Bool
result

getAllParentTypes :: Name -> (Name -> Q Bool) -> Q [Name]
getAllParentTypes :: Name -> (Name -> Q Bool) -> Q [Name]
getAllParentTypes Name
name Name -> Q Bool
pruneFn = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Name -> (Name -> Q Bool) -> StateT [Name] Q ()
getAllParentTypes' Name
name Name -> Q Bool
pruneFn) []
  where
    getAllParentTypes' :: Name -> (Name -> Q Bool) -> StateT [Name] Q ()
    getAllParentTypes' :: Name -> (Name -> Q Bool) -> StateT [Name] Q ()
getAllParentTypes' Name
nm Name -> Q Bool
pfn = (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Q a -> Q (Maybe a)
nothingOnFail forall a b. (a -> b) -> a -> b
$ Name -> Q Bool
pfn Name
nm) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Bool
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Bool
False -> (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Q a -> Q (Maybe a)
nothingOnFail (Name -> Q DatatypeInfo
reifyDatatype Name
nm)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe DatatypeInfo
Nothing -> do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning [i|Failed to reify: '#{nm}'|]
        Just (DatatypeInfo {[Type]
[TyVarBndrUnit]
[ConstructorInfo]
Name
DatatypeVariant
datatypeCons :: [ConstructorInfo]
datatypeVariant :: DatatypeVariant
datatypeInstTypes :: [Type]
datatypeVars :: [TyVarBndrUnit]
datatypeName :: Name
datatypeContext :: [Type]
datatypeContext :: DatatypeInfo -> [Type]
datatypeName :: DatatypeInfo -> Name
datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeCons :: DatatypeInfo -> [ConstructorInfo]
..}) -> do
          let parentTypes :: [Type]
parentTypes = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> [Type]
constructorFields [ConstructorInfo]
datatypeCons

          let maybeRecurse :: Name -> StateT [Name] Q ()
maybeRecurse Name
n = do
                [Name]
st <- forall s (m :: * -> *). MonadState s m => m s
get
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Name]
st) forall a b. (a -> b) -> a -> b
$ do
                  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Name
n forall a. a -> [a] -> [a]
:)
                  Name -> (Name -> Q Bool) -> StateT [Name] Q ()
getAllParentTypes' Name
n Name -> Q Bool
pfn

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Type]
parentTypes forall a b. (a -> b) -> a -> b
$ \Type
typ -> do
            let [Name]
names :: [Name] = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (Type -> State ([Name], [Type]) ()
getNamesFromType Type
typ) ([], [Type
typ])
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
names Name -> StateT [Name] Q ()
maybeRecurse

    getNamesFromType :: Type -> State ([Name], [Type]) ()
    getNamesFromType :: Type -> State ([Name], [Type]) ()
getNamesFromType (ConT Name
n) = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> [a]
addIfNotPresent Name
n)
    getNamesFromType (AppT Type
t1 Type
t2) = Type -> Type -> State ([Name], [Type]) ()
handleTwoTypes Type
t1 Type
t2
    getNamesFromType (InfixT Type
t1 Name
_ Type
t2) = Type -> Type -> State ([Name], [Type]) ()
handleTwoTypes Type
t1 Type
t2
    getNamesFromType (UInfixT Type
t1 Name
_ Type
t2) = Type -> Type -> State ([Name], [Type]) ()
handleTwoTypes Type
t1 Type
t2
    getNamesFromType Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    handleTwoTypes :: Type -> Type -> State ([Name], [Type]) ()
handleTwoTypes Type
t1 Type
t2 = do
      ([Name]
_, [Type]
visitedTypes) <- forall s (m :: * -> *). MonadState s m => m s
get
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
t1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Type]
visitedTypes) forall a b. (a -> b) -> a -> b
$ do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Type
t1 forall a. a -> [a] -> [a]
:))
        Type -> State ([Name], [Type]) ()
getNamesFromType Type
t1

      ([Name]
_, [Type]
visitedTypes') <- forall s (m :: * -> *). MonadState s m => m s
get
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
t2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Type]
visitedTypes') forall a b. (a -> b) -> a -> b
$ do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Type
t2 forall a. a -> [a] -> [a]
:))
        Type -> State ([Name], [Type]) ()
getNamesFromType Type
t2

    addIfNotPresent :: (Eq a) => a -> [a] -> [a]
    addIfNotPresent :: forall a. Eq a => a -> [a] -> [a]
addIfNotPresent a
x [a]
xs | a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [a]
xs = [a]
xs
    addIfNotPresent a
x [a]
xs = a
x forall a. a -> [a] -> [a]
: [a]
xs