From cd8e46ae6f103bb78db045f76b84956ec23bd8d3 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 15:43:34 +0200 Subject: [PATCH 01/10] include immediate parents for containers... ...and exclude grandparents. The immediate parents are needed to make sure that we don't miss them when computing closures. The grandparents are not needed -- we'll get them through the immediate parents. --- src/Data/Aeson/TypeScript/Instances.hs | 44 +++++++++++--------------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index dcc10ab..267f268 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -45,7 +45,7 @@ instance TypeScript Char where instance {-# OVERLAPPABLE #-} (TypeScript a) => TypeScript [a] where getTypeScriptType _ = (getTypeScriptType (Proxy :: Proxy a)) ++ "[]" - getParentTypes _ = (TSType (Proxy :: Proxy a)) : (getParentTypes (Proxy :: Proxy a)) + getParentTypes _ = [TSType (Proxy :: Proxy a)] instance {-# OVERLAPPING #-} TypeScript [Char] where getTypeScriptType _ = "string" @@ -56,37 +56,30 @@ instance (TypeScript a, TypeScript b) => TypeScript (Either a b) where , 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))) + getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a)) + , (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)) - : (getParentTypes (Proxy :: Proxy a)) - <> (getParentTypes (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)) - : (getParentTypes (Proxy :: Proxy a)) - <> (getParentTypes (Proxy :: Proxy b)) - <> (getParentTypes (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)) - : (getParentTypes (Proxy :: Proxy a)) - <> (getParentTypes (Proxy :: Proxy b)) - <> (getParentTypes (Proxy :: Proxy c)) - <> (getParentTypes (Proxy :: Proxy d))) + getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy a)) + , (TSType (Proxy :: Proxy b)) + , (TSType (Proxy :: Proxy c)) + , (TSType (Proxy :: Proxy d)) + ] instance (TypeScript a) => TypeScript (Maybe a) where getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) @@ -98,9 +91,8 @@ instance TypeScript A.Value where 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))) + getParentTypes _ = L.nub [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] instance (TypeScript a) => TypeScript (Set a) where getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]"; - getParentTypes _ = L.nub (getParentTypes (Proxy :: Proxy a)) + getParentTypes _ = L.nub [TSType (Proxy :: Proxy a)] From 6ffc83e7d82b0088676412a706f721806c890ff7 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 15:45:23 +0200 Subject: [PATCH 02/10] honor `unwrapUnaryRecords` for unary records We just return the type of the parent. The rest will be taken care by `getParentTypes`. --- src/Data/Aeson/TypeScript/TH.hs | 35 ++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index e990428..3688ecc 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -186,24 +186,35 @@ deriveTypeScript options name = do 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 - getGenericParentTypesFn <- getGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] - getNonGenericParentTypesFn <- getNonGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] + case (unwrapUnaryRecords options, datatypeCons) of + (True, [con]) | RecordConstructor [_name] <- constructorVariant con -> do + let [fld] = constructorFields con + let getTypeFn = FunD 'getTypeScriptType [Clause [WildP] (NormalB (AppE (VarE 'getTypeScriptType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) fld)))) []] + let getParentTypesFn = FunD 'getParentTypes [Clause [WildP] (NormalB (ListE [AppE (ConE 'TSType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) fld))])) []] +#if MIN_VERSION_th_abstraction(0,3,0) + return [mkInstance (fmap getDatatypePredicate datatypeInstTypes) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeInstTypes)) [getTypeFn, getParentTypesFn]] +#else + return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [getTypeFn, getParentTypesFn]] +#endif + _ -> do + getTypeFn <- getTypeExpression datatypeInfo >>= \expr -> return $ FunD 'getTypeScriptType [Clause [WildP] (NormalB expr) []] + getDeclarationFn <- getDeclarationFunctionBody options name fullyQualifiedDatatypeInfo typeExpr + getGenericParentTypesFn <- getGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] + getNonGenericParentTypesFn <- getNonGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] - let fullyGenericInstance = mkInstance [] (AppT (ConT ''TypeScript) (ConT name)) [getTypeFn, getDeclarationFn, getGenericParentTypesFn] + let fullyGenericInstance = mkInstance [] (AppT (ConT ''TypeScript) (ConT name)) [getTypeFn, getDeclarationFn, getGenericParentTypesFn] - otherInstances <- case null datatypeVars of - False -> do - otherGetTypeFn <- getTypeExpression datatypeInfo >>= \expr -> return $ FunD 'getTypeScriptType [Clause [WildP] (NormalB expr) []] + otherInstances <- case null datatypeVars of + False -> 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 AppT (ConT name) datatypeInstTypes)) [otherGetTypeFn, getNonGenericParentTypesFn]] + return [mkInstance (fmap getDatatypePredicate datatypeInstTypes) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeInstTypes)) [otherGetTypeFn, getNonGenericParentTypesFn]] #else - return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [otherGetTypeFn, getNonGenericParentTypesFn]] + return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [otherGetTypeFn, getNonGenericParentTypesFn]] #endif - True -> return [] + True -> return [] - return $ fullyGenericInstance : otherInstances + return $ fullyGenericInstance : otherInstances -- | For the fully generic instance, the parent types are the types inside the constructors getGenericParentTypesExpression :: DatatypeInfo -> Q Exp From 7645e67a1a4bf6e302affa61804f6867e39e86fd Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 15:47:53 +0200 Subject: [PATCH 03/10] when the type refer to a single interface, refer to it correctly Before this change, the following type data Test = TestBlah {x :: Int, y :: Bool} when configured with `tagSingleConstructors = True` would have generated getTypeScriptType (Proxy @Test) ==> "Test" formatTSDeclarations (getTypeScriptDeclarations (Proxy @Test)) ==> interface TestBlah {x: Int, y: Bool} That is, there would be a dangling references to a non-existent interface `Test`. --- src/Data/Aeson/TypeScript/TH.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index 3688ecc..bd27fd8 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -197,7 +197,8 @@ deriveTypeScript options name = do return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [getTypeFn, getParentTypesFn]] #endif _ -> do - getTypeFn <- getTypeExpression datatypeInfo >>= \expr -> return $ FunD 'getTypeScriptType [Clause [WildP] (NormalB expr) []] + typeExpr <- getTypeExpression fullyQualifiedDatatypeInfo + let getTypeFn = FunD 'getTypeScriptType [Clause [WildP] (NormalB typeExpr) []] getDeclarationFn <- getDeclarationFunctionBody options name fullyQualifiedDatatypeInfo typeExpr getGenericParentTypesFn <- getGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] getNonGenericParentTypesFn <- getNonGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] @@ -225,8 +226,8 @@ getGenericParentTypesExpression (DatatypeInfo {..}) = return $ ListE [AppE (ConE getNonGenericParentTypesExpression :: DatatypeInfo -> Q Exp getNonGenericParentTypesExpression (DatatypeInfo {..}) = return $ ListE [AppE (ConE 'TSType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT datatypeName)))] -getDeclarationFunctionBody :: Options -> p -> DatatypeInfo -> Q Dec -getDeclarationFunctionBody options _name datatypeInfo@(DatatypeInfo {..}) = do +getDeclarationFunctionBody :: Options -> p -> DatatypeInfo -> Exp -> Q Dec +getDeclarationFunctionBody options _name datatypeInfo@(DatatypeInfo {..}) nameExpr = 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 j | j <- [1..(length datatypeVars)]] @@ -238,8 +239,9 @@ getDeclarationFunctionBody options _name datatypeInfo@(DatatypeInfo {..}) = do case interfaceNamesAndDeclarations of [(_, Just interfaceDecl, True)] | datatypeVars == [] -> do - -- The type declaration is just a reference to a single interface, so we can omit the type part and drop the "I" from the interface name - return $ NormalB $ ListE [AppE (VarE 'dropLeadingIFromInterfaceName) interfaceDecl] + -- The type declaration is just a reference to a single interface, so we can omit the type part and replace the interface + -- name with the type name + return $ NormalB $ ListE [AppE (AppE (VarE 'replaceInterfaceName) nameExpr) interfaceDecl] _ -> do let interfaceNames = fmap fst3 interfaceNamesAndDeclarations @@ -249,10 +251,9 @@ getDeclarationFunctionBody options _name datatypeInfo@(DatatypeInfo {..}) = do return $ FunD 'getTypeScriptDeclarations [Clause [WildP] declarationFnBody []] -dropLeadingIFromInterfaceName :: TSDeclaration -> TSDeclaration -dropLeadingIFromInterfaceName decl@(TSInterfaceDeclaration {interfaceName=('I':xs)}) = decl { interfaceName = xs } -dropLeadingIFromInterfaceName decl@(TSTypeAlternatives {typeName=('I':xs)}) = decl { typeName = xs } -dropLeadingIFromInterfaceName x = x +replaceInterfaceName :: String -> TSDeclaration -> TSDeclaration +replaceInterfaceName name decl@(TSInterfaceDeclaration {}) = decl { interfaceName = name } +replaceInterfaceName name decl@(TSTypeAlternatives {}) = decl { typeName = name } -- | 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, Bool) From 56f7de2639db991b230b70095dcaecef873fd07d Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 16:06:10 +0200 Subject: [PATCH 04/10] add some missing container instances --- src/Data/Aeson/TypeScript/Instances.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index 267f268..dbf75bb 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -9,9 +9,11 @@ import qualified Data.Aeson as A import Data.Aeson.TypeScript.Types import Data.Data import Data.HashMap.Strict +import Data.HashSet import qualified Data.List as L import Data.Monoid import Data.Set +import Data.Map.Strict import Data.String.Interpolate.IsString import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -96,3 +98,13 @@ instance (TypeScript a, TypeScript b) => TypeScript (HashMap a b) where instance (TypeScript a) => TypeScript (Set a) where getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]"; getParentTypes _ = L.nub [TSType (Proxy :: Proxy a)] + +instance (TypeScript a) => TypeScript (HashSet a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) ++ "[]" + getParentTypes _ = [TSType (Proxy :: Proxy a)] + +instance (TypeScript a, TypeScript b) => TypeScript (Map a b) where + getTypeScriptType _ = + "{[k: " ++ getTypeScriptType (Proxy :: Proxy a) ++ "]: " ++ getTypeScriptType (Proxy :: Proxy b) ++ "}" + getParentTypes _ = [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] + From 2a86676e3c6b906c9ba24577e3965d29f137f02b Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 16:07:35 +0200 Subject: [PATCH 05/10] use mapped types to represent maps This allows to have unions as keys, which often happens when encoding variants made out of nullary constructors. --- src/Data/Aeson/TypeScript/Instances.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index dbf75bb..f8fdbdc 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -92,7 +92,7 @@ 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)}}|] + getTypeScriptType _ = [i|{[k in #{getTypeScriptType (Proxy :: Proxy a)}]?: #{getTypeScriptType (Proxy :: Proxy b)}}|] getParentTypes _ = L.nub [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] instance (TypeScript a) => TypeScript (Set a) where @@ -105,6 +105,6 @@ instance (TypeScript a) => TypeScript (HashSet a) where instance (TypeScript a, TypeScript b) => TypeScript (Map a b) where getTypeScriptType _ = - "{[k: " ++ getTypeScriptType (Proxy :: Proxy a) ++ "]: " ++ getTypeScriptType (Proxy :: Proxy b) ++ "}" + "{[k in " ++ getTypeScriptType (Proxy :: Proxy a) ++ "]?: " ++ getTypeScriptType (Proxy :: Proxy b) ++ "}" getParentTypes _ = [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] From 13822f06e45b632446bf6e9b6e8368c060e159b5 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 23:21:49 +0200 Subject: [PATCH 06/10] allow to export types easily --- src/Data/Aeson/TypeScript/Formatting.hs | 4 ++-- src/Data/Aeson/TypeScript/TH.hs | 1 + src/Data/Aeson/TypeScript/Types.hs | 2 ++ 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Formatting.hs b/src/Data/Aeson/TypeScript/Formatting.hs index d824cd1..08615ed 100644 --- a/src/Data/Aeson/TypeScript/Formatting.hs +++ b/src/Data/Aeson/TypeScript/Formatting.hs @@ -14,11 +14,11 @@ formatTSDeclarations = formatTSDeclarations' defaultFormattingOptions -- | 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};|] + [i|#{if exportTypes then "export " else ""}type #{typeNameModifier name}#{getGenericBrackets genericVariables} = #{alternatives};|] where alternatives = T.intercalate " | " (fmap T.pack names) formatTSDeclaration (FormattingOptions {..}) (TSInterfaceDeclaration interfaceName genericVariables members) = - [i|interface #{modifiedInterfaceName}#{getGenericBrackets genericVariables} { + [i|#{if exportTypes then "export " else ""}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 diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index bd27fd8..024bd56 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -111,6 +111,7 @@ module Data.Aeson.TypeScript.TH ( formatTSDeclarations', formatTSDeclaration, FormattingOptions(..), + defaultFormattingOptions, -- * Convenience tools HasJSONOptions(..), diff --git a/src/Data/Aeson/TypeScript/Types.hs b/src/Data/Aeson/TypeScript/Types.hs index e688854..db1a49e 100644 --- a/src/Data/Aeson/TypeScript/Types.hs +++ b/src/Data/Aeson/TypeScript/Types.hs @@ -93,12 +93,14 @@ data FormattingOptions = FormattingOptions -- ^ Function applied to generated interface names , typeNameModifier :: String -> String -- ^ Function applied to generated type names + , exportTypes :: Bool } defaultFormattingOptions = FormattingOptions { numIndentSpaces = 2 , interfaceNameModifier = id , typeNameModifier = id + , exportTypes = False } -- | Convenience typeclass class you can use to "attach" a set of Aeson encoding options to a type. From a751b8be7872a0f0def3c6f216eb212a6f71017b Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 15 Apr 2020 21:52:14 +0200 Subject: [PATCH 07/10] Allow to access `TypeScript` types from outside --- package.yaml | 1 + src/Data/Aeson/TypeScript/Internal.hs | 10 ++++++++++ 2 files changed, 11 insertions(+) create mode 100644 src/Data/Aeson/TypeScript/Internal.hs diff --git a/package.yaml b/package.yaml index 89a2730..b77b2d8 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,7 @@ library: exposed-modules: - Data.Aeson.TypeScript.TH - Data.Aeson.TypeScript.Recursive + - Data.Aeson.TypeScript.Internal tests: aeson-typescript-test: diff --git a/src/Data/Aeson/TypeScript/Internal.hs b/src/Data/Aeson/TypeScript/Internal.hs new file mode 100644 index 0000000..c69e3e4 --- /dev/null +++ b/src/Data/Aeson/TypeScript/Internal.hs @@ -0,0 +1,10 @@ +-- | This module re-exports types concerning the 'TypeScript' class. Usually +-- template haskell generates values for these types for you, make sure to +-- know what you're doing if you are writing instances directly. +module Data.Aeson.TypeScript.Internal + ( TSDeclaration(..) + , TSField(..) + ) where + +import Data.Aeson.TypeScript.Types + From f6e51e48e72d3a9a214f0b8024866ead29b1caf5 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 15 Apr 2020 21:52:52 +0200 Subject: [PATCH 08/10] cabal file update --- aeson-typescript.cabal | 56 ++++++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 27 deletions(-) mode change 100755 => 100644 aeson-typescript.cabal diff --git a/aeson-typescript.cabal b/aeson-typescript.cabal old mode 100755 new mode 100644 index d556a17..ba571ae --- a/aeson-typescript.cabal +++ b/aeson-typescript.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b77cd606ddb441b9a4bc9592c1257172003cb38a9b39c2cc9b693a90110c1b52 +-- hash: 00a617afcabcfd8fbaeb7c22dce7296da68ca0ebf3d0d15df2fac2879faa9f46 name: aeson-typescript version: 0.2.0.0 @@ -33,52 +33,32 @@ source-repository head location: https://github.com/codedownio/aeson-typescript library - hs-source-dirs: - src - build-depends: - aeson - , base >=4.7 && <5 - , containers - , interpolate - , mtl - , template-haskell - , text - , th-abstraction <0.4 - , unordered-containers exposed-modules: Data.Aeson.TypeScript.TH Data.Aeson.TypeScript.Recursive + Data.Aeson.TypeScript.Internal 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 hs-source-dirs: - test src - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: aeson - , aeson-typescript , base >=4.7 && <5 - , bytestring , containers - , directory - , filepath - , hspec , interpolate , mtl - , process , template-haskell - , temporary , text , th-abstraction <0.4 , unordered-containers + default-language: Haskell2010 + +test-suite aeson-typescript-test + type: exitcode-stdio-1.0 + main-is: Spec.hs other-modules: HigherKind NoOmitNothingFields @@ -95,8 +75,30 @@ test-suite aeson-typescript-test Util Data.Aeson.TypeScript.Formatting Data.Aeson.TypeScript.Instances + Data.Aeson.TypeScript.Internal Data.Aeson.TypeScript.Recursive Data.Aeson.TypeScript.TH Data.Aeson.TypeScript.Types Paths_aeson_typescript + hs-source-dirs: + test + src + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-typescript + , base >=4.7 && <5 + , bytestring + , containers + , directory + , filepath + , hspec + , interpolate + , mtl + , process + , template-haskell + , temporary + , text + , th-abstraction <0.4 + , unordered-containers default-language: Haskell2010 From b61824c71204cc9381714b4501aa4408eb2fe25d Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Fri, 22 May 2020 15:38:47 +0200 Subject: [PATCH 09/10] add parent types / generic instances for unary records --- src/Data/Aeson/TypeScript/TH.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index 024bd56..d0b86d9 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -190,13 +190,22 @@ deriveTypeScript options name = do case (unwrapUnaryRecords options, datatypeCons) of (True, [con]) | RecordConstructor [_name] <- constructorVariant con -> do let [fld] = constructorFields con - let getTypeFn = FunD 'getTypeScriptType [Clause [WildP] (NormalB (AppE (VarE 'getTypeScriptType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) fld)))) []] - let getParentTypesFn = FunD 'getParentTypes [Clause [WildP] (NormalB (ListE [AppE (ConE 'TSType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) fld))])) []] + let getNonGenericTypeFn = FunD 'getTypeScriptType [Clause [WildP] (NormalB (getTypeAsStringExp fld)) []] + let getGenericTypeFn = if null datatypeVars + then getNonGenericTypeFn + else FunD 'getTypeScriptType [Clause [WildP] (NormalB (getTypeAsStringExp (foldl AppT (ConT name) templateVarsToUse))) []] + getGenericParentTypesFn <- getGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] + getNonGenericParentTypesFn <- getNonGenericParentTypesExpression fullyQualifiedDatatypeInfo >>= \expr -> return $ FunD 'getParentTypes [Clause [WildP] (NormalB expr) []] + let fullyGenericInstance = mkInstance [] (AppT (ConT ''TypeScript) (ConT name)) [getGenericTypeFn, getGenericParentTypesFn] + otherInstances <- if null datatypeVars + then return [] + else #if MIN_VERSION_th_abstraction(0,3,0) - return [mkInstance (fmap getDatatypePredicate datatypeInstTypes) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeInstTypes)) [getTypeFn, getParentTypesFn]] + return [mkInstance (fmap getDatatypePredicate datatypeInstTypes) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeInstTypes)) [getNonGenericTypeFn, getNonGenericParentTypesFn]] #else - return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [getTypeFn, getParentTypesFn]] + return [mkInstance (fmap getDatatypePredicate datatypeVars) (AppT (ConT ''TypeScript) (foldl AppT (ConT name) datatypeVars)) [getNonGenericTypeFn, getNonGenericParentTypesFn]] #endif + return (fullyGenericInstance : otherInstances) _ -> do typeExpr <- getTypeExpression fullyQualifiedDatatypeInfo let getTypeFn = FunD 'getTypeScriptType [Clause [WildP] (NormalB typeExpr) []] From 92fdfbace1db2154c2d1d6cb5348c05df2c3d9ad Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Jul 2020 13:00:42 +0200 Subject: [PATCH 10/10] Add instance for `Word8` --- src/Data/Aeson/TypeScript/Instances.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index f8fdbdc..d6105b9 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -17,6 +17,7 @@ import Data.Map.Strict import Data.String.Interpolate.IsString import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import Data.Word instance TypeScript () where getTypeScriptType _ = "void" @@ -45,6 +46,9 @@ instance TypeScript Int where instance TypeScript Char where getTypeScriptType _ = "string" +instance TypeScript Word8 where + getTypeScriptType _ = "number" + instance {-# OVERLAPPABLE #-} (TypeScript a) => TypeScript [a] where getTypeScriptType _ = (getTypeScriptType (Proxy :: Proxy a)) ++ "[]" getParentTypes _ = [TSType (Proxy :: Proxy a)]