aeson-typescript 0.2.0.0 → 0.3.0.0

raw patch · 32 files changed

+1356/−389 lines, 32 filesdep ~th-abstractionPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• ChangeLog.md +0/−3
• README.md +1/−1
• aeson-typescript.cabal +49/−32
• src/Data/Aeson/TypeScript/Formatting.hs +42/−10
• src/Data/Aeson/TypeScript/Instances.hs +38/−3
• src/Data/Aeson/TypeScript/Internal.hs +8/−0
• src/Data/Aeson/TypeScript/Lookup.hs +63/−0
• src/Data/Aeson/TypeScript/Recursive.hs +27/−0
• src/Data/Aeson/TypeScript/TH.hs +240/−274
• src/Data/Aeson/TypeScript/Types.hs +101/−6
• src/Data/Aeson/TypeScript/Util.hs +166/−0
• test/Basic.hs +48/−0
• test/Formatting.hs +34/−0
• test/HigherKind.hs +26/−11
• test/Live.hs +73/−0
• test/Live2.hs +28/−0
• test/LiveLogging.hs +32/−0
• test/NoOmitNothingFields.hs +40/−0
• test/ObjectWithSingleFieldNoTagSingleConstructors.hs +14/−4
• test/ObjectWithSingleFieldTagSingleConstructors.hs +14/−3
• test/OmitNothingFields.hs +40/−0
• test/Spec.hs +13/−1
• test/TaggedObjectNoTagSingleConstructors.hs +14/−4
• test/TaggedObjectTagSingleConstructors.hs +14/−3
• test/TestBoilerplate.hs +51/−5
• test/TwoElemArrayNoTagSingleConstructors.hs +14/−4
• test/TwoElemArrayTagSingleConstructors.hs +14/−3
• test/TypeFamilies.hs +91/−0
• test/UntaggedNoTagSingleConstructors.hs +14/−4
• test/UntaggedTagSingleConstructors.hs +15/−3
• test/Util.hs +13/−15

@@ -0,0 +1,19 @@+# Change log++## 0.3.0.0++* Update th-abstraction dependency to < 0.5 to support working with newer Stack LTS.+* Major refactors to improve TH quality.+* Tracking of parent types to allow recursive deriving+  * The `getParentTypes` function was added to the main typeclass.+  * The new `Data.Aeson.TypeScript.Recursive` module for working with recursive definitions.+* New support for mapping Haskell closed type families to TypeScript lookup types.++## 0.2.0.0++* New formatting option `interfaceNameModifier`.++## 0.1.0.0++* Initial release.+

@@ -1,3 +0,0 @@-# Changelog for aeson-typescript--## Unreleased changes

@@ -1,5 +1,5 @@ -# Welcome to `aeson-typescript` [![Hackage](https://img.shields.io/hackage/v/aeson-typescript.svg)](https://hackage.haskell.org/package/aeson-typescript) [![Build Status](https://travis-ci.org/codedownio/aeson-typescript.svg)](https://travis-ci.org/codedownio/aeson-typescript)+# Welcome to `aeson-typescript` [![Hackage](https://img.shields.io/hackage/v/aeson-typescript.svg)](https://hackage.haskell.org/package/aeson-typescript) ![aeson-typescript](https://github.com/codedownio/aeson-typescript/workflows/aeson-typescript/badge.svg)  This library provides a way to generate TypeScript `.d.ts` files that match your existing Aeson `ToJSON` instances. If you already use Aeson's Template Haskell support to derive your instances, then deriving TypeScript is as simple as

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 74aae5bd5d3353838039530c9ce854fa79c1a282fa2d73d232a7d5677ad341e2+-- hash: 73021b1b79e95ae7e4b67a45fafb5d452d8ab05ae59d4071098e8628cf8f29e4  name:           aeson-typescript-version:        0.2.0.0+version:        0.3.0.0 synopsis:       Generate TypeScript definition files from your ADTs description:    Please see the README on Github at <https://github.com/codedownio/aeson-typescript#readme> category:       Text, Web, JSON@@ -15,14 +15,15 @@ bug-reports:    https://github.com/codedownio/aeson-typescript/issues author:         Tom McLaughlin maintainer:     tom@codedown.io-copyright:      2018 CodeDown+copyright:      2021 CodeDown license:        BSD3 license-file:   LICENSE-tested-with:    GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2+tested-with:+    GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 build-type:     Simple extra-source-files:     README.md-    ChangeLog.md+    CHANGELOG.md     test/assets/package.json     test/assets/npm_install.sh     test/assets/yarn_install.sh@@ -33,6 +34,17 @@   location: https://github.com/codedownio/aeson-typescript  library+  exposed-modules:+      Data.Aeson.TypeScript.TH+      Data.Aeson.TypeScript.Internal+      Data.Aeson.TypeScript.Recursive+  other-modules:+      Data.Aeson.TypeScript.Formatting+      Data.Aeson.TypeScript.Instances+      Data.Aeson.TypeScript.Lookup+      Data.Aeson.TypeScript.Types+      Data.Aeson.TypeScript.Util+      Paths_aeson_typescript   hs-source-dirs:       src   build-depends:@@ -43,20 +55,42 @@     , mtl     , template-haskell     , text-    , th-abstraction <0.4+    , th-abstraction <0.5     , unordered-containers-  exposed-modules:-      Data.Aeson.TypeScript.TH-  other-modules:-      Data.Aeson.TypeScript.Formatting-      Data.Aeson.TypeScript.Instances-      Data.Aeson.TypeScript.Types-      Paths_aeson_typescript   default-language: Haskell2010  test-suite aeson-typescript-test   type: exitcode-stdio-1.0   main-is: Spec.hs+  other-modules:+      Basic+      Formatting+      HigherKind+      Live+      Live2+      LiveLogging+      NoOmitNothingFields+      ObjectWithSingleFieldNoTagSingleConstructors+      ObjectWithSingleFieldTagSingleConstructors+      OmitNothingFields+      TaggedObjectNoTagSingleConstructors+      TaggedObjectTagSingleConstructors+      TestBoilerplate+      TwoElemArrayNoTagSingleConstructors+      TwoElemArrayTagSingleConstructors+      TypeFamilies+      UntaggedNoTagSingleConstructors+      UntaggedTagSingleConstructors+      Util+      Data.Aeson.TypeScript.Formatting+      Data.Aeson.TypeScript.Instances+      Data.Aeson.TypeScript.Internal+      Data.Aeson.TypeScript.Lookup+      Data.Aeson.TypeScript.Recursive+      Data.Aeson.TypeScript.TH+      Data.Aeson.TypeScript.Types+      Data.Aeson.TypeScript.Util+      Paths_aeson_typescript   hs-source-dirs:       test       src@@ -76,23 +110,6 @@     , template-haskell     , temporary     , text-    , th-abstraction <0.4+    , th-abstraction <0.5     , unordered-containers-  other-modules:-      HigherKind-      ObjectWithSingleFieldNoTagSingleConstructors-      ObjectWithSingleFieldTagSingleConstructors-      TaggedObjectNoTagSingleConstructors-      TaggedObjectTagSingleConstructors-      TestBoilerplate-      TwoElemArrayNoTagSingleConstructors-      TwoElemArrayTagSingleConstructors-      UntaggedNoTagSingleConstructors-      UntaggedTagSingleConstructors-      Util-      Data.Aeson.TypeScript.Formatting-      Data.Aeson.TypeScript.Instances-      Data.Aeson.TypeScript.TH-      Data.Aeson.TypeScript.Types-      Paths_aeson_typescript   default-language: Haskell2010

@@ -1,12 +1,16 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, CPP #-}  module Data.Aeson.TypeScript.Formatting where  import Data.Aeson.TypeScript.Types-import Data.Monoid import Data.String.Interpolate.IsString import qualified Data.Text as T +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++ -- | Same as 'formatTSDeclarations'', but uses default formatting options. formatTSDeclarations :: [TSDeclaration] -> String formatTSDeclarations = formatTSDeclarations' defaultFormattingOptions@@ -14,21 +18,49 @@ -- | Format a single TypeScript declaration. This version accepts a FormattingOptions object in case you want more control over the output. formatTSDeclaration :: FormattingOptions -> TSDeclaration -> String formatTSDeclaration (FormattingOptions {..}) (TSTypeAlternatives name genericVariables names) =-  [i|type #{typeNameModifier name}#{getGenericBrackets genericVariables} = #{alternatives};|]-  where alternatives = T.intercalate " | " (fmap T.pack names)+  case typeAlternativesFormat of+    Enum -> [i|#{exportPrefix exportMode}enum #{typeNameModifier name} { #{alternativesEnum} }|]+    EnumWithType -> [i|#{exportPrefix exportMode}enum #{typeNameModifier name} { #{alternativesEnumWithType} }#{enumType}|]+    TypeAlias -> [i|#{exportPrefix exportMode}type #{typeNameModifier name}#{getGenericBrackets genericVariables} = #{alternatives};|]+  where+    alternatives = T.intercalate " | " (fmap T.pack names)+    alternativesEnum = T.intercalate ", " $ [toEnumName entry | entry <- T.pack <$> names]+    alternativesEnumWithType = T.intercalate ", " $ [toEnumName entry <> "=" <> entry | entry <- T.pack <$> names]+    enumType = [i|\n\ntype #{name} = keyof typeof #{typeNameModifier name};|]+    toEnumName = T.replace "\"" ""  formatTSDeclaration (FormattingOptions {..}) (TSInterfaceDeclaration interfaceName genericVariables members) =-  [i|interface #{modifiedInterfaceName}#{getGenericBrackets genericVariables} {-#{lines}-}|] where lines = T.intercalate "\n" $ fmap T.pack [(replicate numIndentSpaces ' ') <> formatTSField member <> ";"| member <- members]-          modifiedInterfaceName = (\(i, name) -> i <> interfaceNameModifier name) . splitAt 1 $ interfaceName+  [i|#{exportPrefix exportMode}interface #{modifiedInterfaceName}#{getGenericBrackets genericVariables} {+#{ls}+}|] where ls = T.intercalate "\n" $ fmap T.pack [(replicate numIndentSpaces ' ') <> formatTSField member <> ";"| member <- members]+          modifiedInterfaceName = (\(li, name) -> li <> interfaceNameModifier name) . splitAt 1 $ interfaceName +formatTSDeclaration (FormattingOptions {..}) (TSRawDeclaration text) = text++exportPrefix :: ExportMode -> String+exportPrefix ExportEach = "export "+exportPrefix ExportNone = ""+ -- | Format a list of TypeScript declarations into a string, suitable for putting directly into a @.d.ts@ file. formatTSDeclarations' :: FormattingOptions -> [TSDeclaration] -> String-formatTSDeclarations' options declarations = T.unpack $ T.intercalate "\n\n" (fmap (T.pack . formatTSDeclaration options) declarations)+formatTSDeclarations' options declarations = T.unpack $ T.intercalate "\n\n" (fmap (T.pack . formatTSDeclaration (validateFormattingOptions options declarations)) declarations) +validateFormattingOptions :: FormattingOptions -> [TSDeclaration] -> FormattingOptions+validateFormattingOptions options@FormattingOptions{..} decls+  | typeAlternativesFormat == Enum && isPlainSumType decls = options+  | typeAlternativesFormat == EnumWithType && isPlainSumType decls = options { typeNameModifier = flip (<>) "Enum" }+  | otherwise = options { typeAlternativesFormat = TypeAlias }+  where+    isInterface :: TSDeclaration -> Bool+    isInterface TSInterfaceDeclaration{} = True+    isInterface _ = False++    -- Plain sum types have only one declaration with multiple alternatives+    -- Units (data U = U) contain two declarations, and thus are invalid+    isPlainSumType ds = (not . any isInterface $ ds) && length ds == 1+ formatTSField :: TSField -> String-formatTSField (TSField optional name typ) = [i|#{name}#{if optional then "?" else ""}: #{typ}|]+formatTSField (TSField optional name typ) = [i|#{name}#{if optional then ("?" :: String) else ""}: #{typ}|]  getGenericBrackets :: [String] -> String getGenericBrackets [] = ""

@@ -1,4 +1,5 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, OverlappingInstances, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- Note: the OverlappingInstances pragma is only here so the overlapping instances in this file -- will work on older GHCs, like GHC 7.8.4@@ -9,15 +10,23 @@ import Data.Aeson.TypeScript.Types import Data.Data import Data.HashMap.Strict-import Data.Monoid+import qualified Data.List as L import Data.Set import Data.String.Interpolate.IsString import qualified Data.Text as T import qualified Data.Text.Lazy as TL+import Data.Void +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif+ instance TypeScript () where   getTypeScriptType _ = "void" +instance TypeScript Void where+  getTypeScriptType _ = "void"+ instance TypeScript T.Text where   getTypeScriptType _ = "string" @@ -37,7 +46,6 @@   getTypeScriptType _ = "boolean"  instance TypeScript Int where-  getTypeScriptDeclarations _ = []   getTypeScriptType _ = "number"  instance TypeScript Char where@@ -45,6 +53,7 @@  instance {-# OVERLAPPABLE #-} (TypeScript a) => TypeScript [a] where   getTypeScriptType _ = (getTypeScriptType (Proxy :: Proxy a)) ++ "[]"+  getParentTypes _ = (TSType (Proxy :: Proxy a)) : (getParentTypes (Proxy :: Proxy a))  instance {-# OVERLAPPING #-} TypeScript [Char] where   getTypeScriptType _ = "string"@@ -55,25 +64,51 @@                                , TSInterfaceDeclaration "Left" ["T"] [TSField False "Left" "T"]                                , TSInterfaceDeclaration "Right" ["T"] [TSField False "Right" "T"]                                ]+  getParentTypes _ = L.nub ((TSType (Proxy :: Proxy a))+                            : (TSType (Proxy :: Proxy b))+                            : (getParentTypes (Proxy :: Proxy a))+                            <> (getParentTypes (Proxy :: Proxy b)))  instance (TypeScript a, TypeScript b) => TypeScript (a, b) where   getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}]|]+  getParentTypes _ = L.nub ((TSType (Proxy :: Proxy a))+                            : (TSType (Proxy :: Proxy b))+                            : (getParentTypes (Proxy :: Proxy a))+                            <> (getParentTypes (Proxy :: Proxy b)))  instance (TypeScript a, TypeScript b, TypeScript c) => TypeScript (a, b, c) where   getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}, #{getTypeScriptType (Proxy :: Proxy c)}]|]+  getParentTypes _ = L.nub ((TSType (Proxy :: Proxy a))+                            : (TSType (Proxy :: Proxy b))+                            : (TSType (Proxy :: Proxy c))+                            : (getParentTypes (Proxy :: Proxy a))+                            <> (getParentTypes (Proxy :: Proxy b))+                            <> (getParentTypes (Proxy :: Proxy c)))  instance (TypeScript a, TypeScript b, TypeScript c, TypeScript d) => TypeScript (a, b, c, d) where   getTypeScriptType _ = [i|[#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}, #{getTypeScriptType (Proxy :: Proxy c)}, #{getTypeScriptType (Proxy :: Proxy d)}]|]+  getParentTypes _ = L.nub ((TSType (Proxy :: Proxy a))+                            : (TSType (Proxy :: Proxy b))+                            : (TSType (Proxy :: Proxy c))+                            : (TSType (Proxy :: Proxy d))+                            : (getParentTypes (Proxy :: Proxy a))+                            <> (getParentTypes (Proxy :: Proxy b))+                            <> (getParentTypes (Proxy :: Proxy c))+                            <> (getParentTypes (Proxy :: Proxy d)))  instance (TypeScript a) => TypeScript (Maybe a) where   getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a)   getTypeScriptOptional _ = True+  getParentTypes _ = [TSType (Proxy :: Proxy a)]  instance TypeScript A.Value where   getTypeScriptType _ = "any";  instance (TypeScript a, TypeScript b) => TypeScript (HashMap a b) where   getTypeScriptType _ = [i|{[k: #{getTypeScriptType (Proxy :: Proxy a)}]: #{getTypeScriptType (Proxy :: Proxy b)}}|]+  getParentTypes _ = L.nub ((getParentTypes (Proxy :: Proxy a))+                            <> (getParentTypes (Proxy :: Proxy b)))  instance (TypeScript a) => TypeScript (Set a) where   getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]";+  getParentTypes _ = L.nub (getParentTypes (Proxy :: Proxy a))

@@ -0,0 +1,8 @@+-- | Internal details. For now, this module just exports the full TSDeclaration constructors.+-- These are subject to breaking changes but are exported here in case you want to live dangerously.++module Data.Aeson.TypeScript.Internal (+  TSDeclaration(..)+  ) where++import Data.Aeson.TypeScript.Types

@@ -0,0 +1,63 @@+{-# 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.IsString+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 declNameStr = do+  info <- reify name+  case info of+    FamilyI (ClosedTypeFamilyD (TypeFamilyHead _name _vars _sig _maybeInject) eqns) _decs -> do+      interfaceDecl <- getClosedTypeFamilyInterfaceDecl name eqns+      return [FunD (mkName declNameStr) [Clause [] (NormalB (ListE [interfaceDecl])) []]]++    _ -> fail [i|Expected a close type family; got #{info}|]++getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp+getClosedTypeFamilyInterfaceDecl name eqns = do+  fields <- forM eqns $ \case+#if MIN_VERSION_template_haskell(2,15,0)+    TySynEqn Nothing (AppT (ConT _) (ConT arg)) result -> do+#else+    TySynEqn [ConT arg] result -> do+#endif+      [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) |]+    x -> 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 eqns = do+  forM eqns $ \case+#if MIN_VERSION_template_haskell(2,15,0)+    TySynEqn Nothing (AppT (ConT _) (ConT _)) result -> return result+#else+    TySynEqn [ConT _] result -> return result+#endif+    x -> fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|]

@@ -0,0 +1,27 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, NamedFieldPuns, MultiWayIf, ViewPatterns, LambdaCase, PolyKinds #-}++module Data.Aeson.TypeScript.Recursive (+  getTransitiveClosure+  , getTypeScriptDeclarationsRecursively+  ) where++import Data.Aeson.TypeScript.Instances ()+import Data.Aeson.TypeScript.TH+import Data.Function+import Data.Proxy+import qualified Data.Set as S+++getTransitiveClosure :: S.Set TSType -> S.Set TSType+getTransitiveClosure initialTypes = fix (\loop items -> let items' = S.unions (items : [getMore x | x <- S.toList items]) in+                                            if | items' == items -> items+                                               | otherwise -> loop items'+                                        ) initialTypes+  where getMore :: TSType -> S.Set TSType+        getMore (TSType x) = S.fromList $ getParentTypes x++getTypeScriptDeclarationsRecursively :: (TypeScript a) => Proxy a -> [TSDeclaration]+getTypeScriptDeclarationsRecursively initialType = S.toList $ S.fromList declarations+  where+    closure = getTransitiveClosure (S.fromList [TSType initialType])+    declarations = mconcat [getTypeScriptDeclarations x | TSType x <- S.toList closure]

@@ -1,4 +1,17 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, NamedFieldPuns, MultiWayIf, ViewPatterns #-}+{-# 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.TH@@ -98,240 +111,278 @@ -}  module Data.Aeson.TypeScript.TH (-  deriveTypeScript,+  deriveTypeScript+  , deriveTypeScript'+  , deriveTypeScriptLookupType    -- * The main typeclass-  TypeScript(..),+  , TypeScript(..)+  , TSType(..) -  TSDeclaration,+  , TSDeclaration(TSRawDeclaration)    -- * Formatting declarations-  formatTSDeclarations,-  formatTSDeclarations',-  formatTSDeclaration,-  FormattingOptions(..),+  , formatTSDeclarations+  , formatTSDeclarations'+  , formatTSDeclaration+  , FormattingOptions(..)+  , SumTypeFormat(..)+  , ExportMode(..) +  -- * Advanced options+  , ExtraTypeScriptOptions(..)+   -- * Convenience tools-  HasJSONOptions(..),-  deriveJSONAndTypeScript,+  , HasJSONOptions(..)+  , deriveJSONAndTypeScript+  , deriveJSONAndTypeScript' -  module Data.Aeson.TypeScript.Instances+  , T(..)+  , T1(..)+  , T2(..)+  , T3(..)++  , module Data.Aeson.TypeScript.Instances   ) where  import Control.Monad+import Control.Monad.Writer import Data.Aeson as A import Data.Aeson.TH as A import Data.Aeson.TypeScript.Formatting import Data.Aeson.TypeScript.Instances ()+import Data.Aeson.TypeScript.Lookup import Data.Aeson.TypeScript.Types+import Data.Aeson.TypeScript.Util+import qualified Data.List as L import qualified Data.Map as M import Data.Maybe-import Data.Monoid import Data.Proxy import Data.String.Interpolate.IsString-import qualified Data.Text as T+import Data.Typeable import Language.Haskell.TH hiding (stringE) import Language.Haskell.TH.Datatype--data T = T-data T1 = T1-data T2 = T2-data T3 = T3-data T4 = T4-data T5 = T5-data T6 = T6-data T7 = T7-data T8 = T8-data T9 = T9-data T10 = T10--instance TypeScript T where-  getTypeScriptType _ = "T"--instance TypeScript T1 where-  getTypeScriptType _ = "T1"--instance TypeScript T2 where-  getTypeScriptType _ = "T2"--instance TypeScript T3 where-  getTypeScriptType _ = "T3"--instance TypeScript T4 where-  getTypeScriptType _ = "T4"--instance TypeScript T5 where-  getTypeScriptType _ = "T5"--instance TypeScript T6 where-  getTypeScriptType _ = "T6"--instance TypeScript T7 where-  getTypeScriptType _ = "T7"--instance TypeScript T8 where-  getTypeScriptType _ = "T8"--instance TypeScript T9 where-  getTypeScriptType _ = "T9"--instance TypeScript T10 where-  getTypeScriptType _ = "T10"+import qualified Language.Haskell.TH.Lib as TH +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif  -- | Generates a 'TypeScript' instance declaration for the given data type.-deriveTypeScript :: Options-                 -- ^ Encoding options.-                 -> Name-                 -- ^ Name of the type for which to generate a 'TypeScript' instance declaration.-                 -> Q [Dec]-deriveTypeScript options name = do-  datatypeInfo@(DatatypeInfo {..}) <- reifyDatatype name--  assertExtensionsTurnedOn datatypeInfo--  let getFreeVariableName (SigT (VarT name) kind) = Just name-      getFreeVariableName typ = Nothing+deriveTypeScript' :: Options+                  -- ^ Encoding options.+                  -> Name+                  -- ^ Name of the type for which to generate a 'TypeScript' instance declaration.+                  -> ExtraTypeScriptOptions+                  -- ^ Extra options to control advanced features.+                  -> Q [Dec]+deriveTypeScript' options name extraOptions = do+  datatypeInfo' <- reifyDatatype name+  assertExtensionsTurnedOn datatypeInfo' -  let templateVarsToUse = case length datatypeVars of+  -- Plug in generic variables for all star free variables+  let starVars = [name | (isStarType -> Just name) <- getDataTypeVars datatypeInfo']+  let templateVarsToUse = case length starVars of         1 -> [ConT ''T]-        n -> take (length datatypeVars) [ConT ''T1, ConT ''T2, ConT ''T3, ConT ''T4, ConT ''T5, ConT ''T6, ConT ''T7, ConT ''T8, ConT ''T9, ConT ''T10]--#if MIN_VERSION_th_abstraction(0,3,0)-  let subMap = M.fromList $ zip (catMaybes $ fmap getFreeVariableName datatypeInstTypes) templateVarsToUse-  let fullyQualifiedDatatypeInfo = (datatypeInfo {datatypeInstTypes = templateVarsToUse-                                                 , datatypeCons = fmap (applySubstitution subMap) datatypeCons})-#else-  let subMap = M.fromList $ zip (catMaybes $ fmap getFreeVariableName datatypeVars) templateVarsToUse-  let fullyQualifiedDatatypeInfo = (datatypeInfo {datatypeVars = templateVarsToUse-                                                 , datatypeCons = fmap (applySubstitution subMap) datatypeCons})-#endif-  getTypeFn <- getTypeExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getTypeScriptType [Clause [WildP] (NormalB expr) []]-  getDeclarationFn <- getDeclarationFunctionBody options name fullyQualifiedDatatypeInfo-  let fullyGenericInstance = mkInstance [] (AppT (ConT ''TypeScript) (ConT name)) [getTypeFn, getDeclarationFn]--  otherInstances <- case length datatypeVars > 0 of-    True -> do-      otherGetTypeFn <- getTypeExpression datatypeInfo >>= \expr -> return $ FunD 'getTypeScriptType [Clause [WildP] (NormalB expr) []]-#if MIN_VERSION_th_abstraction(0,3,0)-      return [mkInstance (fmap getDatatypePredicate datatypeInstTypes) (AppT (ConT ''TypeScript) (foldl (\x y -> AppT x y) (ConT name) datatypeInstTypes)) [otherGetTypeFn]]-#else-      return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl (\x y -> AppT x y) (ConT name) datatypeVars)) [otherGetTypeFn]]-#endif-    False -> return []--  return $ fullyGenericInstance : otherInstances+        _ -> take (length starVars) allStarConstructors+  let subMap = M.fromList $ zip starVars templateVarsToUse+  let dti = datatypeInfo' { datatypeCons = fmap (applySubstitution subMap) (datatypeCons datatypeInfo')} -getDeclarationFunctionBody :: Options -> p -> DatatypeInfo -> Q Dec-getDeclarationFunctionBody options _name datatypeInfo@(DatatypeInfo {..}) = do-  -- If name is higher-kinded, add generic variables to the type and interface declarations-  let genericVariables :: [String] = if | length datatypeVars == 1 -> ["T"]-                                        | otherwise -> ["T" <> show i | i <- [1..(length datatypeVars)]]-  let genericVariablesExp = ListE [stringE x | x <- genericVariables]+  -- Build constraints: a TypeScript constraint for every constructor type and one for every type variable.+  -- Probably overkill/not exactly right, but it's a start.+  let constructorPreds :: [Pred] = [AppT (ConT ''TypeScript) x | x <- mconcat $ fmap constructorFields (datatypeCons dti)+                                                               , hasFreeTypeVariable x]+  let constructorPreds' :: [Pred] = [AppT (ConT ''TypeScript) x | x <- mconcat $ fmap constructorFields (datatypeCons datatypeInfo')+                                                                , hasFreeTypeVariable x]+  let typeVariablePreds :: [Pred] = [AppT (ConT ''TypeScript) x | x <- getDataTypeVars dti] -  declarationFnBody <- do-    let interfaceNamesAndDeclarations = fmap (handleConstructor options datatypeInfo genericVariables) datatypeCons-    let interfaceNames = fmap fst interfaceNamesAndDeclarations-    let interfaceDeclarations = catMaybes $ fmap snd interfaceNamesAndDeclarations+  let eligibleGenericVars = catMaybes $ flip fmap (getDataTypeVars dti) $ \case+        SigT (VarT n) StarT -> Just n+        _ -> Nothing+  genericVariablesAndSuffixes <- forM eligibleGenericVars $ \var -> do+    (_, genericInfos) <- runWriterT $ forM_ (datatypeCons datatypeInfo') $ \ci ->+      forM_ (namesAndTypes options ci) $ \(_, typ) -> do+        searchForConstraints extraOptions typ var+    return (var, unifyGenericVariable genericInfos) -    let typeDeclaration = applyToArgsE (ConE 'TSTypeAlternatives) [stringE $ getTypeName datatypeName, genericVariablesExp, ListE interfaceNames]+  -- Build the declarations+  (types, extraDeclsOrGenericInfos) <- runWriterT $ mapM (handleConstructor options extraOptions dti genericVariablesAndSuffixes) (datatypeCons dti)+  typeDeclaration <- [|TSTypeAlternatives $(TH.stringE $ getTypeName (datatypeName dti))+                                          $(genericVariablesListExpr True genericVariablesAndSuffixes)+                                          $(listE $ fmap return types)|]+  let extraDecls = [x | ExtraDecl x <- extraDeclsOrGenericInfos]+  let extraTopLevelDecls = mconcat [x | ExtraTopLevelDecs x <- extraDeclsOrGenericInfos]+  let predicates = constructorPreds <> constructorPreds' <> typeVariablePreds <> [x | ExtraConstraint x <- extraDeclsOrGenericInfos] -    return $ NormalB $ ListE (typeDeclaration : interfaceDeclarations)+  declarationsFunctionBody <- [| $(return typeDeclaration) : $(listE (fmap return $ extraDecls)) |] -  return $ FunD 'getTypeScriptDeclarations [Clause [WildP] declarationFnBody []]+  let extraParentTypes = [x | ExtraParentType x <- extraDeclsOrGenericInfos] +  -- Couldn't figure out how to put the constraints for "instance TypeScript..." in the quasiquote above without+  -- introducing () when the constraints are empty, which causes "illegal tuple constraint" unless the user enables ConstraintKinds.+  -- So, just use our mkInstance function+  getTypeScriptTypeExp <- [|$(TH.stringE $ getTypeName (datatypeName dti)) <> $(getBracketsExpressionAllTypesNoSuffix genericVariablesAndSuffixes)|]+  getParentTypesExp <- listE [ [|TSType (Proxy :: Proxy $(return t))|]+                             | t <- (mconcat $ fmap constructorFields (datatypeCons datatypeInfo')) <> extraParentTypes]+  let inst = [mkInstance predicates (AppT (ConT ''TypeScript) (foldl AppT (ConT name) (getDataTypeVars dti))) [+                 FunD 'getTypeScriptType [Clause [WildP] (NormalB getTypeScriptTypeExp) []]+                 , FunD 'getTypeScriptDeclarations [Clause [WildP] (NormalB declarationsFunctionBody) []]+                 , FunD 'getParentTypes [Clause [WildP] (NormalB getParentTypesExp) []]+                 ]]+  return (extraTopLevelDecls <> inst)  -- | Return a string to go in the top-level type declaration, plus an optional expression containing a declaration-handleConstructor :: Options -> DatatypeInfo -> [String] -> ConstructorInfo -> (Exp, Maybe Exp)-handleConstructor options (DatatypeInfo {..}) genericVariables ci@(ConstructorInfo {}) =-  if | isSingleConstructorType && not (getTagSingleConstructors options) -> (stringE interfaceName, singleConstructorEncoding)-+handleConstructor :: Options -> ExtraTypeScriptOptions -> DatatypeInfo -> [(Name, String)] -> ConstructorInfo -> WriterT [ExtraDeclOrGenericInfo] Q Exp+handleConstructor options extraOptions (DatatypeInfo {..}) genericVariables ci@(ConstructorInfo {}) =+  if | (length datatypeCons == 1) && not (getTagSingleConstructors options) -> do+         writeSingleConstructorEncoding+         brackets <- lift $ getBracketsExpression False genericVariables+         lift [|$(TH.stringE interfaceName) <> $(return brackets)|]      | allConstructorsAreNullary datatypeCons && allNullaryToStringTag options -> stringEncoding+      -- With UntaggedValue, nullary constructors are encoded as strings      | (isUntaggedValue $ sumEncoding options) && isConstructorNullary ci -> stringEncoding       -- Treat as a sum-     | isObjectWithSingleField $ sumEncoding options -> (stringE [i|{#{show constructorNameToUse}: #{interfaceName}}|], singleConstructorEncoding)-     | isTwoElemArray $ sumEncoding options -> (stringE [i|[#{show constructorNameToUse}, #{interfaceName}]|], singleConstructorEncoding)-     | isUntaggedValue $ sumEncoding options -> (stringE interfaceName, singleConstructorEncoding)-     | otherwise -> (stringE interfaceName, taggedConstructorEncoding)+     | isObjectWithSingleField $ sumEncoding options -> do+         writeSingleConstructorEncoding+         brackets <- lift $ getBracketsExpression False genericVariables+         lift [|"{" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ": " <> $(TH.stringE interfaceName) <> $(return brackets) <> "}"|]+     | isTwoElemArray $ sumEncoding options -> do+         writeSingleConstructorEncoding+         brackets <- lift $ getBracketsExpression False genericVariables+         lift [|"[" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ", " <> $(TH.stringE interfaceName) <> $(return brackets) <> "]"|]+     | isUntaggedValue $ sumEncoding options -> do+         writeSingleConstructorEncoding+         brackets <- lift $ getBracketsExpression False genericVariables+         lift [|$(TH.stringE interfaceName) <> $(return brackets)|]+     | otherwise -> do+         tagField :: [Exp] <- lift $ case sumEncoding options of+           TaggedObject tagFieldName _ -> (: []) <$> [|TSField False $(TH.stringE tagFieldName) $(TH.stringE [i|"#{constructorNameToUse options ci}"|])|]+           _ -> return [] -  where-    stringEncoding = (stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|], Nothing)+         tsFields <- getTSFields+         decl <- lift $ assembleInterfaceDeclaration (ListE (tagField ++ tsFields))+         tell [ExtraDecl decl]+         brackets <- lift $ getBracketsExpression False genericVariables+         lift [|$(TH.stringE interfaceName) <> $(return brackets)|] -    singleConstructorEncoding = if | constructorVariant ci == NormalConstructor -> tupleEncoding-                                   | otherwise -> Just $ assembleInterfaceDeclaration options (constructorName ci) genericVariables (ListE (getTSFields namesAndTypes))+  where+    stringEncoding = lift $ TH.stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|] -    taggedConstructorEncoding = Just $ assembleInterfaceDeclaration options (constructorName ci) genericVariables (ListE (tagField ++ getTSFields namesAndTypes))+    writeSingleConstructorEncoding = if+      | constructorVariant ci == NormalConstructor -> do+          encoding <- tupleEncoding+          tell [ExtraDecl encoding]+      | otherwise -> do+          tsFields <- getTSFields+          decl <- lift $ assembleInterfaceDeclaration (ListE tsFields)+          tell [ExtraDecl decl]      -- * Type declaration to use-    interfaceName = getInterfaceName (constructorName ci) <> getGenericBrackets genericVariables+    interfaceName = "I" <> (lastNameComponent' $ constructorName ci) -    tupleEncoding = Just $ applyToArgsE (ConE 'TSTypeAlternatives) [stringE $ getInterfaceName (constructorName ci)-                                                                   , ListE [stringE x | x <- genericVariables]-                                                                   , ListE [getTypeAsStringExp contentsTupleType]]+    tupleEncoding = do+      tupleType <- transformTypeFamilies extraOptions (contentsTupleType ci)+      lift $ [|TSTypeAlternatives $(TH.stringE interfaceName)+                                  $(genericVariablesListExpr True genericVariables)+                                  [getTypeScriptType (Proxy :: Proxy $(return tupleType))]|] -    namesAndTypes :: [(String, Type)] = case constructorVariant ci of-      RecordConstructor names -> zip (fmap ((fieldLabelModifier options) . lastNameComponent') names) (constructorFields ci)-      NormalConstructor -> case sumEncoding options of-        TaggedObject _ contentsFieldName -> if | isConstructorNullary ci -> []-                                                          | otherwise -> [(contentsFieldName, contentsTupleType)]-        _ -> [(constructorNameToUse, contentsTupleType)]+    assembleInterfaceDeclaration members = [|TSInterfaceDeclaration $(TH.stringE interfaceName)+                                                                    $(genericVariablesListExpr True genericVariables)+                                                                    $(return members)|] -    tagField = case sumEncoding options of-      TaggedObject tagFieldName _ -> [(AppE (AppE (AppE (ConE 'TSField) (ConE 'False))-                                              (stringE tagFieldName))-                                        (stringE [i|"#{constructorNameToUse}"|]))]-      _ -> []+    getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]+    getTSFields = forM (namesAndTypes options ci) $ \(nameString, typ') -> do+      typ <- transformTypeFamilies extraOptions typ'+      when (typ /= typ') $ do+        let constraint = AppT (ConT ''TypeScript) typ+        tell [ExtraConstraint constraint] -    isSingleConstructorType = length datatypeCons == 1+      (fieldTyp, optAsBool) <- lift $ case typ of+        (AppT (ConT name) t) | name == ''Maybe && not (omitNothingFields options) ->+          ( , ) <$> [|$(getTypeAsStringExp t) <> " | null"|] <*> getOptionalAsBoolExp t+        _ -> ( , ) <$> getTypeAsStringExp typ <*> getOptionalAsBoolExp typ'+      lift $ [| TSField $(return optAsBool) $(TH.stringE nameString) $(return fieldTyp) |] -    constructorNameToUse = (constructorTagModifier options) $ lastNameComponent' (constructorName ci)-    contentsTupleType = getTupleType (constructorFields ci)+transformTypeFamilies :: ExtraTypeScriptOptions -> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type+transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ)+  | name `L.elem` typeFamiliesToMapToTypeScript = lift (reify name) >>= \case+      FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) eqns) _ -> do+        name' <- lift $ newName (nameBase typeFamilyName <> "'") --- | Helper for handleConstructor-getTSFields :: [(String, Type)] -> [Exp]-getTSFields namesAndTypes = [(AppE (AppE (AppE (ConE 'TSField) (getOptionalAsBoolExp typ))-                                     (stringE nameString))-                               (getTypeAsStringExp typ))-                            | (nameString, typ) <- namesAndTypes]+        f <- lift $ newName "f"+        let inst1 = DataD [] name' [PlainTV f] Nothing [] []+        tell [ExtraTopLevelDecs [inst1]] --- | Helper for handleConstructor-assembleInterfaceDeclaration options constructorName genericVariables members = AppE (AppE (AppE (ConE 'TSInterfaceDeclaration) constructorNameExp) genericVariablesExp) members where-  constructorNameExp = stringE $ getInterfaceName constructorName-  genericVariablesExp = (ListE [stringE x | x <- genericVariables])+        imageTypes <- lift $ getClosedTypeFamilyImage eqns+        inst2 <- lift $ [d|instance (Typeable g, TypeScript g) => TypeScript ($(conT name') g) where+                             getTypeScriptType _ = $(TH.stringE $ nameBase name) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]"+                             getTypeScriptDeclarations _ = [$(getClosedTypeFamilyInterfaceDecl name eqns)]+                             getParentTypes _ = $(listE [ [|TSType (Proxy :: Proxy $(return x))|] | x <- imageTypes])+                        |]+        tell [ExtraTopLevelDecs inst2] +        tell [ExtraParentType (AppT (ConT name') (ConT ''T))] --- * Getting type expression+        transformTypeFamilies eo (AppT (ConT name') typ)+      _ -> AppT (ConT name) <$> transformTypeFamilies eo typ+  | otherwise = AppT (ConT name) <$> transformTypeFamilies eo typ+transformTypeFamilies eo (AppT typ1 typ2) = AppT <$> transformTypeFamilies eo typ1 <*> transformTypeFamilies eo typ2+transformTypeFamilies eo (SigT typ kind) = flip SigT kind <$> transformTypeFamilies eo typ+transformTypeFamilies eo (InfixT typ1 n typ2) = InfixT <$> transformTypeFamilies eo typ1 <*> pure n <*> transformTypeFamilies eo typ2+transformTypeFamilies eo (UInfixT typ1 n typ2) = UInfixT <$> transformTypeFamilies eo typ1 <*> pure n <*> transformTypeFamilies eo typ2+transformTypeFamilies eo (ParensT typ) = ParensT <$> transformTypeFamilies eo typ+#if MIN_VERSION_template_haskell(2,15,0)+transformTypeFamilies eo (AppKindT typ kind) = flip AppKindT kind <$> transformTypeFamilies eo typ+transformTypeFamilies eo (ImplicitParamT s typ) = ImplicitParamT s <$> transformTypeFamilies eo typ+#endif+transformTypeFamilies _ typ = return typ --- | Get an expression to be used for getTypeScriptType.--- For datatypes of kind * this is easy, since we can just evaluate the string literal in TH.--- For higher-kinded types, we need to make an expression which evaluates the template types and fills it in.-#if MIN_VERSION_th_abstraction(0,3,0)-getTypeExpression :: DatatypeInfo -> Q Exp-getTypeExpression (DatatypeInfo {datatypeInstTypes=[], ..}) = return $ stringE $ getTypeName datatypeName-getTypeExpression (DatatypeInfo {datatypeInstTypes=vars, ..}) = do-#else-getTypeExpression :: DatatypeInfo -> Q Exp-getTypeExpression (DatatypeInfo {datatypeVars=[], ..}) = return $ stringE $ getTypeName datatypeName-getTypeExpression (DatatypeInfo {datatypeVars=vars, ..}) = do++searchForConstraints :: ExtraTypeScriptOptions -> Type -> Name -> WriterT [GenericInfo] Q ()+searchForConstraints eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) var+  | typ == VarT var && (name `L.elem` typeFamiliesToMapToTypeScript) = lift (reify name) >>= \case+      FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) _) _ -> do+        tell [GenericInfo var (TypeFamilyKey typeFamilyName)]+        searchForConstraints eo typ var+      _ -> searchForConstraints eo typ var+  | otherwise = searchForConstraints eo typ var+searchForConstraints eo (AppT typ1 typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var+searchForConstraints eo (SigT typ _) var = searchForConstraints eo typ var+searchForConstraints eo (InfixT typ1 _ typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var+searchForConstraints eo (UInfixT typ1 _ typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var+searchForConstraints eo (ParensT typ) var = searchForConstraints eo typ var+#if MIN_VERSION_template_haskell(2,15,0)+searchForConstraints eo (AppKindT typ _) var = searchForConstraints eo typ var+searchForConstraints eo (ImplicitParamT _ typ) var = searchForConstraints eo typ var #endif-  let baseName = stringE $ getTypeName datatypeName-  let typeNames = ListE [getTypeAsStringExp typ | typ <- vars]-  let headType = AppE (VarE 'head) typeNames-  let tailType = AppE (VarE 'tail) typeNames-  let comma = stringE ", "-  x <- newName "x"-  let tailsWithCommas = AppE (VarE 'mconcat) (CompE [BindS (VarP x) tailType, NoBindS (AppE (AppE (VarE 'mappend) comma) (VarE x))])-  let brackets = AppE (VarE 'mconcat) (ListE [stringE "<", headType, tailsWithCommas, stringE ">"])+searchForConstraints _ _ _ = return () -  return $ (AppE (AppE (VarE 'mappend) baseName) brackets)+hasFreeTypeVariable :: Type -> Bool+hasFreeTypeVariable (VarT _) = True+hasFreeTypeVariable (AppT typ1 typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2+hasFreeTypeVariable (SigT typ _) = hasFreeTypeVariable typ+hasFreeTypeVariable (InfixT typ1 _ typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2+hasFreeTypeVariable (UInfixT typ1 _ typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2+hasFreeTypeVariable (ParensT typ) = hasFreeTypeVariable typ+#if MIN_VERSION_template_haskell(2,15,0)+hasFreeTypeVariable (AppKindT typ _) = hasFreeTypeVariable typ+hasFreeTypeVariable (ImplicitParamT _ typ) = hasFreeTypeVariable typ+#endif+hasFreeTypeVariable _ = False +unifyGenericVariable :: [GenericInfo] -> String+unifyGenericVariable genericInfos = case [nameBase name | GenericInfo _ (TypeFamilyKey name) <- genericInfos] of+  [] -> ""+  names -> " extends keyof " <> (L.intercalate " & " names)+ -- * Convenience functions  -- | Convenience function to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instances simultaneously, so the instances are guaranteed to be in sync. ----- This function is given mainly as an illustration. If you want some other permutation of instances, such as 'A.ToJSON' and 'A.TypeScript' only, just take a look at the source and write your own version.+-- This function is given mainly as an illustration.+-- If you want some other permutation of instances, such as 'A.ToJSON' and 'A.TypeScript' only, just take a look at the source and write your own version. -- -- @since 0.1.0.4 deriveJSONAndTypeScript :: Options@@ -339,106 +390,21 @@                         -> Name                         -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations.                         -> Q [Dec]-deriveJSONAndTypeScript options name = do-  ts <- deriveTypeScript options name-  json <- A.deriveJSON options name-  return $ ts <> json---- * Util stuff--lastNameComponent :: String -> String-lastNameComponent x = T.unpack $ last $ T.splitOn "." (T.pack x)--lastNameComponent' :: Name -> String-lastNameComponent' = lastNameComponent . show--getInterfaceName :: Name -> String-getInterfaceName x = "I" <> (lastNameComponent' x)--getTypeName :: Name -> String-getTypeName x = lastNameComponent $ show x--allConstructorsAreNullary :: [ConstructorInfo] -> Bool-allConstructorsAreNullary constructors = and $ fmap isConstructorNullary constructors--isConstructorNullary :: ConstructorInfo -> Bool-isConstructorNullary (ConstructorInfo {constructorVariant, constructorFields}) = (constructorVariant == NormalConstructor) && (constructorFields == [])---- 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 typ = AppT (ConT ''TypeScript) typ-#else-getDatatypePredicate typ = ClassP ''TypeScript [typ]-#endif--getTypeAsStringExp :: Type -> Exp-getTypeAsStringExp typ = AppE (VarE 'getTypeScriptType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ))--getOptionalAsBoolExp :: Type -> Exp-getOptionalAsBoolExp typ = AppE (VarE 'getTypeScriptOptional) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ))--isTaggedObject (sumEncoding -> TaggedObject _ _) = True-isTaggedObject _ = False---- | Get the type of a tuple of constructor fields, as when we're packing a record-less constructor into a list-getTupleType constructorFields = case length constructorFields of-  0 -> AppT ListT (ConT ''())-  1 -> head constructorFields-  x -> applyToArgsT (ConT $ tupleTypeName x) constructorFields---- | Helper to apply a type constructor to a list of type args-applyToArgsT :: Type -> [Type] -> Type-applyToArgsT constructor [] = constructor-applyToArgsT constructor (x:xs) = applyToArgsT (AppT constructor x) xs---- | Helper to apply a function a list of args-applyToArgsE :: Exp -> [Exp] -> Exp-applyToArgsE f [] = f-applyToArgsE f (x:xs) = applyToArgsE (AppE f x) xs--stringE = LitE . StringL---- Between Template Haskell 2.10 and 2.11, InstanceD got an additional argument-#if MIN_VERSION_template_haskell(2,11,0)-mkInstance context typ decs = InstanceD Nothing context typ decs-#else-mkInstance context typ decs = InstanceD context typ decs-#endif---- 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 = tagSingleConstructors 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 {..}) = do-  -- Check that necessary language extensions are turned on-  scopedTypeVariablesEnabled <- isExtEnabled ScopedTypeVariables-  kindSignaturesEnabled <- isExtEnabled KindSignatures-  when (not scopedTypeVariablesEnabled) $ error [i|The ScopedTypeVariables extension is required; please enable it before calling deriveTypeScript. (For example: put {-# LANGUAGE ScopedTypeVariables #-} at the top of the file.)|]-  when ((not kindSignaturesEnabled) && (length datatypeVars > 0)) $ 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 ObjectWithSingleField = True-isObjectWithSingleField _ = False+deriveJSONAndTypeScript options name = (<>) <$> (deriveTypeScript options name) <*> (A.deriveJSON options name) --- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this-isTwoElemArray TwoElemArray = True-isTwoElemArray _ = False+deriveJSONAndTypeScript' :: Options+                         -- ^ Encoding options.+                         -> Name+                         -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations.+                         -> ExtraTypeScriptOptions+                         -- ^ Extra options to control advanced features.+                         -> Q [Dec]+deriveJSONAndTypeScript' options name extraOptions = (<>) <$> (deriveTypeScript' options name extraOptions) <*> (A.deriveJSON options name) --- 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-#if MIN_VERSION_aeson(1,0,0)-isUntaggedValue UntaggedValue = True-#endif-isUntaggedValue _ = False+-- | Generates a 'TypeScript' instance declaration for the given data type.+deriveTypeScript :: Options+                 -- ^ Encoding options.+                 -> Name+                 -- ^ Name of the type for which to generate a 'TypeScript' instance declaration.+                 -> Q [Dec]+deriveTypeScript options name = deriveTypeScript' options name defaultExtraTypeScriptOptions

@@ -1,11 +1,12 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, PolyKinds #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, PolyKinds, StandaloneDeriving #-}  module Data.Aeson.TypeScript.Types where  import qualified Data.Aeson as A-import qualified Data.Aeson.TH as A-import Data.Data+import Data.Proxy import Data.String+import Data.Typeable+import Language.Haskell.TH  -- | The typeclass that defines how a type is turned into TypeScript. --@@ -38,7 +39,7 @@ -- instance (TypeScript a) => TypeScript (Set a) where --   getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]"; -- @-class TypeScript a where+class (Typeable a) => TypeScript a where   getTypeScriptDeclarations :: Proxy a -> [TSDeclaration]   -- ^ Get the declaration(s) needed for this type.   getTypeScriptDeclarations _ = []@@ -50,17 +51,38 @@   -- ^ Get a flag representing whether this type is optional.   getTypeScriptOptional _ = False +  getParentTypes :: Proxy a -> [TSType]+  -- ^ Get the types that this type depends on. This is useful for generating transitive closures of necessary types.+  getParentTypes _ = []++  isGenericVariable :: Proxy a -> Bool+  -- ^ Special flag to indicate whether this type corresponds to a template variable.+  isGenericVariable _ = False++-- | An existential wrapper for any TypeScript instance.+data TSType = forall a. (Typeable a, TypeScript a) => TSType { unTSType :: Proxy a }++instance Eq TSType where+  (TSType p1) == (TSType p2) = typeRep p1 == typeRep p2++instance Ord TSType where+  (TSType p1) `compare` (TSType p2) = typeRep p1 `compare` typeRep p2++instance Show TSType where+  show (TSType proxy) = show $ typeRep proxy+ data TSDeclaration = TSInterfaceDeclaration { interfaceName :: String                                             , interfaceGenericVariables :: [String]                                             , interfaceMembers :: [TSField] }                    | TSTypeAlternatives { typeName :: String                                         , typeGenericVariables :: [String]                                         , alternativeTypes :: [String]}-  deriving (Show, Eq)+                   | TSRawDeclaration { text :: String }+  deriving (Show, Eq, Ord)  data TSField = TSField { fieldOptional :: Bool                        , fieldName :: String-                       , fieldType :: String } deriving (Show, Eq)+                       , fieldType :: String } deriving (Show, Eq, Ord)  newtype TSString a = TSString { unpackTSString :: String } deriving Show @@ -76,14 +98,87 @@   -- ^ Function applied to generated interface names   , typeNameModifier :: String -> String   -- ^ Function applied to generated type names+  , exportMode :: ExportMode+  -- ^ Whether to include the export keyword in declarations+  , typeAlternativesFormat :: SumTypeFormat+  -- ^ How to format the declaration of the alternatives when multiple constructors exist   } +data ExportMode =+  ExportEach+  -- ^ Prefix every declaration with the "export" keyword (suitable for putting in a TypeScripe module)+  | ExportNone+  -- ^ No exporting (suitable for putting in a .d.ts file)++-- | TODO: docstrings here+data SumTypeFormat =+  TypeAlias+  | Enum+  | EnumWithType+  deriving (Eq, Show)++defaultFormattingOptions :: FormattingOptions defaultFormattingOptions = FormattingOptions   { numIndentSpaces = 2   , interfaceNameModifier = id   , typeNameModifier = id+  , exportMode = ExportNone+  , typeAlternativesFormat = TypeAlias   }  -- | Convenience typeclass class you can use to "attach" a set of Aeson encoding options to a type. class HasJSONOptions a where   getJSONOptions :: (Proxy a) -> A.Options++data T = T+data T1 = T1+data T2 = T2+data T3 = T3+data T4 = T4+data T5 = T5+data T6 = T6+data T7 = T7+data T8 = T8+data T9 = T9+data T10 = T10++instance TypeScript T where getTypeScriptType _ = "T"; isGenericVariable _ = True+instance TypeScript T1 where getTypeScriptType _ = "T1"; isGenericVariable _ = True+instance TypeScript T2 where getTypeScriptType _ = "T2"; isGenericVariable _ = True+instance TypeScript T3 where getTypeScriptType _ = "T3"; isGenericVariable _ = True+instance TypeScript T4 where getTypeScriptType _ = "T4"; isGenericVariable _ = True+instance TypeScript T5 where getTypeScriptType _ = "T5"; isGenericVariable _ = True+instance TypeScript T6 where getTypeScriptType _ = "T6"; isGenericVariable _ = True+instance TypeScript T7 where getTypeScriptType _ = "T7"; isGenericVariable _ = True+instance TypeScript T8 where getTypeScriptType _ = "T8"; isGenericVariable _ = True+instance TypeScript T9 where getTypeScriptType _ = "T9"; isGenericVariable _ = True+instance TypeScript T10 where getTypeScriptType _ = "T10"; isGenericVariable _ = True++allStarConstructors :: [Type]+allStarConstructors = [ConT ''T1, ConT ''T2, ConT ''T3, ConT ''T4, ConT ''T5, ConT ''T6, ConT ''T7, ConT ''T8, ConT ''T9, ConT ''T10]++allStarConstructors' :: [Name]+allStarConstructors' = [''T1, ''T2, ''T3, ''T4, ''T5, ''T6, ''T7, ''T8, ''T9, ''T10]++-- | Type variable gathering++data ExtraTypeScriptOptions = ExtraTypeScriptOptions {+  typeFamiliesToMapToTypeScript :: [Name]+  }++defaultExtraTypeScriptOptions :: ExtraTypeScriptOptions+defaultExtraTypeScriptOptions = ExtraTypeScriptOptions []++data ExtraDeclOrGenericInfo = ExtraDecl Exp+                            | ExtraGeneric GenericInfo+                            | ExtraTopLevelDecs [Dec]+                            | ExtraConstraint Type+                            | ExtraParentType Type+  deriving Show++data GenericInfo = GenericInfo Name GenericInfoExtra+  deriving Show++data GenericInfoExtra = NormalStar+                      | TypeFamilyKey Name+  deriving Show

@@ -0,0 +1,166 @@+{-# 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.IsString+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 {datatypeInstTypes}) = datatypeInstTypes+#else+getDataTypeVars (DatatypeInfo {datatypeVars}) = datatypeVars+#endif++setDataTypeVars :: DatatypeInfo -> [Type] -> DatatypeInfo+#if MIN_VERSION_th_abstraction(0,3,0)+setDataTypeVars dti@(DatatypeInfo {}) vars = dti { datatypeInstTypes = vars }+#else+setDataTypeVars dti@(DatatypeInfo {}) vars = dti { datatypeVars = vars }+#endif++dropLeadingIFromInterfaceName :: TSDeclaration -> TSDeclaration+dropLeadingIFromInterfaceName decl@(TSInterfaceDeclaration {interfaceName=('I':xs)}) = decl { interfaceName = xs }+dropLeadingIFromInterfaceName decl@(TSTypeAlternatives {typeName=('I':xs)}) = decl { typeName = xs }+dropLeadingIFromInterfaceName x = x       ++lastNameComponent :: String -> String+lastNameComponent x = T.unpack $ last $ T.splitOn "." (T.pack x)++lastNameComponent' :: Name -> String+lastNameComponent' = lastNameComponent . show++getTypeName :: Name -> String+getTypeName x = lastNameComponent $ show x++allConstructorsAreNullary :: [ConstructorInfo] -> Bool+allConstructorsAreNullary constructors = and $ fmap isConstructorNullary constructors++isConstructorNullary :: ConstructorInfo -> Bool+isConstructorNullary (ConstructorInfo {constructorVariant, constructorFields}) = (constructorVariant == NormalConstructor) && (constructorFields == [])++-- 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 typ = AppT (ConT ''TypeScript) typ+#else+getDatatypePredicate typ = ClassP ''TypeScript [typ]+#endif++getTypeAsStringExp :: Type -> Q Exp+getTypeAsStringExp typ = [|getTypeScriptType (Proxy :: Proxy $(return typ))|]++getOptionalAsBoolExp :: Type -> Q Exp+getOptionalAsBoolExp typ = [|getTypeScriptOptional (Proxy :: Proxy $(return typ))|]++-- | Helper to apply a type constructor to a list of type args+applyToArgsT :: Type -> [Type] -> Type+applyToArgsT constructor [] = constructor+applyToArgsT constructor (x:xs) = applyToArgsT (AppT constructor x) xs++-- | Helper to apply a function a list of args+applyToArgsE :: Exp -> [Exp] -> Exp+applyToArgsE f [] = f+applyToArgsE f (x:xs) = applyToArgsE (AppE f x) 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 = tagSingleConstructors 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 {..}) = do+  -- Check that necessary language extensions are turned on+  scopedTypeVariablesEnabled <- isExtEnabled ScopedTypeVariables+  kindSignaturesEnabled <- isExtEnabled KindSignatures+  when (not scopedTypeVariablesEnabled) $ error [i|The ScopedTypeVariables extension is required; please enable it before calling deriveTypeScript. (For example: put {-# LANGUAGE ScopedTypeVariables #-} at the top of the file.)|]+  when ((not kindSignaturesEnabled) && (length datatypeVars > 0)) $ 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 ObjectWithSingleField = True+isObjectWithSingleField _ = False++-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this+isTwoElemArray :: SumEncoding -> Bool+isTwoElemArray TwoElemArray = True+isTwoElemArray _ = 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 UntaggedValue = True+#endif+isUntaggedValue _ = 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 context typ decs = InstanceD Nothing context typ decs+#else+mkInstance context typ decs = InstanceD context typ decs+#endif++namesAndTypes :: Options -> ConstructorInfo -> [(String, Type)]+namesAndTypes options ci = case constructorVariant ci of+  RecordConstructor names -> zip (fmap ((fieldLabelModifier options) . lastNameComponent') names) (constructorFields ci)+  _ -> case sumEncoding options of+    TaggedObject _ contentsFieldName+      | isConstructorNullary ci -> []+      | otherwise -> [(contentsFieldName, contentsTupleType ci)]+    _ -> [(constructorNameToUse options ci, contentsTupleType ci)]++constructorNameToUse :: Options -> ConstructorInfo -> String+constructorNameToUse options ci = (constructorTagModifier options) $ lastNameComponent' (constructorName 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 ci = let fields = constructorFields ci in+  case length fields of+    0 -> AppT ListT (ConT ''())+    1 -> head fields+    x -> applyToArgsT (ConT $ tupleTypeName x) fields++getBracketsExpression :: Bool -> [(Name, String)] -> Q Exp+getBracketsExpression _ [] = [|""|]+getBracketsExpression includeSuffix names =+  [|let vars = $(genericVariablesListExpr includeSuffix names) in "<" <> L.intercalate ", " vars <> ">"|]++getBracketsExpressionAllTypesNoSuffix :: [(Name, String)] -> Q Exp+getBracketsExpressionAllTypesNoSuffix [] = [|""|]+getBracketsExpressionAllTypesNoSuffix names = [|"<" <> L.intercalate ", " $(listE [ [|(getTypeScriptType (Proxy :: Proxy $(varT x)))|] | (x, _suffix) <- names]) <> ">"|]++genericVariablesListExpr :: Bool -> [(Name, String)] -> Q Exp+genericVariablesListExpr includeSuffix genericVariables = listE (fmap (\((_, suffix), correspondingGeneric) ->+  [|(getTypeScriptType (Proxy :: Proxy $(return correspondingGeneric))) <> $(TH.stringE (if includeSuffix then suffix else ""))|])+  (case genericVariables of+      [x] -> [(x, ConT ''T)]+      xs -> zip xs allStarConstructors)+  )++isStarType :: Type -> Maybe Name+isStarType (SigT (VarT n) StarT) = Just n+isStarType _ = Nothing

@@ -0,0 +1,48 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++module Basic (tests) where++import Data.Aeson as A+import Data.Aeson.TypeScript.TH+import Data.Aeson.TypeScript.Types+import Data.Proxy+import Data.String.Interpolate.IsString+import Prelude hiding (Double)+import Test.Hspec+++data Unit1 = Unit1+$(deriveTypeScript A.defaultOptions ''Unit1)++data Unit2 = Unit2+$(deriveTypeScript (A.defaultOptions { A.tagSingleConstructors = True+                                     , A.constructorTagModifier = const "foo" }) ''Unit2)++tests :: SpecWith ()+tests = describe "Basic tests" $ do+  describe "tagSingleConstructors and constructorTagModifier" $ do+    it [i|Works with a normal unit|] $ do+      (getTypeScriptDeclarations (Proxy :: Proxy Unit1)) `shouldBe` ([+        TSTypeAlternatives "Unit1" [] ["IUnit1"]+        , TSTypeAlternatives "IUnit1" [] ["void[]"]+        ])++    it [i|Works with a unit with constructorTagModifier|] $ do+      (getTypeScriptDeclarations (Proxy :: Proxy Unit2)) `shouldBe` ([])+++main :: IO ()+main = hspec tests

@@ -0,0 +1,34 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE QuasiQuotes #-}++module Formatting (tests) where++import Data.Aeson (defaultOptions)+import Data.Aeson.TypeScript.TH+import Data.Aeson.TypeScript.Types+import Data.Proxy+import Data.String.Interpolate.IsString+import Test.Hspec++data D = S | F deriving (Eq, Show)++$(deriveTypeScript defaultOptions ''D)++tests :: Spec+tests = do+  describe "Formatting" $+    describe "when given a Sum Type" $ do+      describe "and the TypeAlias format option is set" $+        it "should generate a TS string literal type" $+          formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @D Proxy) `shouldBe`+            [i|type D = "S" | "F";|]+      describe "and the Enum format option is set" $+        it "should generate a TS Enum" $+          formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = Enum }) (getTypeScriptDeclarations @D Proxy) `shouldBe`+            [i|enum D { S, F }|]+      describe "and the EnumWithType format option is set" $+        it "should generate a TS Enum with a type declaration" $+          formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = EnumWithType }) (getTypeScriptDeclarations @D Proxy) `shouldBe`+            [i|enum DEnum { S="S", F="F" }\n\ntype D = keyof typeof DEnum;|]

@@ -1,4 +1,17 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}  module HigherKind (tests) where @@ -32,10 +45,11 @@ $(deriveJSON A.defaultOptions ''HigherKindWithUnary)  +tests :: SpecWith () tests = describe "Higher kinds" $ do   describe "Kind * -> *" $ do     it [i|makes the declaration and types correctly|] $ do-      (getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) `shouldBe` ([+      (getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) `shouldBe` ([         TSTypeAlternatives "HigherKind" ["T"] ["IHigherKind<T>"],         TSInterfaceDeclaration "IHigherKind" ["T"] [TSField False "higherKindList" "T[]"]         ])@@ -51,14 +65,14 @@         ])      it [i|works with an interface inside|] $ do-      (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary)) `shouldBe` ([+      (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T))) `shouldBe` ([         TSTypeAlternatives "HigherKindWithUnary" ["T"] ["IUnary<T>"],         TSTypeAlternatives "IUnary" ["T"] ["number"]         ])    describe "Kind * -> * -> *" $ do     it [i|makes the declaration and type correctly|] $ do-      (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) `shouldBe` ([+      (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) `shouldBe` ([         TSTypeAlternatives "DoubleHigherKind" ["T1","T2"] ["IDoubleHigherKind<T1, T2>"],         TSInterfaceDeclaration "IDoubleHigherKind" ["T1","T2"] [TSField False "someList" "T2[]"                                                                , TSField False "higherKindThing" "HigherKind<T1>"]@@ -69,9 +83,9 @@    describe "TSC compiler checks" $ do     it "type checks everything with tsc" $ do-      let declarations = ((getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) <>-                          (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) <>-                          (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary))+      let declarations = ((getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) <>+                          (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) <>+                          (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T)))                          )        let typesAndValues = [(getTypeScriptType (Proxy :: Proxy (HigherKind Int)) , A.encode (HigherKind [42 :: Int]))@@ -86,11 +100,12 @@       testTypeCheckDeclarations declarations typesAndValues  +main :: IO () main = hspec tests -+main' :: IO () main' = putStrLn $ formatTSDeclarations (-   (getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) <>-   (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) <>-   (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary))+   (getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) <>+   (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) <>+   (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T)))   )

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Live where++import Data.Aeson as A+import Data.Aeson.TypeScript.Recursive+import Data.Aeson.TypeScript.TH+import Data.Function+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.String.Interpolate.IsString+import qualified Data.Text as T+import Prelude hiding (Double)+++instance TypeScript Identity where getTypeScriptType _ = "any"++data SingleDE = SingleDE+instance TypeScript SingleDE where getTypeScriptType _ = [i|"single"|]++data K8SDE = K8SDE+instance TypeScript K8SDE where getTypeScriptType _ = [i|"k8s"|]++data SingleNodeEnvironment = SingleNodeEnvironment+  deriving (Eq, Show)+instance TypeScript SingleNodeEnvironment where getTypeScriptType _ = [i|"single_node_env"|]+                                  +data K8SEnvironment = K8SEnvironment+  deriving (Eq, Show)+instance TypeScript K8SEnvironment where getTypeScriptType _ = [i|"k8s_env"|]++data Nullable (c :: Type -> Type) x+data Exposed x+type family Columnar (f :: Type -> Type) x where+    Columnar Exposed x = Exposed x+    Columnar Identity x = x+    Columnar (Nullable c) x = Columnar c (Maybe x)+    Columnar f x = f x++type family DeployEnvironment env = result | result -> env where+  DeployEnvironment SingleNodeEnvironment = SingleDE+  DeployEnvironment K8SEnvironment = K8SDE+  DeployEnvironment T = ()++-- * The main type++data UserT env f = User {+  _userUsername :: Columnar f T.Text+  , _userCreatedAt  :: Columnar f Int+  , _userDeployEnvironment  :: Columnar f (DeployEnvironment env)+  }++$(deriveTypeScript' A.defaultOptions ''UserT (ExtraTypeScriptOptions [''DeployEnvironment]))++main :: IO ()+main = getTypeScriptDeclarationsRecursively (Proxy :: Proxy (UserT T Identity))+     & formatTSDeclarations+     & putStrLn

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Live2 where++import Data.Aeson as A+import Data.Aeson.TypeScript.TH+import Data.Function+import Data.Proxy++       +data TestT a = TestT {+  listOfA :: [a]+  , maybeA :: Maybe a+  }+$(deriveTypeScript A.defaultOptions ''TestT)++main :: IO ()+main = getTypeScriptDeclarations (Proxy :: Proxy (TestT Int))+     & formatTSDeclarations+     & putStrLn

@@ -0,0 +1,32 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++module LiveLogging where++import Data.Kind+import Prelude hiding (Double)+++data LoggingSource = SGeneral++data LoggingSourceTagged s where+  General :: LoggingSourceTagged 'SGeneral++type family ParamsFamily (q :: LoggingSource) :: Type where+  ParamsFamily 'SGeneral = String++data HigherKindWithTypeFamily s = TapMessageParams { params :: ParamsFamily s }+-- $(deriveTypeScript A.defaultOptions ''HigherKindWithTypeFamily)++-- main = do+--   putStrLn $(stringE . pprint =<< (deriveTypeScript A.defaultOptions ''TestT))

@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module NoOmitNothingFields (main, tests) where++import Data.Aeson as A+import Data.Aeson.TypeScript.TH+import Data.Aeson.TypeScript.Types+import Data.Proxy+import Test.Hspec+import TestBoilerplate++$(testDeclarations "NoOmitNothingFields" (A.defaultOptions {omitNothingFields=False}))++main :: IO ()+main = hspec $ describe "NoOmitNothingFields" $ do+  it "encodes as expected" $ do+    let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional)++    decls `shouldBe` [TSInterfaceDeclaration {+                         interfaceName = "Optional"+                         , interfaceGenericVariables = []+                         , interfaceMembers = [+                             TSField {fieldOptional = False+                                     , fieldName = "optionalInt"+                                     , fieldType = "number | null"}+                             ]+                         }]++  tests

@@ -1,13 +1,23 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module ObjectWithSingleFieldNoTagSingleConstructors (tests) where+module ObjectWithSingleFieldNoTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate-import Util  $(testDeclarations "ObjectWithSingleField with tagSingleConstructors=False" (A.defaultOptions {sumEncoding=ObjectWithSingleField})) +main :: IO () main = hspec tests

@@ -1,13 +1,24 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module ObjectWithSingleFieldTagSingleConstructors (tests) where+module ObjectWithSingleFieldTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util  $(testDeclarations "ObjectWithSingleField with tagSingleConstructors=True" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=ObjectWithSingleField})) +main :: IO () main = hspec tests

@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module OmitNothingFields (main, tests) where++import Data.Aeson as A+import Data.Aeson.TypeScript.TH+import Data.Aeson.TypeScript.Types+import Data.Proxy+import Test.Hspec+import TestBoilerplate++$(testDeclarations "OmitNothingFields" (A.defaultOptions {omitNothingFields=True}))++main :: IO ()+main = hspec $ describe "OmitNothingFields" $ do+  it "encodes as expected" $ do+    let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional)++    decls `shouldBe` [TSInterfaceDeclaration {+                         interfaceName = "Optional"+                         , interfaceGenericVariables = []+                         , interfaceMembers = [+                             TSField {fieldOptional = True+                                     , fieldName = "optionalInt"+                                     , fieldType = "number"}+                             ]+                         }]++  tests

@@ -3,7 +3,10 @@  import Test.Hspec +import qualified Formatting import qualified HigherKind+import qualified TypeFamilies+ import qualified ObjectWithSingleFieldNoTagSingleConstructors import qualified ObjectWithSingleFieldTagSingleConstructors import qualified TaggedObjectNoTagSingleConstructors@@ -12,8 +15,16 @@ import qualified TwoElemArrayTagSingleConstructors import qualified UntaggedNoTagSingleConstructors import qualified UntaggedTagSingleConstructors+import qualified OmitNothingFields+import qualified NoOmitNothingFields ++main :: IO () main = hspec $ do+  Formatting.tests+  HigherKind.tests+  TypeFamilies.tests+   ObjectWithSingleFieldTagSingleConstructors.tests   ObjectWithSingleFieldNoTagSingleConstructors.tests   TaggedObjectTagSingleConstructors.tests@@ -22,4 +33,5 @@   TwoElemArrayNoTagSingleConstructors.tests   UntaggedTagSingleConstructors.tests   UntaggedNoTagSingleConstructors.tests-  HigherKind.tests+  OmitNothingFields.tests+  NoOmitNothingFields.tests

@@ -1,13 +1,23 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module TaggedObjectNoTagSingleConstructors (tests) where+module TaggedObjectNoTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate-import Util  $(testDeclarations "TaggedObject with tagSingleConstructors=False" A.defaultOptions) +main :: IO () main = hspec tests

@@ -1,13 +1,24 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module TaggedObjectTagSingleConstructors (tests) where+module TaggedObjectTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util  $(testDeclarations "TaggedObject with tagSingleConstructors=True" (setTagSingleConstructors A.defaultOptions)) +main :: IO () main = hspec tests

@@ -1,4 +1,16 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module TestBoilerplate where @@ -6,8 +18,11 @@ import qualified Data.Aeson as A import Data.Aeson.TH as A import Data.Aeson.TypeScript.TH+import Data.Functor.Identity+import Data.Kind import Data.Proxy-import Language.Haskell.TH+import Data.String.Interpolate.IsString+import Language.Haskell.TH hiding (Type) import Test.Hspec import Util @@ -19,8 +34,34 @@ data Hybrid = HybridSimple Int | HybridRecord { hybridString :: String } data TwoConstructor = Con1 { con1String :: String } | Con2 { con2String :: String, con2Int :: Int } data Complex a = Nullary | Unary Int | Product String Char a | Record { testOne :: Int, testTwo :: Bool, testThree :: Complex a} deriving Eq+data Optional = Optional {optionalInt :: Maybe Int} +-- * For testing type families +instance TypeScript Identity where getTypeScriptType _ = "any"++data SingleDE = SingleDE+instance TypeScript SingleDE where getTypeScriptType _ = [i|"single"|]++data K8SDE = K8SDE+instance TypeScript K8SDE where getTypeScriptType _ = [i|"k8s"|]++data SingleNodeEnvironment = SingleNodeEnvironment deriving (Eq, Show)+instance TypeScript SingleNodeEnvironment where getTypeScriptType _ = [i|"single_node_env"|]++data K8SEnvironment = K8SEnvironment deriving (Eq, Show)+instance TypeScript K8SEnvironment where getTypeScriptType _ = [i|"k8s_env"|]++data Nullable (c :: Type -> Type) x+data Exposed x+type family Columnar (f :: Type -> Type) x where+    Columnar Exposed x = Exposed x+    Columnar Identity x = x+    Columnar (Nullable c) x = Columnar c (Maybe x)+    Columnar f x = f x++-- * Declarations+ testDeclarations :: String -> A.Options -> Q [Dec] testDeclarations testName aesonOptions = do   decls :: [Dec] <- execWriterT $ do@@ -32,6 +73,7 @@     deriveInstances ''Hybrid     deriveInstances ''TwoConstructor     deriveInstances ''Complex+    deriveInstances ''Optional    typesAndValues :: Exp <- [e|[(getTypeScriptType (Proxy :: Proxy Unit), A.encode Unit) @@ -52,7 +94,9 @@                               , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode (Nullary :: Complex Int))                               , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode (Unary 42 :: Complex Int))                               , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode (Product "asdf" 'g' 42 :: Complex Int))-                              , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode ((Record { testOne = 3, testTwo = True, testThree = Product "test" 'A' 123}) :: Complex Int))]+                              , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode ((Record { testOne = 3, testTwo = True, testThree = Product "test" 'A' 123}) :: Complex Int))+                              , (getTypeScriptType (Proxy :: Proxy Optional), A.encode (Optional { optionalInt = Nothing }))+                              , (getTypeScriptType (Proxy :: Proxy Optional), A.encode (Optional { optionalInt = Just 1 }))]                            |]    declarations :: Exp <- [e|getTypeScriptDeclarations (Proxy :: Proxy Unit)@@ -62,10 +106,12 @@                          <> getTypeScriptDeclarations (Proxy :: Proxy TwoField)                          <> getTypeScriptDeclarations (Proxy :: Proxy Hybrid)                          <> getTypeScriptDeclarations (Proxy :: Proxy TwoConstructor)-                         <> getTypeScriptDeclarations (Proxy :: Proxy Complex)+                         <> getTypeScriptDeclarations (Proxy :: Proxy (Complex T))+                         <> getTypeScriptDeclarations (Proxy :: Proxy Optional)                          |] -  tests <- [d|tests = describe $(return $ LitE $ StringL testName) $ it "type checks everything with tsc" $ testTypeCheckDeclarations $(return declarations) $(return typesAndValues)|]+  tests <- [d|tests :: SpecWith ()+              tests = describe $(return $ LitE $ StringL testName) $ it "type checks everything with tsc" $ testTypeCheckDeclarations $(return declarations) $(return typesAndValues)|]    return $ decls ++ tests 

@@ -1,13 +1,23 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module TwoElemArrayNoTagSingleConstructors (tests) where+module TwoElemArrayNoTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate-import Util  $(testDeclarations "TwoElemArray with tagSingleConstructors=False" (A.defaultOptions {sumEncoding=TwoElemArray})) +main :: IO () main = hspec tests

@@ -1,13 +1,24 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module TwoElemArrayTagSingleConstructors (tests) where+module TwoElemArrayTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util  $(testDeclarations "TwoElemArray with tagSingleConstructors=True" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=TwoElemArray})) +main :: IO () main = hspec tests

@@ -0,0 +1,91 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++module TypeFamilies (tests) where++import Data.Aeson as A+import Data.Aeson.TypeScript.Recursive+import Data.Aeson.TypeScript.TH+import Data.Aeson.TypeScript.Types+import Data.Functor.Identity+import Data.Proxy+import Data.String.Interpolate.IsString+import qualified Data.Text as T+import Prelude hiding (Double)+import Test.Hspec+import TestBoilerplate+++type family DeployEnvironment env = result | result -> env where+  DeployEnvironment SingleNodeEnvironment = SingleDE+  DeployEnvironment K8SEnvironment = K8SDE+  DeployEnvironment T = ()+data UserT env f = User {+  _userUsername :: Columnar f T.Text+  , _userCreatedAt  :: Columnar f Int+  , _userDeployEnvironment  :: Columnar f (DeployEnvironment env)+  }+$(deriveTypeScript' A.defaultOptions ''UserT (ExtraTypeScriptOptions [''DeployEnvironment]))++type family DeployEnvironment2 env = result | result -> env where+  DeployEnvironment2 SingleNodeEnvironment = SingleDE+  DeployEnvironment2 K8SEnvironment = K8SDE+  DeployEnvironment2 T = ()+newtype Simple env = Simple (DeployEnvironment2 env)+$(deriveTypeScript' A.defaultOptions ''Simple (ExtraTypeScriptOptions [''DeployEnvironment2]))++tests :: SpecWith ()+tests = describe "Type families" $ do+  describe "simple newtype" $ do+    it [i|makes the declaration and types correctly|] $ do+      (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Simple T))) `shouldBe` ([+        TSInterfaceDeclaration "DeployEnvironment2" [] [+          TSField False "\"single_node_env\"" "\"single\""+          , TSField False "\"k8s_env\"" "\"k8s\""+          , TSField False "T" "void"+          ]+        , TSTypeAlternatives "ISimple" ["T extends keyof DeployEnvironment2"] ["DeployEnvironment2[T]"]+        , TSTypeAlternatives "Simple" ["T extends keyof DeployEnvironment2"] ["ISimple<T>"]+        ])++  describe "Complicated Beam-like user type" $ do+    it [i|makes the declaration and types correctly|] $ do+      (getTypeScriptDeclarations (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([+        TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser<T>"]+        , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [+            TSField False "_userUsername" "string"+            , TSField False "_userCreatedAt" "number"+            , TSField False "_userDeployEnvironment" "DeployEnvironment[T]"+            ]+        ])++    it [i|get the declarations recursively|] $ do+      (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([+        TSInterfaceDeclaration "DeployEnvironment" [] [+          TSField False "\"single_node_env\"" "\"single\""+          , TSField False "\"k8s_env\"" "\"k8s\""+          , TSField False "T" "void"+          ]+        , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [+            TSField False "_userUsername" "string"+            , TSField False "_userCreatedAt" "number"+            , TSField False "_userDeployEnvironment" "DeployEnvironment[T]"+            ]+        , TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser<T>"]+        ])++main :: IO ()+main = hspec tests

@@ -1,12 +1,21 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module UntaggedNoTagSingleConstructors (tests) where+module UntaggedNoTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate-import Util  -- Between Aeson 0.11.3.0 and 1.0.0.0, UntaggedValue was added -- Disable these tests if it's not present@@ -16,4 +25,5 @@ tests = describe "UntaggedNoTagSingleConstructors" $ it "tests are disabled for this Aeson version" $ 2 `shouldBe` 2 #endif +main :: IO () main = hspec tests

@@ -1,9 +1,19 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module UntaggedTagSingleConstructors (tests) where+module UntaggedTagSingleConstructors (main, tests) where  import Data.Aeson as A-import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util@@ -13,7 +23,9 @@ #if MIN_VERSION_aeson(1,0,0) $(testDeclarations "UntaggedTagSingleConstructors" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=UntaggedValue})) #else+tests :: SpecWith () tests = describe "UntaggedTagSingleConstructors" $ it "tests are disabled for this Aeson version" $ 2 `shouldBe` 2 #endif +main :: IO () main = hspec tests

@@ -1,10 +1,9 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns #-}+{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, LambdaCase #-}  module Util where  import Control.Monad import Data.Aeson as A-import Data.Aeson.TH as A import Data.Aeson.TypeScript.TH import qualified Data.ByteString.Lazy as B import Data.Proxy@@ -17,6 +16,7 @@ import System.IO.Temp import System.Process +npmInstallScript, yarnInstallScript, localTSC :: String npmInstallScript = "test/assets/npm_install.sh" yarnInstallScript = "test/assets/yarn_install.sh" localTSC = "test/assets/node_modules/.bin/tsc"@@ -25,14 +25,12 @@ isCI = lookupEnv "CI" >>= (return . (== (Just "true")))  getTSC :: IO FilePath-getTSC = do-  isCI <- isCI-  case isCI of-    True -> do-      return "tsc" -- Assume it's set up on the path-    False -> do-      ensureTSCExists-      return localTSC+getTSC = isCI >>= \case+  True -> do+    return "tsc" -- Assume it's set up on the path+  False -> do+    ensureTSCExists+    return localTSC  testTypeCheck :: forall a. (TypeScript a, ToJSON a) => a -> IO () testTypeCheck obj = withSystemTempDirectory "typescript_test" $ \folder -> do@@ -46,19 +44,20 @@    -- "--diagnostics", "--listFiles"   tsc <- getTSC-  readProcess tsc ["--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] ""+  void $ readProcess tsc ["--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] ""    return ()   where tsDeclarations :: [TSDeclaration] = getTypeScriptDeclarations (Proxy :: Proxy a)         tsType :: String = getTypeScriptType (Proxy :: Proxy a)  +getTSFile :: [TSDeclaration] -> [(String, B.ByteString)] -> String getTSFile tsDeclarations typesAndVals = [i| #{formatTSDeclarations tsDeclarations}  #{T.unlines typeLines} |]-  where typeLines = [[i|let x#{index}: #{typ} = #{val};|] | (index, (typ, val)) <- zip [1..] typesAndVals]+  where typeLines = [[i|let x#{index}: #{typ} = #{val};|] | (index, (typ, val)) <- zip [(1 :: Int)..] typesAndVals]   testTypeCheckDeclarations :: [TSDeclaration] -> [(String, B.ByteString)] -> IO ()@@ -70,11 +69,10 @@   writeFile tsFile contents    tsc <- getTSC-  (code, output, err) <- readProcessWithExitCode tsc ["--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] ""+  (code, output, _err) <- readProcessWithExitCode tsc ["--strict", "--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] ""    when (code /= ExitSuccess) $ do-    putStrLn [i|TSC check failed. File contents were\n\n#{contents}|]-    error [i|TSC check failed: #{output}|]+    error [i|TSC check failed: #{output}. File contents were\n\n#{contents}|]    return ()