{-# 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.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
      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
_ -> 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TySynEqn]
eqns 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 $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) |]
    TySynEqn Maybe [TyVarBndr ()]
Nothing (AppT (ConT Name
_) (PromotedT Name
arg)) Type
result -> do
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(promotedT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) |]
#else
    TySynEqn [ConT arg] result -> do
      [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) |]
#endif
    TySynEqn
x -> 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) [] (L.sortBy (compare `on` fieldName) $(listE $ fmap return fields)) |]

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