Fix more issues with Maybes inside tuple encodings

aeson-typescript.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.37.0.
+-- This file has been generated from package.yaml by hpack version 0.38.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -46,6 +46,7 @@ library
   other-modules:
       Data.Aeson.TypeScript.Formatting
       Data.Aeson.TypeScript.Instances
+      Data.Aeson.TypeScript.Instances.TupleGen
       Data.Aeson.TypeScript.Lookup
       Data.Aeson.TypeScript.Transform
       Data.Aeson.TypeScript.TypeManipulation
@@ -89,6 +90,7 @@ test-suite aeson-typescript-tests
       GetDoc
       HigherKind
       LegalNameSpec
+      MaybeTuples
       NoOmitNothingFields
       ObjectWithSingleFieldNoTagSingleConstructors
       ObjectWithSingleFieldTagSingleConstructors
@@ -106,6 +108,7 @@ test-suite aeson-typescript-tests
       Util.Aeson
       Data.Aeson.TypeScript.Formatting
       Data.Aeson.TypeScript.Instances
+      Data.Aeson.TypeScript.Instances.TupleGen
       Data.Aeson.TypeScript.Internal
       Data.Aeson.TypeScript.LegalName
       Data.Aeson.TypeScript.Lookup

src/Data/Aeson/TypeScript/Instances.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverlappingInstances #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeApplications #-}
@@ -13,6 +13,7 @@
 module Data.Aeson.TypeScript.Instances where
 
 import qualified Data.Aeson as A
+import Data.Aeson.TypeScript.Instances.TupleGen
 import Data.Aeson.TypeScript.Types
 import Data.Data
 import Data.Functor.Compose (Compose)
@@ -121,26 +122,8 @@
                            , (TSType (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))
-                           ]
-
-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))
-                           ]
-
-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))
-                           ]
+-- Derive instance TypeScript (a, b), instance TypeScript (a, b, c), etc. up to size 10
+mkTupleInstances 10
 
 instance forall a k (b :: k). (Typeable k, Typeable b, TypeScript a) => TypeScript (Const a b) where
   getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a)

src/Data/Aeson/TypeScript/Instances/TupleGen.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Data.Aeson.TypeScript.Instances.TupleGen where
+
+import Data.Aeson.TypeScript.Types
+import Data.Data
+import Data.List (intercalate)
+import qualified Data.List as L
+import Language.Haskell.TH
+
+
+mkTupleInstance :: Int -> Q Dec
+mkTupleInstance n = do
+  let typeVars = take n $ map (mkName . (:[])) ['a'..]
+      constraints = map (\tv -> AppT (ConT ''TypeScript) (VarT tv)) typeVars
+      tupleType = foldl AppT (TupleT n) (map VarT typeVars)
+      instanceHead = AppT (ConT ''TypeScript) tupleType
+
+  getTypeBody <- buildTypeBody typeVars
+  let getTypeMethod = FunD 'getTypeScriptType [Clause [WildP] (NormalB getTypeBody) []]
+
+  let tsTypes = map (\tv -> AppE (ConE 'TSType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (VarT tv)))) typeVars
+      getParentsMethod = FunD 'getParentTypes [Clause [WildP] (NormalB (AppE (VarE 'L.nub) (ListE tsTypes))) []]
+
+  return $ InstanceD Nothing constraints instanceHead [getTypeMethod, getParentsMethod]
+
+buildTypeBody :: [Name] -> Q Exp
+buildTypeBody typeVars = do
+  let calls = map (\tv -> AppE (VarE 'getTypeScriptTypeOrOptionalNull)
+                              (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (VarT tv)))) typeVars
+      parts = [LitE (StringL "[")] ++ intercalate [LitE (StringL ", ")] (map (:[]) calls) ++ [LitE (StringL "]")]
+  return $ foldr1 (\a b -> InfixE (Just a) (VarE '(++)) (Just b)) parts
+
+mkTupleInstances :: Int -> Q [Dec]
+mkTupleInstances maxArity = mapM mkTupleInstance [2..maxArity]

src/Data/Aeson/TypeScript/Recursive.hs

@@ -24,7 +24,7 @@
 import Data.Aeson.TypeScript.TH
 import Data.Aeson.TypeScript.Util (nothingOnFail)
 import Data.Bifunctor
 import Data.Function
 import qualified Data.List as L
 import Data.Maybe
 import Data.Proxy
@@ -32,7 +32,6 @@
 import Data.String.Interpolate
 import Language.Haskell.TH as TH
 import Language.Haskell.TH.Datatype
-import Language.Haskell.TH.Syntax hiding (lift)
 
 
 getTransitiveClosure :: S.Set TSType -> S.Set TSType

src/Data/Aeson/TypeScript/TH.hs

@@ -145,7 +145,7 @@
   , T9(..)
   , T10(..)
 
   , module Data.Aeson.TypeScript.Instances
   ) where
 
 import Control.Monad
@@ -288,10 +288,8 @@
 
 #if MIN_VERSION_aeson(0,10,0)
       | unwrapUnaryRecords options && (isSingleRecordConstructor ci) -> do
           let [typ] = constructorFields ci
-          stringExp <- lift $ case typ of
-            (AppT (ConT name) t) | name == ''Maybe && not (omitNothingFields options) -> [|$(getTypeAsStringExp t) <> " | null"|]
-            _ -> getTypeAsStringExp typ
+          stringExp <- lift $ [|getTypeScriptTypeOrOptionalNull (Proxy :: Proxy $(return typ))|]
           alternatives <- lift [|TSTypeAlternatives $(TH.stringE interfaceName)
                                                     $(genericVariablesListExpr True genericVariables)
                                                     [$(return stringExp)]
@@ -309,9 +307,7 @@
 
     tupleEncoding = do
       let typ = contentsTupleTypeSubstituted genericVariables ci
-      stringExp <- lift $ case typ of
-        (AppT (ConT name) t) | name == ''Maybe -> [|$(getTypeAsStringExp t) <> " | null"|]
-        _ -> getTypeAsStringExp typ
+      stringExp <- lift $ [|getTypeScriptTypeOrOptionalNull (Proxy :: Proxy $(return typ))|]
 
       lift [|TSTypeAlternatives $(TH.stringE interfaceName)
                                 $(genericVariablesListExpr True genericVariables)
@@ -326,7 +322,7 @@
     getTSFields :: WriterT [ExtraDeclOrGenericInfo] Q [Exp]
     getTSFields = forM (namesAndTypes options genericVariables ci) $ \(name, nameString, typ) -> do
       (fieldTyp, optAsBool) <- lift $ case typ of
-        (AppT (ConT name) t) | name == ''Maybe && not (omitNothingFields options) ->
+        (AppT (ConT name') t) | name' == ''Maybe && not (omitNothingFields options) ->
           ( , ) <$> [|$(getTypeAsStringExp t) <> " | null"|] <*> getOptionalAsBoolExp t
         _ -> ( , ) <$> getTypeAsStringExp typ <*> getOptionalAsBoolExp typ
 

src/Data/Aeson/TypeScript/Types.hs

@@ -70,6 +70,12 @@ class (Typeable a) => TypeScript a where
   -- ^ Special flag to indicate whether this type corresponds to a template variable.
   isGenericVariable _ = False
 
+
+getTypeScriptTypeOrOptionalNull :: TypeScript a => Proxy a -> String
+getTypeScriptTypeOrOptionalNull proxy = getTypeScriptType proxy <> extra
+  where
+    extra = if getTypeScriptOptional proxy then " | null" else ""
+
 -- | An existential wrapper for any TypeScript instance.
 data TSType = forall a. (Typeable a, TypeScript a) => TSType { unTSType :: Proxy a }
 

src/Data/Aeson/TypeScript/Util.hs

@@ -12,6 +12,7 @@
 import Data.Aeson.TypeScript.Types
 import qualified Data.List as L
 import Data.Proxy
+import Data.String (IsString)
 import Data.String.Interpolate
 import qualified Data.Text as T
 import Language.Haskell.TH hiding (stringE)
@@ -82,12 +83,12 @@
 getOptionalAsBoolExp :: Type -> Q Exp
 getOptionalAsBoolExp typ = [|getTypeScriptOptional (Proxy :: Proxy $(return typ))|]
 
--- | Helper to apply a type constructor to a list of type args
+-- | 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
+-- | Apply a function to a list of args
 applyToArgsE :: Exp -> [Exp] -> Exp
 applyToArgsE f [] = f
 applyToArgsE f (x:xs) = applyToArgsE (AppE f x) xs
@@ -183,6 +184,7 @@
 #endif
 mapType _ x = x
 
+tryPromote :: (Eq a1, Eq a2, IsString a2) => Type -> [(a1, (a3, a2))] -> a1 -> Type
 tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "")) = ConT ''T
 tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T")) = ConT ''T
 tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T1")) = ConT ''T1
@@ -222,7 +224,7 @@
 nothingOnFail action = recover (return Nothing) (Just <$> action)
 
 tryGetDoc :: (String -> String) -> Name -> Q Exp
 tryGetDoc haddockModifier n = do
 #if MIN_VERSION_template_haskell(2,18,0)
   maybeDoc <- nothingOnFail (getDoc (DeclDoc n)) >>= \case
     Just (Just doc) -> return $ Just $ Just $ haddockModifier doc

test/Basic.hs

@@ -17,9 +17,6 @@ data Unit2 = Unit2
 $(deriveTypeScript (A.defaultOptions { A.tagSingleConstructors = True
                                      , A.constructorTagModifier = const "foo" }) ''Unit2)
 
-data Test1 = Test1 (Maybe Int)
-deriveTypeScript A.defaultOptions ''Test1
-
 tests :: SpecWith ()
 tests = describe "Basic tests" $ do
   describe "tagSingleConstructors and constructorTagModifier" $ do
@@ -29,17 +26,5 @@ tests = describe "Basic tests" $ do
         , TSTypeAlternatives "IUnit1" [] ["void[]"] Nothing
         ])
 
-    it [i|Works with a unit with constructorTagModifier|] $ do
-      (getTypeScriptDeclarations (Proxy :: Proxy Unit2)) `shouldBe` ([
-        TSTypeAlternatives "Unit2" [] ["\"foo\""] Nothing
-        ])
-
-    it [i|Maybe tuple encoding includes null option|] $ do
-      (getTypeScriptDeclarations (Proxy :: Proxy Test1)) `shouldBe` ([
-        TSTypeAlternatives "Test1" [] ["ITest1"] Nothing
-        , TSTypeAlternatives "ITest1" [] ["number | null"] Nothing
-        ])
-
-
 main :: IO ()
 main = hspec tests

test/MaybeTuples.hs

@@ -0,0 +1,78 @@
+
+module MaybeTuples (tests) where
+
+import Data.Aeson as A
+import Data.Aeson.TypeScript.TH
+import Data.Aeson.TypeScript.Types
+import Data.Proxy
+import Data.String.Interpolate
+import Prelude hiding (Double)
+import Test.Hspec
+
+
+data Maybe1 = Maybe1 (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe1
+
+data Maybe2 = Maybe2 String (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe2
+
+data Maybe3 = Maybe3 String (String, String) (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe3
+
+data Maybe4 = Maybe4 Int Int Int (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe4
+
+data Maybe5 = Maybe5 Int Int Int Int (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe5
+
+data Maybe6 = Maybe6 Int Int Int Int Int (Maybe Int)
+deriveTypeScript A.defaultOptions ''Maybe6
+
+data MaybeRecord = MaybeRecord {
+  foo :: String
+  , bar :: Maybe Int
+  }
+deriveTypeScript A.defaultOptions ''MaybeRecord
+
+tests :: SpecWith ()
+tests = describe "Maybes in tuple encodings" $ do
+  describe "tagSingleConstructors and constructorTagModifier" $ do
+    it [i|Maybe 1 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe1)) `shouldBe` ([
+        TSTypeAlternatives "Maybe1" [] ["IMaybe1"] Nothing
+        , TSTypeAlternatives "IMaybe1" [] ["number | null"] Nothing
+        ])
+
+    it [i|Maybe 2 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe2)) `shouldBe` ([
+        TSTypeAlternatives "Maybe2" [] ["IMaybe2"] Nothing
+        , TSTypeAlternatives "IMaybe2" [] ["[string, number | null]"] Nothing
+        ])
+
+    it [i|Maybe 3 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe3)) `shouldBe` ([
+        TSTypeAlternatives "Maybe3" [] ["IMaybe3"] Nothing
+        , TSTypeAlternatives "IMaybe3" [] ["[string, [string, string], number | null]"] Nothing
+        ])
+
+    it [i|Maybe 4 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe4)) `shouldBe` ([
+        TSTypeAlternatives "Maybe4" [] ["IMaybe4"] Nothing
+        , TSTypeAlternatives "IMaybe4" [] ["[number, number, number, number | null]"] Nothing
+        ])
+
+    it [i|Maybe 5 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe5)) `shouldBe` ([
+        TSTypeAlternatives "Maybe5" [] ["IMaybe5"] Nothing
+        , TSTypeAlternatives "IMaybe5" [] ["[number, number, number, number, number | null]"] Nothing
+        ])
+
+    it [i|Maybe 6 tuple encoding includes null option|] $ do
+      (getTypeScriptDeclarations (Proxy :: Proxy Maybe6)) `shouldBe` ([
+        TSTypeAlternatives "Maybe6" [] ["IMaybe6"] Nothing
+        , TSTypeAlternatives "IMaybe6" [] ["[number, number, number, number, number, number | null]"] Nothing
+        ])
+
+
+main :: IO ()
+main = hspec tests

test/NoOmitNothingFields.hs

@@ -13,9 +13,9 @@ $(testDeclarations "NoOmitNothingFields" (A.defaultOptions {omitNothingFields =
 allTests :: SpecWith ()
 allTests = describe "NoOmitNothingFields" $ do
   it "encodes as expected" $ do
-    let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional)
+    let decls = getTypeScriptDeclarations (Proxy :: Proxy OptionalRecord)
 
-    decls `shouldBe` [TSTypeAlternatives "Optional" [] ["IOptional"] Nothing
-                     , TSInterfaceDeclaration "IOptional" [] [TSField False "optionalInt" "number | null" Nothing] Nothing]
+    decls `shouldBe` [TSTypeAlternatives "OptionalRecord" [] ["IOptionalRecord"] Nothing
+                     , TSInterfaceDeclaration "IOptionalRecord" [] [TSField False "optionalInt" "number | null" Nothing] Nothing]
 
   tests

test/OmitNothingFields.hs

@@ -13,10 +13,10 @@ $(testDeclarations "OmitNothingFields" (A.defaultOptions {omitNothingFields=True
 main :: IO ()
 main = hspec $ describe "OmitNothingFields" $ do
   it "encodes as expected" $ do
-    let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional)
+    let decls = getTypeScriptDeclarations (Proxy :: Proxy OptionalRecord)
 
     decls `shouldBe` [TSInterfaceDeclaration {
-                         interfaceName = "Optional"
+                         interfaceName = "OptionalRecord"
                          , interfaceGenericVariables = []
                          , interfaceMembers = [
                              TSField True "optionalInt" "number" Nothing

test/Spec.hs

@@ -5,11 +5,12 @@
 import Test.Hspec
 
 import qualified Basic
+import qualified ClosedTypeFamilies
 import qualified Formatting
 import qualified Generic
 import qualified GetDoc
 import qualified HigherKind
-import qualified ClosedTypeFamilies
+import qualified MaybeTuples
 
 import qualified LegalNameSpec
 import qualified NoOmitNothingFields
@@ -35,6 +36,7 @@
   GetDoc.tests
 #endif
   HigherKind.tests
+  MaybeTuples.tests
 
   LegalNameSpec.tests
   NoOmitNothingFields.allTests

test/TestBoilerplate.hs

@@ -2,7 +2,7 @@
 
 module TestBoilerplate where
 
 import Control.Monad.Writer.Lazy hiding (Product)
 import qualified Data.Aeson as A
 import Data.Aeson.TH as A
 import Data.Aeson.TypeScript.TH
@@ -29,7 +29,9 @@
 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}
+data OptionalRecord = OptionalRecord {optionalInt :: Maybe Int}
+data OptionalTuple1 = OptionalTuple1 (Maybe Int)
+data OptionalTuple2 = OptionalTuple2 String (Maybe Int)
 data AesonTypes = AesonTypes { aesonValue :: A.Value, aesonObject :: A.Object }
 data Numbers = Numbers {
   natural :: Natural
@@ -87,7 +89,9 @@
     deriveInstances ''Hybrid
     deriveInstances ''TwoConstructor
     deriveInstances ''Complex
-    deriveInstances ''Optional
+    deriveInstances ''OptionalRecord
+    deriveInstances ''OptionalTuple1
+    deriveInstances ''OptionalTuple2
     deriveInstances ''AesonTypes
     deriveInstances ''Numbers
     deriveInstances ''FancyFunctors
@@ -113,8 +117,14 @@
                               , (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 Optional), A.encode (Optional { optionalInt = Nothing }))
-                              , (getTypeScriptType (Proxy :: Proxy Optional), A.encode (Optional { optionalInt = Just 1 }))
+                              , (getTypeScriptType (Proxy :: Proxy OptionalRecord), A.encode (OptionalRecord { optionalInt = Nothing }))
+                              , (getTypeScriptType (Proxy :: Proxy OptionalRecord), A.encode (OptionalRecord { optionalInt = Just 1 }))
+
+                              , (getTypeScriptType (Proxy :: Proxy OptionalTuple1), A.encode (OptionalTuple1 Nothing))
+                              , (getTypeScriptType (Proxy :: Proxy OptionalTuple1), A.encode (OptionalTuple1 (Just 1)))
+
+                              , (getTypeScriptType (Proxy :: Proxy OptionalTuple2), A.encode (OptionalTuple2 "asdf" Nothing))
+                              , (getTypeScriptType (Proxy :: Proxy OptionalTuple2), A.encode (OptionalTuple2 "asdf" (Just 1)))
 
                               , (getTypeScriptType (Proxy :: Proxy AesonTypes), A.encode (AesonTypes {
                                                                                              aesonValue = A.object [("foo" :: AesonKey, A.Number 42)]
@@ -133,7 +143,9 @@
                          <> getTypeScriptDeclarations (Proxy :: Proxy Hybrid)
                          <> getTypeScriptDeclarations (Proxy :: Proxy TwoConstructor)
                          <> getTypeScriptDeclarations (Proxy :: Proxy (Complex T))
-                         <> getTypeScriptDeclarations (Proxy :: Proxy Optional)
+                         <> getTypeScriptDeclarations (Proxy :: Proxy OptionalRecord)
+                         <> getTypeScriptDeclarations (Proxy :: Proxy OptionalTuple1)
+                         <> getTypeScriptDeclarations (Proxy :: Proxy OptionalTuple2)
                          <> getTypeScriptDeclarations (Proxy :: Proxy AesonTypes)
                          <> getTypeScriptDeclarations (Proxy :: Proxy Numbers)
                          <> getTypeScriptDeclarations (Proxy :: Proxy FancyFunctors)