Various bug fixes and improvements.

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

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:

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

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)]
+

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
+

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)

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.