diff --git a/aeson-typescript.cabal b/aeson-typescript.cabal index a448269..2387dd8 100644 --- a/aeson-typescript.cabal +++ b/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 diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index 988aec0..2f61ce6 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -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 @@ instance (TypeScript a, TypeScript b) => TypeScript (Either a b) where , (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) diff --git a/src/Data/Aeson/TypeScript/Instances/TupleGen.hs b/src/Data/Aeson/TypeScript/Instances/TupleGen.hs new file mode 100644 index 0000000..e4ca456 --- /dev/null +++ b/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] diff --git a/src/Data/Aeson/TypeScript/Recursive.hs b/src/Data/Aeson/TypeScript/Recursive.hs index 8eb673c..e5f5daa 100755 --- a/src/Data/Aeson/TypeScript/Recursive.hs +++ b/src/Data/Aeson/TypeScript/Recursive.hs @@ -32,7 +32,6 @@ import qualified Data.Set as S 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 diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index 3cd7227..6f926cf 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -289,9 +289,7 @@ handleConstructor (ExtraTypeScriptOptions {..}) options (DatatypeInfo {..}) gene #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 @@ handleConstructor (ExtraTypeScriptOptions {..}) options (DatatypeInfo {..}) gene 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 @@ handleConstructor (ExtraTypeScriptOptions {..}) options (DatatypeInfo {..}) gene 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 diff --git a/src/Data/Aeson/TypeScript/Types.hs b/src/Data/Aeson/TypeScript/Types.hs index a96f635..910ec73 100644 --- a/src/Data/Aeson/TypeScript/Types.hs +++ b/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 } diff --git a/src/Data/Aeson/TypeScript/Util.hs b/src/Data/Aeson/TypeScript/Util.hs index cedf0bf..29bff97 100644 --- a/src/Data/Aeson/TypeScript/Util.hs +++ b/src/Data/Aeson/TypeScript/Util.hs @@ -12,6 +12,7 @@ import Data.Aeson.TypeScript.Instances () 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 @@ 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 +-- | 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 @@ mapType g (ImplicitParamT x typ) = ImplicitParamT x (mapType g typ) #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 diff --git a/test/Basic.hs b/test/Basic.hs index a6c7a86..a8abb3e 100644 --- a/test/Basic.hs +++ b/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 diff --git a/test/MaybeTuples.hs b/test/MaybeTuples.hs new file mode 100644 index 0000000..d857f97 --- /dev/null +++ b/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 diff --git a/test/NoOmitNothingFields.hs b/test/NoOmitNothingFields.hs index 148e822..4dd6dd8 100644 --- a/test/NoOmitNothingFields.hs +++ b/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 diff --git a/test/OmitNothingFields.hs b/test/OmitNothingFields.hs index 360f2a1..f418b6f 100644 --- a/test/OmitNothingFields.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index d7f7548..11e0626 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,11 +5,12 @@ module Main where 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 @@ main = hspec $ parallel $ do GetDoc.tests #endif HigherKind.tests + MaybeTuples.tests LegalNameSpec.tests NoOmitNothingFields.allTests diff --git a/test/TestBoilerplate.hs b/test/TestBoilerplate.hs index 3b45997..bd4bd92 100644 --- a/test/TestBoilerplate.hs +++ b/test/TestBoilerplate.hs @@ -29,7 +29,9 @@ data TwoField = TwoField { doubleInt :: Int, doubleString :: String } 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 @@ testDeclarations testName aesonOptions = do deriveInstances ''Hybrid deriveInstances ''TwoConstructor deriveInstances ''Complex - deriveInstances ''Optional + deriveInstances ''OptionalRecord + deriveInstances ''OptionalTuple1 + deriveInstances ''OptionalTuple2 deriveInstances ''AesonTypes deriveInstances ''Numbers deriveInstances ''FancyFunctors @@ -113,8 +117,14 @@ testDeclarations testName aesonOptions = do , (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 @@ testDeclarations testName aesonOptions = do <> 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)