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 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/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/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index dcc10ab..d6105b9 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -9,12 +9,15 @@ 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 +import Data.Word instance TypeScript () where getTypeScriptType _ = "void" @@ -43,9 +46,12 @@ 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)) : (getParentTypes (Proxy :: Proxy a)) + getParentTypes _ = [TSType (Proxy :: Proxy a)] instance {-# OVERLAPPING #-} TypeScript [Char] where getTypeScriptType _ = "string" @@ -56,37 +62,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) @@ -97,10 +96,19 @@ 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))) + 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 getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]"; - getParentTypes _ = L.nub (getParentTypes (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 in " ++ getTypeScriptType (Proxy :: Proxy a) ++ "]?: " ++ getTypeScriptType (Proxy :: Proxy b) ++ "}" + getParentTypes _ = [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] + 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 + diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index e990428..d0b86d9 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(..), @@ -186,24 +187,45 @@ 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) []] - - 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) []] + case (unwrapUnaryRecords options, datatypeCons) of + (True, [con]) | RecordConstructor [_name] <- constructorVariant con -> do + let [fld] = constructorFields con + 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)) [getNonGenericTypeFn, getNonGenericParentTypesFn]] +#else + 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) []] + 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] + + 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 @@ -214,8 +236,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)]] @@ -227,8 +249,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 @@ -238,10 +261,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) 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.