{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, NamedFieldPuns, MultiWayIf, ViewPatterns, PolyKinds #-}

module Data.Aeson.TypeScript.Util where

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

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

getDataTypeVars :: DatatypeInfo -> [Type]
#if MIN_VERSION_th_abstraction(0,3,0)
getDataTypeVars :: DatatypeInfo -> [Type]
getDataTypeVars (DatatypeInfo {[Type]
datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes :: [Type]
datatypeInstTypes}) = [Type]
datatypeInstTypes
#else
getDataTypeVars (DatatypeInfo {datatypeVars}) = datatypeVars
#endif

setDataTypeVars :: DatatypeInfo -> [Type] -> DatatypeInfo
#if MIN_VERSION_th_abstraction(0,3,0)
setDataTypeVars :: DatatypeInfo -> [Type] -> DatatypeInfo
setDataTypeVars dti :: DatatypeInfo
dti@(DatatypeInfo {}) [Type]
vars = DatatypeInfo
dti { datatypeInstTypes :: [Type]
datatypeInstTypes = [Type]
vars }
#else
setDataTypeVars dti@(DatatypeInfo {}) vars = dti { datatypeVars = vars }
#endif

dropLeadingIFromInterfaceName :: TSDeclaration -> TSDeclaration
dropLeadingIFromInterfaceName :: TSDeclaration -> TSDeclaration
dropLeadingIFromInterfaceName decl :: TSDeclaration
decl@(TSInterfaceDeclaration {interfaceName :: TSDeclaration -> String
interfaceName=(Char
'I':String
xs)}) = TSDeclaration
decl { interfaceName :: String
interfaceName = String
xs }
dropLeadingIFromInterfaceName decl :: TSDeclaration
decl@(TSTypeAlternatives {typeName :: TSDeclaration -> String
typeName=(Char
'I':String
xs)}) = TSDeclaration
decl { typeName :: String
typeName = String
xs }
dropLeadingIFromInterfaceName TSDeclaration
x = TSDeclaration
x

lastNameComponent :: String -> String
lastNameComponent :: String -> String
lastNameComponent String
x = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
last ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." (String -> Text
T.pack String
x)

lastNameComponent' :: Name -> String
lastNameComponent' :: Name -> String
lastNameComponent' = String -> String
lastNameComponent (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show

getTypeName :: Name -> String
getTypeName :: Name -> String
getTypeName Name
x = String -> String
lastNameComponent (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
x

allConstructorsAreNullary :: [ConstructorInfo] -> Bool
allConstructorsAreNullary :: [ConstructorInfo] -> Bool
allConstructorsAreNullary [ConstructorInfo]
constructors = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Bool) -> [ConstructorInfo] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstructorInfo -> Bool
isConstructorNullary [ConstructorInfo]
constructors

isConstructorNullary :: ConstructorInfo -> Bool
isConstructorNullary :: ConstructorInfo -> Bool
isConstructorNullary (ConstructorInfo {ConstructorVariant
constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant :: ConstructorVariant
constructorVariant, [Type]
constructorFields :: ConstructorInfo -> [Type]
constructorFields :: [Type]
constructorFields}) = (ConstructorVariant
constructorVariant ConstructorVariant -> ConstructorVariant -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorVariant
NormalConstructor) Bool -> Bool -> Bool
&& ([Type]
constructorFields [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [])

-- In Template Haskell 2.10.0.0 and later, Pred is just a synonm for Type
-- In earlier versions, it has constructors
getDatatypePredicate :: Type -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
getDatatypePredicate :: Type -> Type
getDatatypePredicate Type
typ = Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeScript) Type
typ
#else
getDatatypePredicate typ = ClassP ''TypeScript [typ]
#endif

getTypeAsStringExp :: Type -> Q Exp
getTypeAsStringExp :: Type -> Q Exp
getTypeAsStringExp Type
typ = [|getTypeScriptType (Proxy :: Proxy $(return typ))|]

getOptionalAsBoolExp :: Type -> Q Exp
getOptionalAsBoolExp :: Type -> Q Exp
getOptionalAsBoolExp Type
typ = [|getTypeScriptOptional (Proxy :: Proxy $(return typ))|]

-- | Helper to apply a type constructor to a list of type args
applyToArgsT :: Type -> [Type] -> Type
applyToArgsT :: Type -> [Type] -> Type
applyToArgsT Type
constructor [] = Type
constructor
applyToArgsT Type
constructor (Type
x:[Type]
xs) = Type -> [Type] -> Type
applyToArgsT (Type -> Type -> Type
AppT Type
constructor Type
x) [Type]
xs

-- | Helper to apply a function a list of args
applyToArgsE :: Exp -> [Exp] -> Exp
applyToArgsE :: Exp -> [Exp] -> Exp
applyToArgsE Exp
f [] = Exp
f
applyToArgsE Exp
f (Exp
x:[Exp]
xs) = Exp -> [Exp] -> Exp
applyToArgsE (Exp -> Exp -> Exp
AppE Exp
f Exp
x) [Exp]
xs

-- Between Aeson 1.1.2.0 and 1.2.0.0, tagSingleConstructors was added
getTagSingleConstructors :: Options -> Bool
#if MIN_VERSION_aeson(1,2,0)
getTagSingleConstructors :: Options -> Bool
getTagSingleConstructors Options
options = Options -> Bool
tagSingleConstructors Options
options
#else
getTagSingleConstructors _ = False
#endif

-- Between Template Haskell 2.10 and 2.11, the ability to look up which extensions are turned on was added
assertExtensionsTurnedOn :: DatatypeInfo -> Q ()
#if MIN_VERSION_template_haskell(2,11,0)
assertExtensionsTurnedOn :: DatatypeInfo -> Q ()
assertExtensionsTurnedOn (DatatypeInfo {[Type]
[TyVarBndrUnit]
[ConstructorInfo]
Name
DatatypeVariant
datatypeContext :: DatatypeInfo -> [Type]
datatypeName :: DatatypeInfo -> Name
datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons :: [ConstructorInfo]
datatypeVariant :: DatatypeVariant
datatypeInstTypes :: [Type]
datatypeVars :: [TyVarBndrUnit]
datatypeName :: Name
datatypeContext :: [Type]
datatypeInstTypes :: DatatypeInfo -> [Type]
..}) = do
  -- Check that necessary language extensions are turned on
  Bool
scopedTypeVariablesEnabled <- Extension -> Q Bool
isExtEnabled Extension
ScopedTypeVariables
  Bool
kindSignaturesEnabled <- Extension -> Q Bool
isExtEnabled Extension
KindSignatures
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
scopedTypeVariablesEnabled) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. HasCallStack => String -> a
error [i|The ScopedTypeVariables extension is required; please enable it before calling deriveTypeScript. (For example: put {-\# LANGUAGE ScopedTypeVariables \#-} at the top of the file.)|]
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool -> Bool
not Bool
kindSignaturesEnabled) Bool -> Bool -> Bool
&& ([TyVarBndrUnit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndrUnit]
datatypeVars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. HasCallStack => String -> a
error [i|The KindSignatures extension is required since type #{datatypeName} is a higher order type; please enable it before calling deriveTypeScript. (For example: put {-\# LANGUAGE KindSignatures \#-} at the top of the file.)|]
#else
assertExtensionsTurnedOn _ = return ()
#endif

-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this
isObjectWithSingleField :: SumEncoding -> Bool
isObjectWithSingleField :: SumEncoding -> Bool
isObjectWithSingleField SumEncoding
ObjectWithSingleField = Bool
True
isObjectWithSingleField SumEncoding
_ = Bool
False

-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this
isTwoElemArray :: SumEncoding -> Bool
isTwoElemArray :: SumEncoding -> Bool
isTwoElemArray SumEncoding
TwoElemArray = Bool
True
isTwoElemArray SumEncoding
_ = Bool
False

-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this
-- UntaggedValue was added between Aeson 0.11.3.0 and 1.0.0.0
isUntaggedValue :: SumEncoding -> Bool
#if MIN_VERSION_aeson(1,0,0)
isUntaggedValue :: SumEncoding -> Bool
isUntaggedValue SumEncoding
UntaggedValue = Bool
True
#endif
isUntaggedValue SumEncoding
_ = Bool
False

-- Between Template Haskell 2.10 and 2.11, InstanceD got an additional argument
mkInstance :: Cxt -> Type -> [Dec] -> Dec
#if MIN_VERSION_template_haskell(2,11,0)
mkInstance :: [Type] -> Type -> [Dec] -> Dec
mkInstance [Type]
context Type
typ [Dec]
decs = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context Type
typ [Dec]
decs
#else
mkInstance context typ decs = InstanceD context typ decs
#endif

namesAndTypes :: Options -> ConstructorInfo -> [(String, Type)]
namesAndTypes :: Options -> ConstructorInfo -> [(String, Type)]
namesAndTypes Options
options ConstructorInfo
ci = case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
ci of
  RecordConstructor [Name]
names -> [String] -> [Type] -> [(String, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Options -> String -> String
fieldLabelModifier Options
options) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
lastNameComponent') [Name]
names) (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci)
  ConstructorVariant
_ -> case Options -> SumEncoding
sumEncoding Options
options of
    TaggedObject String
_ String
contentsFieldName
      | ConstructorInfo -> Bool
isConstructorNullary ConstructorInfo
ci -> []
      | Bool
otherwise -> [(String
contentsFieldName, ConstructorInfo -> Type
contentsTupleType ConstructorInfo
ci)]
    SumEncoding
_ -> [(Options -> ConstructorInfo -> String
constructorNameToUse Options
options ConstructorInfo
ci, ConstructorInfo -> Type
contentsTupleType ConstructorInfo
ci)]

constructorNameToUse :: Options -> ConstructorInfo -> String
constructorNameToUse :: Options -> ConstructorInfo -> String
constructorNameToUse Options
options ConstructorInfo
ci = (Options -> String -> String
constructorTagModifier Options
options) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
lastNameComponent' (ConstructorInfo -> Name
constructorName ConstructorInfo
ci)

-- | Get the type of a tuple of constructor fields, as when we're packing a record-less constructor into a list
contentsTupleType :: ConstructorInfo -> Type
contentsTupleType :: ConstructorInfo -> Type
contentsTupleType ConstructorInfo
ci = let fields :: [Type]
fields = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci in
  case [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields of
    Int
0 -> Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT ''())
    Int
1 -> [Type] -> Type
forall a. [a] -> a
head [Type]
fields
    Int
x -> Type -> [Type] -> Type
applyToArgsT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
x) [Type]
fields

getBracketsExpression :: Bool -> [(Name, String)] -> Q Exp
getBracketsExpression :: Bool -> [(Name, String)] -> Q Exp
getBracketsExpression Bool
_ [] = [|""|]
getBracketsExpression Bool
includeSuffix [(Name, String)]
names =
  [|let vars = $(genericVariablesListExpr includeSuffix names) in "<" <> L.intercalate ", " vars <> ">"|]

getBracketsExpressionAllTypesNoSuffix :: [(Name, String)] -> Q Exp
getBracketsExpressionAllTypesNoSuffix :: [(Name, String)] -> Q Exp
getBracketsExpressionAllTypesNoSuffix [] = [|""|]
getBracketsExpressionAllTypesNoSuffix [(Name, String)]
names = [|"<" <> L.intercalate ", " $(listE [ [|(getTypeScriptType (Proxy :: Proxy $(varT x)))|] | (x, _suffix) <- names]) <> ">"|]

genericVariablesListExpr :: Bool -> [(Name, String)] -> Q Exp
genericVariablesListExpr :: Bool -> [(Name, String)] -> Q Exp
genericVariablesListExpr Bool
includeSuffix [(Name, String)]
genericVariables = [Q Exp] -> Q Exp
listE ((((Name, String), Type) -> Q Exp)
-> [((Name, String), Type)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Name
_, String
suffix), Type
correspondingGeneric) ->
  [|(getTypeScriptType (Proxy :: Proxy $(return correspondingGeneric))) <> $(TH.stringE (if includeSuffix then suffix else ""))|])
  (case [(Name, String)]
genericVariables of
      [(Name, String)
x] -> [((Name, String)
x, Name -> Type
ConT ''T)]
      [(Name, String)]
xs -> [(Name, String)] -> [Type] -> [((Name, String), Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, String)]
xs [Type]
allStarConstructors)
  )

isStarType :: Type -> Maybe Name
isStarType :: Type -> Maybe Name
isStarType (SigT (VarT Name
n) Type
StarT) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isStarType Type
_ = Maybe Name
forall a. Maybe a
Nothing