{-# 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.Lookup where

import Control.Monad
import Data.Aeson.TypeScript.Instances ()
import Data.Aeson.TypeScript.Types
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 (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 (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
#else
    TySynEqn [ConT arg] result -> do
#endif
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) |]
    TySynEqn
x -> String -> Q Exp
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 $(TH.stringE $ nameBase name) [] $(listE $ fmap return fields) |]

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
_) (ConT Name
_)) Type
result -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
result
#else
    TySynEqn [ConT _] result -> return result
#endif
    TySynEqn
x -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|]