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

module Data.Aeson.TypeScript.Lookup where

import Control.Monad
import Data.Aeson.TypeScript.Instances ()
import Data.Aeson.TypeScript.Types
import Data.Function
import qualified Data.List as L
import Data.Proxy
import Data.String.Interpolate
import Language.Haskell.TH hiding (stringE)
import qualified Language.Haskell.TH.Lib as TH


-- | Generates a 'TypeScript' declaration for a closed type family as a lookup type.
deriveTypeScriptLookupType :: Name
                           -- ^ Name of a type family.
                           -> String
                           -- ^ Name of the declaration to derive.
                           -> Q [Dec]
deriveTypeScriptLookupType :: Name -> String -> Q [Dec]
deriveTypeScriptLookupType Name
name String
declNameStr = do
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
    FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_name [TyVarBndr ()]
_vars FamilyResultSig
_sig Maybe InjectivityAnn
_maybeInject) [TySynEqn]
eqns) [Dec]
_decs -> do
      Exp
interfaceDecl <- Name -> [TySynEqn] -> Q Exp
getClosedTypeFamilyInterfaceDecl Name
name [TySynEqn]
eqns
      [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
declNameStr) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ([Exp] -> Exp
ListE [Exp
interfaceDecl])) []]]

    Info
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail [i|Expected a close type family; got #{info}|]

getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp
getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp
getClosedTypeFamilyInterfaceDecl Name
name [TySynEqn]
eqns = do
  [Exp]
fields <- [TySynEqn] -> (TySynEqn -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TySynEqn]
eqns ((TySynEqn -> Q Exp) -> Q [Exp]) -> (TySynEqn -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \case
#if MIN_VERSION_template_haskell(2,15,0)
    TySynEqn Maybe [TyVarBndr ()]
Nothing (AppT (ConT Name
_) (ConT Name
arg)) Type
result -> do
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
arg))) (getTypeScriptType (Proxy :: Proxy $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
result))) Nothing |]
    TySynEqn Maybe [TyVarBndr ()]
Nothing (AppT (ConT Name
_) (PromotedT Name
arg)) Type
result -> do
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
arg))) (getTypeScriptType (Proxy :: Proxy $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
result))) Nothing |]
#else
    TySynEqn [ConT arg] result -> do
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) Nothing |]
#endif
    TySynEqn
x -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|]

  [| TSInterfaceDeclaration $(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) [] (L.sortBy (compare `on` fieldName) $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
fields)) Nothing |]

getClosedTypeFamilyImage :: [TySynEqn] -> Q [Type]
getClosedTypeFamilyImage :: [TySynEqn] -> Q [Type]
getClosedTypeFamilyImage [TySynEqn]
eqns = do
  [TySynEqn] -> (TySynEqn -> Q Type) -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TySynEqn]
eqns ((TySynEqn -> Q Type) -> Q [Type])
-> (TySynEqn -> Q Type) -> Q [Type]
forall a b. (a -> b) -> a -> b
$ \case
#if MIN_VERSION_template_haskell(2,15,0)
    TySynEqn Maybe [TyVarBndr ()]
Nothing (AppT (ConT Name
_) Type
_) Type
result -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
result
#else
    TySynEqn [ConT _] result -> return result
#endif
    TySynEqn
x -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|]