diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100755 index 0000000..4f9ce36 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,7 @@ +((haskell-mode + . ( + (haskell-process-args-stack-ghci . ("--ghci-options=-ferror-spans" "--no-build" "--no-load" + "aeson-typescript:lib" + "aeson-typescript:aeson-typescript-tests" + )) + ))) diff --git a/.github/workflows/aeson-typescript.yml b/.github/workflows/aeson-typescript.yml new file mode 100644 index 0000000..9c63d79 --- /dev/null +++ b/.github/workflows/aeson-typescript.yml @@ -0,0 +1,105 @@ +name: aeson-typescript + +on: + pull_request: + push: + +jobs: + cabal: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macOS-latest] + ghc: + - "8.10.7" + - "9.0.2" + - "9.2.8" + - "9.4.7" + - "9.6.3" + + steps: + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v2 + id: setup-haskell-cabal + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: "latest" + + - name: Freeze + run: | + cabal freeze + + - uses: actions/cache@v3 + name: Cache ~/.cabal/store + with: + path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + + - uses: actions/setup-node@v3 + with: + node-version: '16' + - name: Install TSC + run: | + npm install -g typescript + + - name: Build + run: | + cabal configure --enable-tests --enable-benchmarks --test-show-details=direct + cabal build all + + - name: Test + run: | + cabal test all + + stack: + name: stack / ghc ${{ matrix.ghc }} + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + include: + - ghc: "8.10.7" + yaml: "stack-8.10.7.yaml" + - ghc: "9.0.2" + yaml: "stack-9.0.2.yaml" + - ghc: "9.2.8" + yaml: "stack-9.2.8.yaml" + - ghc: "9.4.7" + yaml: "stack-9.4.7.yaml" + - ghc: "9.6.3" + yaml: "stack.yaml" + + steps: + - uses: actions/checkout@v3 + + - uses: haskell/actions/setup@v2 + name: Setup Haskell Stack + with: + ghc-version: ${{ matrix.ghc }} + enable-stack: true + stack-version: "latest" + + - uses: actions/cache@v3 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.yaml }} + + - uses: actions/setup-node@v3 + with: + node-version: '16' + - name: Install TSC + run: | + npm install -g typescript + + - name: Build + run: | + stack build --stack-yaml ${{matrix.yaml}} --system-ghc --test --bench --no-run-tests --no-run-benchmarks + + - name: Test + run: | + stack test --stack-yaml ${{matrix.yaml}} --system-ghc diff --git a/.gitignore b/.gitignore index 012bd9f..938bf2c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .stack-work/ *~ -.dir-locals.el -dist-newstyle \ No newline at end of file +dist-newstyle +*.hie +dev/ diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..274c361 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,69 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Warnings currently triggered by your code +- ignore: {name: "Redundant bracket"} +- ignore: {name: "Redundant do"} +- ignore: {name: "Use if"} +- ignore: {name: "Move brackets to avoid $"} +- ignore: {name: "Use <$>"} +- ignore: {name: "Reduce duplication"} +- ignore: {name: "Redundant multi-way if"} + +# Specify additional command line arguments +# +# - arguments: [--color, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..54445bf --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,72 @@ +# Change log + +## Unreleased + +## 0.7.0.0 + +Represents optional fields (according to the Haskell model) as required fields +with type `A | null` rather than optional fields. + +## 0.6.2.0 + +* Expose generic type constructors `T4` through `T10`. (We only exposed `T`, `T1`, `T2`, and `T3` before.) + +## 0.6.1.0 + +* Fix a bug which caused enum formatting mode to turn off when multiple declarations were provided (#41) +* Fix some mismatch issues where an enum value doesn't match the desired string. + +## 0.6.0.0 + +* New word instances: Word, Word16, Word32, Word64 +* New instances from Data.Functor: Compose, Const, Identity, Product + +## 0.5.0.0 + +* [#35](https://github.com/codedownio/aeson-typescript/pull/35) + * Add `Data.Aeson.TypeScript.LegalName` module for checking whether a name is a legal JavaScript name or not. + * The `defaultFormatter` will `error` if the name contains illegal characters. +* Be able to transfer Haddock comments to emitted TypeScript (requires GHC >= 9.2 and `-haddock` flag) +* Add support for @no-emit-typescript in Haddocks for constructors and record fields (requires GHC >= 9.2 and `-haddock` flag) +* Support GHC 9.6.1 + +## 0.4.2.0 + +* Fix TypeScript (A.KeyMap a) instance + +## 0.4.1.0 + +* Add TypeScript Int16 +* Add TypeScript (A.KeyMap a) instance for aeson 2 + +## 0.4.0.0 + +* Add new built-in instances (Word8, Int32, Int64, Map, HashSet) +* Export TSField in the Internal module +* Avoid producing redundant constraints (for fewer warnings when using -Wredundant-constraints) +* Encode maps as mapped types (allows you to have unions as keys) +* Support mapping open type families to lookup types (+ progress on handling promoted types) +* Improve propagation of T variables in declarations +* Add support for "key types", in case you have custom implementations of FromJSONKey/ToJSONKey +* Add ability to recursively derive missing instances (fragile) + +## 0.3.0.1 + +* Support GHC 9.0.1 + +## 0.3.0.0 + +* Update th-abstraction dependency to < 0.5 to support working with newer Stack LTS. +* Major refactors to improve TH quality. +* Tracking of parent types to allow recursive deriving + * The `getParentTypes` function was added to the main typeclass. + * The new `Data.Aeson.TypeScript.Recursive` module for working with recursive definitions. +* New support for mapping Haskell closed type families to TypeScript lookup types. + +## 0.2.0.0 + +* New formatting option `interfaceNameModifier`. + +## 0.1.0.0 + +* Initial release. diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index 4acb20d..0000000 --- a/ChangeLog.md +++ /dev/null @@ -1,8 +0,0 @@ -# Changelog for aeson-typescript - -## Unreleased changes - -## 0.3.0.0 - -Represents optional fields (according to the Haskell model) as required fields -with type `A | null` rather than optional fields. diff --git a/LICENSE b/LICENSE index 1d753c9..9ff54f5 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2017 +Copyright Tom McLaughlin (c) 2022 All rights reserved. diff --git a/README.md b/README.md index 3ee2a6a..227be17 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -# Welcome to `aeson-typescript` [![Hackage](https://img.shields.io/hackage/v/aeson-typescript.svg)](https://hackage.haskell.org/package/aeson-typescript) [![Build Status](https://travis-ci.org/codedownio/aeson-typescript.svg)](https://travis-ci.org/codedownio/aeson-typescript) +# Welcome to `aeson-typescript` [![Hackage](https://img.shields.io/hackage/v/aeson-typescript.svg)](https://hackage.haskell.org/package/aeson-typescript) ![aeson-typescript](https://github.com/codedownio/aeson-typescript/workflows/aeson-typescript/badge.svg) This library provides a way to generate TypeScript `.d.ts` files that match your existing Aeson `ToJSON` instances. If you already use Aeson's Template Haskell support to derive your instances, then deriving TypeScript is as simple as @@ -16,6 +16,7 @@ data D a = Nullary | Product String Char a | Record { testOne :: Double , testTwo :: Bool + -- | This docstring will go into the generated TypeScript! , testThree :: D a } deriving Eq ``` @@ -29,7 +30,7 @@ $(deriveTypeScript (defaultOptions {fieldLabelModifier = drop 4, constructorTagM Now we can use the newly created instances. ```haskell ->>> putStrLn $ formatTSDeclarations $ getTypeScriptDeclaration (Proxy :: Proxy D) +>>> putStrLn $ formatTSDeclarations $ getTypeScriptDeclarations (Proxy :: Proxy (D T)) type D = "nullary" | IUnary | IProduct | IRecord; @@ -41,6 +42,7 @@ interface IRecord { tag: "record"; One: number; Two: boolean; + // This docstring will go into the generated TypeScript! Three: D; } ``` @@ -112,6 +114,6 @@ Now you can generate the types by running `stack runhaskell tsdef/Main.hs > type # See also -If you want a much more opinionated web framework for generating APIs, check out [servant](http://haskell-servant.readthedocs.io/en/stable/). (Although it doesn't seem to support TypeScript client generation at the moment.) +If you want a more opinionated web framework for generating APIs, check out [servant](http://haskell-servant.readthedocs.io/en/stable/). If you use Servant, you may enjoy [servant-typescript](https://github.com/codedownio/servant-typescript), which is based on `aeson-typescript`! This companion package also has the advantage of magically collecting all the types used in your API, so you don't have to list them out manually. For another very powerful framework that can generate TypeScript client code based on an API specification, see [Swagger/OpenAPI](https://github.com/swagger-api/swagger-codegen). diff --git a/aeson-typescript.cabal b/aeson-typescript.cabal index a38a152..882d685 100644 --- a/aeson-typescript.cabal +++ b/aeson-typescript.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -- -- hash: e778945cc6c2317863114819314907c928f41e6d6f6a7ccdb77b712d1dd356bf name: aeson-typescript -version: 0.3.0.0 +version: 0.7.0.0 synopsis: Generate TypeScript definition files from your ADTs description: Please see the README on Github at category: Text, Web, JSON @@ -15,14 +15,21 @@ homepage: https://github.com/codedownio/aeson-typescript#readme bug-reports: https://github.com/codedownio/aeson-typescript/issues author: Tom McLaughlin maintainer: tom@codedown.io -copyright: 2018 CodeDown +copyright: 2022 CodeDown license: BSD3 license-file: LICENSE -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 build-type: Simple +tested-with: + GHC == 9.6.1 + , GHC == 9.4.4 + , GHC == 9.2.7 + , GHC == 9.0.2 + , GHC == 8.10.7 + , GHC == 8.8.4 + , GHC == 8.6.5 extra-source-files: README.md - ChangeLog.md + CHANGELOG.md test/assets/package.json test/assets/npm_install.sh test/assets/yarn_install.sh @@ -35,36 +42,59 @@ source-repository head library exposed-modules: Data.Aeson.TypeScript.TH - Data.Aeson.TypeScript.LookupTypes + Data.Aeson.TypeScript.Internal Data.Aeson.TypeScript.Recursive + Data.Aeson.TypeScript.LegalName other-modules: Data.Aeson.TypeScript.Formatting Data.Aeson.TypeScript.Instances + Data.Aeson.TypeScript.Lookup + Data.Aeson.TypeScript.Transform + Data.Aeson.TypeScript.TypeManipulation Data.Aeson.TypeScript.Types + Data.Aeson.TypeScript.Util Paths_aeson_typescript hs-source-dirs: src + default-extensions: + LambdaCase + MultiWayIf + NamedFieldPuns + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + TupleSections + ViewPatterns build-depends: aeson , base >=4.7 && <5 + , bytestring , containers - , interpolate , mtl + , string-interpolate , template-haskell , text - , th-abstraction <0.5 + , th-abstraction + , transformers , unordered-containers default-language: Haskell2010 -test-suite aeson-typescript-test +test-suite aeson-typescript-tests type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Basic + ClosedTypeFamilies + Formatting + Generic + GetDoc HigherKind + LegalNameSpec NoOmitNothingFields ObjectWithSingleFieldNoTagSingleConstructors ObjectWithSingleFieldTagSingleConstructors - OmitNothingFields + OpenTypeFamilies TaggedObjectNoTagSingleConstructors TaggedObjectTagSingleConstructors TestBoilerplate @@ -72,18 +102,39 @@ test-suite aeson-typescript-test TwoElemArrayTagSingleConstructors UntaggedNoTagSingleConstructors UntaggedTagSingleConstructors + UnwrapUnaryRecords Util + Util.Aeson Data.Aeson.TypeScript.Formatting Data.Aeson.TypeScript.Instances - Data.Aeson.TypeScript.LookupTypes + Data.Aeson.TypeScript.Internal + Data.Aeson.TypeScript.LegalName + Data.Aeson.TypeScript.Lookup Data.Aeson.TypeScript.Recursive Data.Aeson.TypeScript.TH + Data.Aeson.TypeScript.Transform + Data.Aeson.TypeScript.TypeManipulation Data.Aeson.TypeScript.Types + Data.Aeson.TypeScript.Util Paths_aeson_typescript hs-source-dirs: test src - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-extensions: + LambdaCase + MultiWayIf + NamedFieldPuns + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + TupleSections + ViewPatterns + FlexibleContexts + KindSignatures + TemplateHaskell + TypeFamilies + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -haddock -fno-warn-unused-top-binds -fno-warn-orphans build-depends: aeson , aeson-typescript @@ -93,12 +144,13 @@ test-suite aeson-typescript-test , directory , filepath , hspec - , interpolate , mtl , process + , string-interpolate , template-haskell , temporary , text - , th-abstraction <0.5 + , th-abstraction + , transformers , unordered-containers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 5b2b36b..395969f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,15 +1,15 @@ name: aeson-typescript -version: 0.3.0.0 +version: 0.7.0.0 github: "codedownio/aeson-typescript" license: BSD3 category: Text, Web, JSON author: "Tom McLaughlin" maintainer: "tom@codedown.io" -copyright: "2018 CodeDown" +copyright: "2022 CodeDown" extra-source-files: - README.md -- ChangeLog.md +- CHANGELOG.md - test/assets/package.json - test/assets/npm_install.sh - test/assets/yarn_install.sh @@ -23,28 +23,49 @@ synopsis: Generate TypeScript definition files from your ADTs # common to point users to the README.md file. description: Please see the README on Github at -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 +tested-with: +- GHC == 9.6.1 +- GHC == 9.4.4 +- GHC == 9.2.7 +- GHC == 9.0.2 +- GHC == 8.10.7 +- GHC == 8.8.4 +- GHC == 8.6.5 dependencies: - aeson - base >= 4.7 && < 5 +- bytestring - containers -- interpolate - mtl +- string-interpolate - template-haskell - text -- th-abstraction < 0.5 +- th-abstraction +- transformers - unordered-containers +default-extensions: +- LambdaCase +- MultiWayIf +- NamedFieldPuns +- OverloadedStrings +- QuasiQuotes +- RecordWildCards +- ScopedTypeVariables +- TupleSections +- ViewPatterns + library: source-dirs: src exposed-modules: - - Data.Aeson.TypeScript.TH - - Data.Aeson.TypeScript.LookupTypes - - Data.Aeson.TypeScript.Recursive + - Data.Aeson.TypeScript.TH + - Data.Aeson.TypeScript.Internal + - Data.Aeson.TypeScript.Recursive + - Data.Aeson.TypeScript.LegalName tests: - aeson-typescript-test: + aeson-typescript-tests: main: Spec.hs source-dirs: - test @@ -54,6 +75,14 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N + - -haddock + - -fno-warn-unused-top-binds + - -fno-warn-orphans + default-extensions: + - FlexibleContexts + - KindSignatures + - TemplateHaskell + - TypeFamilies dependencies: - aeson-typescript - bytestring diff --git a/src/Data/Aeson/TypeScript/Formatting.hs b/src/Data/Aeson/TypeScript/Formatting.hs index 03a1bfe..ca1457c 100644 --- a/src/Data/Aeson/TypeScript/Formatting.hs +++ b/src/Data/Aeson/TypeScript/Formatting.hs @@ -1,35 +1,124 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Data.Aeson.TypeScript.Formatting where +import Data.Aeson as A import Data.Aeson.TypeScript.Types -import Data.Monoid -import Data.String.Interpolate.IsString +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Function ((&)) +import qualified Data.List as L +import Data.Maybe +import Data.String.Interpolate import qualified Data.Text as T +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + -- | Same as 'formatTSDeclarations'', but uses default formatting options. formatTSDeclarations :: [TSDeclaration] -> String 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};|] - where alternatives = T.intercalate " | " (fmap T.pack names) +formatTSDeclaration (FormattingOptions{..}) (TSTypeAlternatives name genericVariables names maybeDoc) = + makeDocPrefix maybeDoc <> mainDeclaration + where + mainDeclaration = case chooseTypeAlternativesFormat typeAlternativesFormat of + Enum -> [i|#{exportPrefix exportMode}enum #{typeNameModifier name} { #{alternativesEnum} }|] + where + alternativesEnum = T.intercalate ", " $ [toEnumName entry <> "=" <> entry | entry <- T.pack <$> names] + EnumWithType -> [i|#{exportPrefix exportMode}enum #{typeNameModifier name}Enum { #{alternativesEnumWithType} }#{enumType}|] + where + alternativesEnumWithType = T.intercalate ", " $ [toEnumName entry <> "=" <> entry | entry <- T.pack <$> names] + enumType = [i|\n\ntype #{name} = keyof typeof #{typeNameModifier name}Enum;|] :: T.Text + TypeAlias -> [i|#{exportPrefix exportMode}type #{typeNameModifier name}#{getGenericBrackets genericVariables} = #{alternatives};|] + where + alternatives = T.intercalate " | " (fmap T.pack names) + + -- Only allow certain formats if some checks pass + chooseTypeAlternativesFormat Enum + | all isDoubleQuotedString names = Enum + | otherwise = TypeAlias + chooseTypeAlternativesFormat EnumWithType + | all isDoubleQuotedString names = EnumWithType + | otherwise = TypeAlias + chooseTypeAlternativesFormat x = x + + isDoubleQuotedString s = case A.eitherDecode (BL8.pack s) of + Right (A.String _) -> True + _ -> False + + toEnumName = T.replace "\"" "" +formatTSDeclaration (FormattingOptions{..}) (TSInterfaceDeclaration interfaceName genericVariables (filter (not . isNoEmitTypeScriptField) -> members) maybeDoc) = + makeDocPrefix maybeDoc + <> [i|#{exportPrefix exportMode}interface #{modifiedInterfaceName}#{getGenericBrackets genericVariables} { +#{ls} +}|] + where + ls = T.intercalate "\n" $ [indentTo numIndentSpaces (T.pack (formatTSField member <> ";")) | member <- members] + modifiedInterfaceName = (\(li, name) -> li <> interfaceNameModifier name) . splitAt 1 $ interfaceName + + formatTSField :: TSField -> String + formatTSField (TSField optional name typ maybeDoc') = makeDocPrefix maybeDoc' <> [i|#{name}: #{typ}#{if optional then ("| null" :: String) else ""}|] +formatTSDeclaration _ (TSRawDeclaration text) = text -formatTSDeclaration (FormattingOptions {..}) (TSInterfaceDeclaration interfaceName genericVariables members) = - [i|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 +indentTo :: Int -> T.Text -> T.Text +indentTo numIndentSpaces input = T.intercalate "\n" [padding <> line | line <- T.splitOn "\n" input] + where + padding = T.replicate numIndentSpaces " " + +exportPrefix :: ExportMode -> String +exportPrefix ExportEach = "export " +exportPrefix ExportNone = "" -- | Format a list of TypeScript declarations into a string, suitable for putting directly into a @.d.ts@ file. formatTSDeclarations' :: FormattingOptions -> [TSDeclaration] -> String -formatTSDeclarations' options declarations = T.unpack $ T.intercalate "\n\n" (fmap (T.pack . formatTSDeclaration options) declarations) +formatTSDeclarations' options allDeclarations = + declarations + & fmap (T.pack . formatTSDeclaration options) + & T.intercalate "\n\n" + & T.unpack + where + removedDeclarationNames = mapMaybe getDeclarationName (filter isNoEmitTypeScriptDeclaration allDeclarations) + where + getDeclarationName :: TSDeclaration -> Maybe String + getDeclarationName (TSInterfaceDeclaration{..}) = Just interfaceName + getDeclarationName (TSTypeAlternatives{..}) = Just typeName + getDeclarationName _ = Nothing + + removeReferencesToRemovedNames :: [String] -> TSDeclaration -> TSDeclaration + removeReferencesToRemovedNames removedNames decl@(TSTypeAlternatives{..}) = decl{alternativeTypes = [x | x <- alternativeTypes, not (x `L.elem` removedNames)]} + removeReferencesToRemovedNames _ x = x -formatTSField :: TSField -> String -formatTSField (TSField optional name typ) = [i|#{name}: #{typ}#{if optional then "| null" else ""}|] + declarations = + allDeclarations + & filter (not . isNoEmitTypeScriptDeclaration) + & fmap (removeReferencesToRemovedNames removedDeclarationNames) + +makeDocPrefix :: Maybe String -> String +makeDocPrefix maybeDoc = case maybeDoc of + Nothing -> "" + Just (T.pack -> text) -> + ["// " <> line | line <- T.splitOn "\n" text] + & T.intercalate "\n" + & (<> "\n") + & T.unpack getGenericBrackets :: [String] -> String getGenericBrackets [] = "" getGenericBrackets xs = [i|<#{T.intercalate ", " (fmap T.pack xs)}>|] + +-- * Support for @no-emit-typescript + +noEmitTypeScriptAnnotation :: String +noEmitTypeScriptAnnotation = "@no-emit-typescript" + +isNoEmitTypeScriptField :: TSField -> Bool +isNoEmitTypeScriptField (TSField{fieldDoc = (Just doc)}) = noEmitTypeScriptAnnotation `L.isInfixOf` doc +isNoEmitTypeScriptField _ = False + +isNoEmitTypeScriptDeclaration :: TSDeclaration -> Bool +isNoEmitTypeScriptDeclaration (TSInterfaceDeclaration{interfaceDoc = (Just doc)}) = noEmitTypeScriptAnnotation `L.isInfixOf` doc +isNoEmitTypeScriptDeclaration (TSTypeAlternatives{typeDoc = (Just doc)}) = noEmitTypeScriptAnnotation `L.isInfixOf` doc +isNoEmitTypeScriptDeclaration _ = False diff --git a/src/Data/Aeson/TypeScript/Instances.hs b/src/Data/Aeson/TypeScript/Instances.hs index 5fe901c..97de51c 100644 --- a/src/Data/Aeson/TypeScript/Instances.hs +++ b/src/Data/Aeson/TypeScript/Instances.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- Note: the OverlappingInstances pragma is only here so the overlapping instances in this file -- will work on older GHCs, like GHC 7.8.4 @@ -8,14 +14,32 @@ module Data.Aeson.TypeScript.Instances where import qualified Data.Aeson as A import Data.Aeson.TypeScript.Types import Data.Data +import Data.Functor.Compose (Compose) +import Data.Functor.Const (Const) +import Data.Functor.Identity (Identity) +import Data.Functor.Product (Product) import Data.HashMap.Strict +import Data.HashSet +import Data.Kind (Type) import qualified Data.List as L -import Data.Monoid +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict import Data.Set -import Data.String.Interpolate.IsString +import Data.String.Interpolate import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Void +import Data.Word +import GHC.Int +import Numeric.Natural (Natural) + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as A +#endif instance TypeScript () where @@ -33,6 +57,9 @@ instance TypeScript TL.Text where instance TypeScript Integer where getTypeScriptType _ = "number" +instance TypeScript Natural where + getTypeScriptType _ = "number" + instance TypeScript Float where getTypeScriptType _ = "number" @@ -45,53 +72,96 @@ instance TypeScript Bool where instance TypeScript Int where getTypeScriptType _ = "number" +instance TypeScript Int16 where + getTypeScriptType _ = "number" + +instance TypeScript Int32 where + getTypeScriptType _ = "number" + +instance TypeScript Int64 where + getTypeScriptType _ = "number" + instance TypeScript Char where getTypeScriptType _ = "string" +instance TypeScript Word where + getTypeScriptType _ = "number" + +instance TypeScript Word8 where + getTypeScriptType _ = "number" + +instance TypeScript Word16 where + getTypeScriptType _ = "number" + +instance TypeScript Word32 where + getTypeScriptType _ = "number" + +instance TypeScript Word64 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 (TypeScript a) => TypeScript (NonEmpty a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy [a]) + getParentTypes _ = [TSType (Proxy :: Proxy a)] instance {-# OVERLAPPING #-} TypeScript [Char] where getTypeScriptType _ = "string" instance (TypeScript a, TypeScript b) => TypeScript (Either a b) where getTypeScriptType _ = [i|Either<#{getTypeScriptType (Proxy :: Proxy a)}, #{getTypeScriptType (Proxy :: Proxy b)}>|] - getTypeScriptDeclarations _ = [TSTypeAlternatives "Either" ["T1", "T2"] ["Left", "Right"] - , TSInterfaceDeclaration "Left" ["T"] [TSField False "Left" "T"] - , TSInterfaceDeclaration "Right" ["T"] [TSField False "Right" "T"] + getTypeScriptDeclarations _ = [TSTypeAlternatives "Either" ["T1", "T2"] ["Left", "Right"] Nothing + , TSInterfaceDeclaration "Left" ["T"] [TSField False "Left" "T" Nothing] Nothing + , TSInterfaceDeclaration "Right" ["T"] [TSField False "Right" "T" Nothing] Nothing ] - 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 forall a k (b :: k). (Typeable k, Typeable b, TypeScript a) => TypeScript (Const a b) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) + getParentTypes _ = [TSType (Proxy :: Proxy a)] + +instance (TypeScript a) => TypeScript (Identity a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) + getParentTypes _ = [TSType (Proxy :: Proxy a)] + +instance forall k k1 (f :: k -> Type) (g :: k1 -> k) a. ( + Typeable k, Typeable k1, Typeable f, Typeable g, Typeable a, TypeScript (f (g a)), TypeScript a + ) => TypeScript (Compose f g a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy (f (g a))) + getParentTypes _ = getParentTypes (Proxy :: Proxy (f (g a))) + +instance forall k (f :: k -> Type) (g :: k -> Type) a. ( + Typeable k, Typeable f, Typeable g, Typeable a, TypeScript (f a), TypeScript (g a) + ) => TypeScript (Product f g a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy (f a, g a)) + getParentTypes _ = L.nub [ (TSType (Proxy :: Proxy (f a))) + , (TSType (Proxy :: Proxy (g a))) + ] instance (TypeScript a) => TypeScript (Maybe a) where getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) @@ -101,11 +171,24 @@ instance (TypeScript a) => TypeScript (Maybe a) where instance TypeScript A.Value where getTypeScriptType _ = "any"; +instance (TypeScript a, TypeScript b) => TypeScript (Map a b) where + getTypeScriptType _ = "{[k in " ++ getTypeScriptKeyType (Proxy :: Proxy a) ++ "]?: " ++ getTypeScriptType (Proxy :: Proxy b) ++ "}" + getParentTypes _ = [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] + 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 #{getTypeScriptKeyType (Proxy :: Proxy a)}]?: #{getTypeScriptType (Proxy :: Proxy b)}}|] + getParentTypes _ = L.nub [TSType (Proxy :: Proxy a), TSType (Proxy :: Proxy b)] + +#if MIN_VERSION_aeson(2,0,0) +instance (TypeScript a) => TypeScript (A.KeyMap a) where + getTypeScriptType _ = [i|{[k: string]: #{getTypeScriptType (Proxy :: Proxy a)}}|] + getParentTypes _ = L.nub [TSType (Proxy :: Proxy a)] +#endif instance (TypeScript a) => TypeScript (Set a) where getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) <> "[]"; - getParentTypes _ = L.nub (getParentTypes (Proxy :: Proxy a)) + getParentTypes _ = [TSType (Proxy :: Proxy a)] + +instance (TypeScript a) => TypeScript (HashSet a) where + getTypeScriptType _ = getTypeScriptType (Proxy :: Proxy a) ++ "[]" + getParentTypes _ = [TSType (Proxy :: Proxy a)] diff --git a/src/Data/Aeson/TypeScript/Internal.hs b/src/Data/Aeson/TypeScript/Internal.hs new file mode 100644 index 0000000..16a3cab --- /dev/null +++ b/src/Data/Aeson/TypeScript/Internal.hs @@ -0,0 +1,9 @@ +-- | Internal details. For now, this module just exports the full TSDeclaration constructors. +-- These are subject to breaking changes but are exported here in case you want to live dangerously. + +module Data.Aeson.TypeScript.Internal ( + TSDeclaration(..) + , TSField(..) + ) where + +import Data.Aeson.TypeScript.Types diff --git a/src/Data/Aeson/TypeScript/LegalName.hs b/src/Data/Aeson/TypeScript/LegalName.hs new file mode 100644 index 0000000..3f15900 --- /dev/null +++ b/src/Data/Aeson/TypeScript/LegalName.hs @@ -0,0 +1,39 @@ +-- | This module defines functions which are useful for determining if +-- a given name is a legal JavaScript name according to +-- . +module Data.Aeson.TypeScript.LegalName where + +import Data.Char +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + + +-- | The return type is the illegal characters that are in the name. If the +-- input has no illegal characters, then you have 'Nothing'. +checkIllegalNameChars :: NonEmpty Char -> Maybe (NonEmpty Char) +checkIllegalNameChars (firstChar :| restChars) = NonEmpty.nonEmpty $ + let + legalFirstCategories = + Set.fromList + [ UppercaseLetter + , LowercaseLetter + , TitlecaseLetter + , ModifierLetter + , OtherLetter + , LetterNumber + ] + legalRestCategories = + Set.fromList + [ NonSpacingMark + , SpacingCombiningMark + , DecimalNumber + , ConnectorPunctuation + ] + `Set.union` legalFirstCategories + isIllegalFirstChar c = not $ + c `elem` ['$', '_'] || generalCategory c `Set.member` legalFirstCategories + isIllegalRestChar c = not $ + generalCategory c `Set.member` legalRestCategories + in + filter isIllegalFirstChar [firstChar] <> filter isIllegalRestChar restChars diff --git a/src/Data/Aeson/TypeScript/Lookup.hs b/src/Data/Aeson/TypeScript/Lookup.hs new file mode 100644 index 0000000..82544fe --- /dev/null +++ b/src/Data/Aeson/TypeScript/Lookup.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Aeson.TypeScript.Lookup where + +import Control.Monad +import Data.Aeson.TypeScript.Instances () +import Data.Aeson.TypeScript.Types +import Data.Function +import qualified Data.List as L +import Data.Proxy +import Data.String.Interpolate +import Language.Haskell.TH hiding (stringE) +import qualified Language.Haskell.TH.Lib as TH + + +-- | Generates a 'TypeScript' declaration for a closed type family as a lookup type. +deriveTypeScriptLookupType :: Name + -- ^ Name of a type family. + -> String + -- ^ Name of the declaration to derive. + -> Q [Dec] +deriveTypeScriptLookupType name declNameStr = do + info <- reify name + case info of + FamilyI (ClosedTypeFamilyD (TypeFamilyHead _name _vars _sig _maybeInject) eqns) _decs -> do + interfaceDecl <- getClosedTypeFamilyInterfaceDecl name eqns + return [FunD (mkName declNameStr) [Clause [] (NormalB (ListE [interfaceDecl])) []]] + + _ -> fail [i|Expected a close type family; got #{info}|] + +getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp +getClosedTypeFamilyInterfaceDecl name eqns = do + fields <- forM eqns $ \case +#if MIN_VERSION_template_haskell(2,15,0) + TySynEqn Nothing (AppT (ConT _) (ConT arg)) result -> do + [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) Nothing |] + TySynEqn Nothing (AppT (ConT _) (PromotedT arg)) result -> do + [| TSField False (getTypeScriptType (Proxy :: Proxy $(promotedT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) Nothing |] +#else + TySynEqn [ConT arg] result -> do + [| TSField False (getTypeScriptType (Proxy :: Proxy $(conT arg))) (getTypeScriptType (Proxy :: Proxy $(return result))) Nothing |] +#endif + x -> fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|] + + [| TSInterfaceDeclaration $(TH.stringE $ nameBase name) [] (L.sortBy (compare `on` fieldName) $(listE $ fmap return fields)) Nothing |] + +getClosedTypeFamilyImage :: [TySynEqn] -> Q [Type] +getClosedTypeFamilyImage eqns = do + forM eqns $ \case +#if MIN_VERSION_template_haskell(2,15,0) + TySynEqn Nothing (AppT (ConT _) _) result -> return result +#else + TySynEqn [ConT _] result -> return result +#endif + x -> fail [i|aeson-typescript doesn't know yet how to handle this type family equation: '#{x}'|] diff --git a/src/Data/Aeson/TypeScript/LookupTypes.hs b/src/Data/Aeson/TypeScript/LookupTypes.hs deleted file mode 100644 index db6142a..0000000 --- a/src/Data/Aeson/TypeScript/LookupTypes.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TemplateHaskell #-} - - -module Data.Aeson.TypeScript.LookupTypes where - - -import Control.Monad -import qualified Data.Aeson as A -import Data.Aeson.TypeScript.Types -import Data.Maybe -import Data.Proxy -import qualified Data.Text as T -import Data.Void -import Language.Haskell.TH -import Language.Haskell.TH.Datatype - --- | Given a data type whose constructors all evaluate to string keys, and a type family, --- build a TS interface declaration whose keys are the GADT strings and whose values are the --- types of the value the constructor is *mapped to under the type family*. --- --- This is useful when the data type is a GADT (so the different constructors can be tagged --- with different types), and you want to produce a TypeScript "lookup type" --- corresponding to the type family. --- --- Will ignore Void values returned by the type family. --- -typeFamilyToLookupType :: Name -> Name -> Q Exp -typeFamilyToLookupType gadt typeFamily = do - DatatypeInfo {datatypeCons} <- reifyDatatype gadt - - members <- forM (fmap constructorName datatypeCons) $ \consName -> do - fieldName <- [|case A.toJSON $(conE consName) of A.String t -> T.unpack t; _ -> error "Constructor must serialize to string"|] - proxyExpr <- [|(Proxy :: Proxy ($(return $ PromotedT typeFamily) $(return $ PromotedT consName)))|] - return [|if TSType $(return proxyExpr) == TSType (Proxy :: Proxy Void) then Nothing else - Just (TSField False $(return fieldName) (getTypeScriptType $(return proxyExpr)))|] - - let name = nameBase typeFamily <> "Lookup" - - [|TSInterfaceDeclaration $(stringE name) [] (catMaybes $(listE members))|] - - --- | Given a data type like the one in 'typeFamilyToLookupType', generate a list of 'TSType' --- representing the types of (TypeFamily Constructor), for every Constructor of the data type. --- This is useful for gathering the TypeScript declarations for types in the image of the --- type family. -getImageOfConstructorsUnderTypeFamily :: Name -> Name -> Q Exp -getImageOfConstructorsUnderTypeFamily gadt typeFamily = do - DatatypeInfo {datatypeCons} <- reifyDatatype gadt - - exprs <- forM (fmap constructorName datatypeCons) $ \consName -> do - [|TSType (Proxy :: Proxy ($(return $ PromotedT typeFamily) $(return $ PromotedT consName)))|] - - return $ ListE exprs diff --git a/src/Data/Aeson/TypeScript/Recursive.hs b/src/Data/Aeson/TypeScript/Recursive.hs index 4bcc546..8eb673c 100755 --- a/src/Data/Aeson/TypeScript/Recursive.hs +++ b/src/Data/Aeson/TypeScript/Recursive.hs @@ -1,19 +1,131 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, NamedFieldPuns, MultiWayIf, ViewPatterns, LambdaCase, PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} module Data.Aeson.TypeScript.Recursive ( + -- * Getting declarations recursively getTransitiveClosure + , getTypeScriptDeclarationsRecursively + + -- * Deriving missing instances recursively + , recursivelyDeriveMissingTypeScriptInstancesFor + , recursivelyDeriveMissingInstancesFor + , deriveInstanceIfNecessary + , doesTypeScriptInstanceExist + , getAllParentTypes ) where +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Control.Monad.Writer import Data.Aeson.TypeScript.Instances () 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 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 -getTransitiveClosure initialTypes = fix (\loop items -> let items' = S.unions (items : [getMore x | x <- S.toList items]) in - if | items' == items -> items - | otherwise -> loop items' - ) initialTypes +getTransitiveClosure = fix $ \loop items -> + let items' = S.unions (items : [getMore x | x <- S.toList items]) + in if + | items' == items -> items + | otherwise -> loop items' + where getMore :: TSType -> S.Set TSType getMore (TSType x) = S.fromList $ getParentTypes x + +getTypeScriptDeclarationsRecursively :: (TypeScript a) => Proxy a -> [TSDeclaration] +getTypeScriptDeclarationsRecursively initialType = S.toList $ S.fromList declarations + where + closure = getTransitiveClosure (S.fromList [TSType initialType]) + declarations = mconcat [getTypeScriptDeclarations x | TSType x <- S.toList closure] + + +-- * Recursively deriving missing TypeScript interfaces + +recursivelyDeriveMissingTypeScriptInstancesFor :: (Monoid w) => Name -> (Name -> Q w) -> Q w +recursivelyDeriveMissingTypeScriptInstancesFor = recursivelyDeriveMissingInstancesFor doesTypeScriptInstanceExist + +recursivelyDeriveMissingInstancesFor :: (Monoid w) => (Name -> Q Bool) -> Name -> (Name -> Q w) -> Q w +recursivelyDeriveMissingInstancesFor doesInstanceExist name deriveFn = execWriterT $ do + deriveInstanceIfNecessary name deriveFn + + names <- lift $ getAllParentTypes name doesInstanceExist + forM_ names $ \n -> deriveInstanceIfNecessary n deriveFn + +deriveInstanceIfNecessary :: (Monoid w) => Name -> (Name -> Q w) -> WriterT w Q () +deriveInstanceIfNecessary name deriveFn = do + lift (doesTypeScriptInstanceExist name) >>= \case + True -> return () + False -> do + (lift $ nothingOnFail (deriveFn name)) >>= \case + Nothing -> lift $ reportWarning [i|Failed to derive decls for name '#{name}'|] + Just x -> tell x + +doesTypeScriptInstanceExist :: Name -> Q Bool +doesTypeScriptInstanceExist name = do + result :: Maybe Bool <- runMaybeT $ do + (DatatypeInfo {..}) <- MaybeT $ nothingOnFail $ reifyDatatype name + + -- Skip names with type parameters for now + when (datatypeVars /= []) $ fail "" + + MaybeT $ nothingOnFail $ isInstance ''TypeScript [ConT name] + + return $ fromMaybe True result + +getAllParentTypes :: Name -> (Name -> Q Bool) -> Q [Name] +getAllParentTypes name pruneFn = reverse <$> execStateT (getAllParentTypes' name pruneFn) [] + where + getAllParentTypes' :: Name -> (Name -> Q Bool) -> StateT [Name] Q () + getAllParentTypes' nm pfn = (lift $ nothingOnFail $ pfn nm) >>= \case + Nothing -> return () + Just True -> return () + Just False -> (lift $ nothingOnFail (reifyDatatype nm)) >>= \case + Nothing -> do + lift $ reportWarning [i|Failed to reify: '#{nm}'|] + Just (DatatypeInfo {..}) -> do + let parentTypes = mconcat $ fmap constructorFields datatypeCons + + let maybeRecurse n = do + st <- get + unless (n `L.elem` st) $ do + modify (n :) + getAllParentTypes' n pfn + + forM_ parentTypes $ \typ -> do + let names :: [Name] = fst $ execState (getNamesFromType typ) ([], [typ]) + forM_ names maybeRecurse + + getNamesFromType :: Type -> State ([Name], [Type]) () + getNamesFromType (ConT n) = modify (first $ addIfNotPresent n) + getNamesFromType (AppT t1 t2) = handleTwoTypes t1 t2 + getNamesFromType (InfixT t1 _ t2) = handleTwoTypes t1 t2 + getNamesFromType (UInfixT t1 _ t2) = handleTwoTypes t1 t2 + getNamesFromType _ = return () + + handleTwoTypes t1 t2 = do + (_, visitedTypes) <- get + unless (t1 `L.elem` visitedTypes) $ do + modify (second (t1 :)) + getNamesFromType t1 + + (_, visitedTypes') <- get + unless (t2 `L.elem` visitedTypes') $ do + modify (second (t2 :)) + getNamesFromType t2 + + addIfNotPresent :: (Eq a) => a -> [a] -> [a] + addIfNotPresent x xs | x `L.elem` xs = xs + addIfNotPresent x xs = x : xs diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index e990428..4663a8f 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, NamedFieldPuns, MultiWayIf, ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} {-| Module: Data.Aeson.TypeScript.TH -Copyright: (c) 2018 Tom McLaughlin +Copyright: (c) 2022 Tom McLaughlin License: BSD3 Stability: experimental Portability: portable @@ -35,7 +39,7 @@ $('deriveTypeScript' ('defaultOptions' {'fieldLabelModifier' = 'drop' 4, 'constr Now we can use the newly created instances. @ ->>> putStrLn $ 'formatTSDeclarations' $ 'getTypeScriptDeclarations' (Proxy :: Proxy D) +>>> putStrLn $ 'formatTSDeclarations' $ 'getTypeScriptDeclarations' (Proxy :: Proxy (D T)) type D\ = INullary\ | IUnary\ | IProduct\ | IRecord\; @@ -98,253 +102,240 @@ main = putStrLn $ 'formatTSDeclarations' ( -} module Data.Aeson.TypeScript.TH ( - deriveTypeScript, + deriveTypeScript + , deriveTypeScript' + , deriveTypeScriptLookupType -- * The main typeclass - TypeScript(..), - TSType(..), + , TypeScript(..) + , TSType(..) - TSDeclaration, + , TSDeclaration(TSRawDeclaration) -- * Formatting declarations - formatTSDeclarations, - formatTSDeclarations', - formatTSDeclaration, - FormattingOptions(..), + , formatTSDeclarations + , formatTSDeclarations' + , formatTSDeclaration + , FormattingOptions(..) + , defaultFormattingOptions + , defaultNameFormatter + , SumTypeFormat(..) + , ExportMode(..) + + -- * Advanced options + , defaultExtraTypeScriptOptions + , keyType + , typeFamiliesToMapToTypeScript + , ExtraTypeScriptOptions -- * Convenience tools - HasJSONOptions(..), - deriveJSONAndTypeScript, - - module Data.Aeson.TypeScript.Instances + , HasJSONOptions(..) + , deriveJSONAndTypeScript + , deriveJSONAndTypeScript' + + , T(..) + , T1(..) + , T2(..) + , T3(..) + , T4(..) + , T5(..) + , T6(..) + , T7(..) + , T8(..) + , T9(..) + , T10(..) + + , module Data.Aeson.TypeScript.Instances ) where import Control.Monad +import Control.Monad.Writer import Data.Aeson as A import Data.Aeson.TH as A import Data.Aeson.TypeScript.Formatting import Data.Aeson.TypeScript.Instances () +import Data.Aeson.TypeScript.Lookup +import Data.Aeson.TypeScript.Transform +import Data.Aeson.TypeScript.TypeManipulation import Data.Aeson.TypeScript.Types -import qualified Data.Map as M +import Data.Aeson.TypeScript.Util +import qualified Data.List as L import Data.Maybe -import Data.Monoid import Data.Proxy -import Data.String.Interpolate.IsString -import qualified Data.Text as T +import Data.String.Interpolate import Language.Haskell.TH hiding (stringE) import Language.Haskell.TH.Datatype +import qualified Language.Haskell.TH.Lib as TH -data T = T -data T1 = T1 -data T2 = T2 -data T3 = T3 -data T4 = T4 -data T5 = T5 -data T6 = T6 -data T7 = T7 -data T8 = T8 -data T9 = T9 -data T10 = T10 - -instance TypeScript T where getTypeScriptType _ = "T" -instance TypeScript T1 where getTypeScriptType _ = "T1" -instance TypeScript T2 where getTypeScriptType _ = "T2" -instance TypeScript T3 where getTypeScriptType _ = "T3" -instance TypeScript T4 where getTypeScriptType _ = "T4" -instance TypeScript T5 where getTypeScriptType _ = "T5" -instance TypeScript T6 where getTypeScriptType _ = "T6" -instance TypeScript T7 where getTypeScriptType _ = "T7" -instance TypeScript T8 where getTypeScriptType _ = "T8" -instance TypeScript T9 where getTypeScriptType _ = "T9" -instance TypeScript T10 where getTypeScriptType _ = "T10" - - --- | Generates a 'TypeScript' instance declaration for the given data type. -deriveTypeScript :: Options - -- ^ Encoding options. - -> Name - -- ^ Name of the type for which to generate a 'TypeScript' instance declaration. - -> Q [Dec] -deriveTypeScript options name = do - datatypeInfo@(DatatypeInfo {..}) <- reifyDatatype name - - assertExtensionsTurnedOn datatypeInfo - - let getFreeVariableName (SigT (VarT n) _kind) = Just n - getFreeVariableName _ = Nothing - - let templateVarsToUse = case length datatypeVars of - 1 -> [ConT ''T] - _ -> take (length datatypeVars) [ConT ''T1, ConT ''T2, ConT ''T3, ConT ''T4, ConT ''T5, ConT ''T6, ConT ''T7, ConT ''T8, ConT ''T9, ConT ''T10] - -#if MIN_VERSION_th_abstraction(0,3,0) - let subMap = M.fromList $ zip (mapMaybe getFreeVariableName datatypeInstTypes) templateVarsToUse - let fullyQualifiedDatatypeInfo = (datatypeInfo {datatypeInstTypes = templateVarsToUse - , datatypeCons = fmap (applySubstitution subMap) datatypeCons}) -#else - let subMap = M.fromList $ zip (mapMaybe getFreeVariableName datatypeVars) templateVarsToUse - 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) []] -#if MIN_VERSION_th_abstraction(0,3,0) - 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]] +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid #endif - True -> return [] - - return $ fullyGenericInstance : otherInstances - --- | For the fully generic instance, the parent types are the types inside the constructors -getGenericParentTypesExpression :: DatatypeInfo -> Q Exp -getGenericParentTypesExpression (DatatypeInfo {..}) = return $ ListE [AppE (ConE 'TSType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ)) | typ <- types] - where types = mconcat $ fmap constructorFields $ datatypeCons - --- | For the non-generic instances, the parent type is the generic type -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 - -- 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)]] - let genericVariablesExp = ListE [stringE x | x <- genericVariables] - - declarationFnBody <- do - let interfaceNamesAndDeclarations = fmap (handleConstructor options datatypeInfo genericVariables) datatypeCons - let interfaceDeclarations = catMaybes $ fmap snd3 interfaceNamesAndDeclarations - - 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] - - _ -> do - let interfaceNames = fmap fst3 interfaceNamesAndDeclarations - - let typeDeclaration = applyToArgsE (ConE 'TSTypeAlternatives) [stringE $ getTypeName datatypeName, genericVariablesExp, ListE interfaceNames] - return $ NormalB $ ListE (typeDeclaration : interfaceDeclarations) - - 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 +-- | Generates a 'TypeScript' instance declaration for the given data type. +deriveTypeScript' :: Options + -- ^ Encoding options. + -> Name + -- ^ Name of the type for which to generate a 'TypeScript' instance declaration. + -> ExtraTypeScriptOptions + -- ^ Extra options to control advanced features. + -> Q [Dec] +deriveTypeScript' options name extraOptions = do + datatypeInfo' <- reifyDatatype name + assertExtensionsTurnedOn datatypeInfo' + + -- Figure out what the generic variables are + let eligibleGenericVars = catMaybes $ flip fmap (getDataTypeVars datatypeInfo') $ \case + SigT (VarT n) StarT -> Just n + _ -> Nothing + let varsAndTVars = case eligibleGenericVars of + [] -> [] + [x] -> [(x, "T")] + xs -> zip xs allStarConstructors'' + genericVariablesAndSuffixes <- forM varsAndTVars $ \(var, tvar) -> do + (_, genericInfos) <- runWriterT $ forM_ (datatypeCons datatypeInfo') $ \ci -> + forM_ (namesAndTypes options [] ci) $ \(_, _, typ) -> do + searchForConstraints extraOptions typ var + return (var, (unifyGenericVariable genericInfos, tvar)) + + -- Plug in generic variables and de-family-ify + ((\x -> (datatypeInfo' { datatypeCons = x })) -> dti, extraDeclsOrGenericInfosInitial) <- runWriterT $ forM (datatypeCons datatypeInfo') $ \ci -> + ((\x -> ci { constructorFields = x }) <$>) $ forM (constructorFields ci) $ + transformTypeFamilies extraOptions . mapType genericVariablesAndSuffixes + + -- Build constraints: a TypeScript constraint for every constructor type and one for every type variable. + -- Probably overkill/not exactly right, but it's a start. + let constructorPreds :: [Pred] = [AppT (ConT ''TypeScript) x | x <- mconcat $ fmap constructorFields (datatypeCons dti) + , hasFreeTypeVariable x + , not $ coveredByDataTypeVars (getDataTypeVars dti) x + ] + let constructorPreds' :: [Pred] = [AppT (ConT ''TypeScript) x | x <- mconcat $ fmap constructorFields (datatypeCons datatypeInfo') + , hasFreeTypeVariable x + , not $ coveredByDataTypeVars (getDataTypeVars dti) x + ] + let typeVariablePreds :: [Pred] = [AppT (ConT ''TypeScript) x | x <- getDataTypeVars dti] + + -- Build the declarations + (types, (extraDeclsOrGenericInfosInitial <>) -> extraDeclsOrGenericInfos) <- runWriterT $ mapM (handleConstructor extraOptions options dti genericVariablesAndSuffixes) (datatypeCons dti) + typeDeclaration <- [|TSTypeAlternatives $(TH.stringE $ getTypeName (datatypeName dti)) + $(genericVariablesListExpr True genericVariablesAndSuffixes) + $(listE $ fmap return types) + $(tryGetDoc (haddockModifier extraOptions) (datatypeName dti))|] + + declarationsFunctionBody <- [| $(return typeDeclaration) : $(listE (fmap return [x | ExtraDecl x <- extraDeclsOrGenericInfos])) |] + + -- Couldn't figure out how to put the constraints for "instance TypeScript..." in the quasiquote above without + -- introducing () when the constraints are empty, which causes "illegal tuple constraint" unless the user enables ConstraintKinds. + -- So, just use our mkInstance function + getTypeScriptTypeExp <- [|$(TH.stringE $ getTypeName (datatypeName dti)) <> $(getBracketsExpressionAllTypesNoSuffix genericVariablesAndSuffixes)|] + getParentTypesExp <- listE [ [|TSType (Proxy :: Proxy $(return t))|] + | t <- (mconcat $ fmap constructorFields (datatypeCons datatypeInfo')) <> [x | ExtraParentType x <- extraDeclsOrGenericInfos]] + let predicates = L.nub (constructorPreds <> constructorPreds' <> typeVariablePreds <> [x | ExtraConstraint x <- extraDeclsOrGenericInfos]) + keyTypeDecl <- case keyType extraOptions of + Nothing -> return [] + Just kt -> do + keyTypeExp <- [|$(TH.stringE kt)|] + return $ [FunD 'getTypeScriptKeyType [Clause [WildP] (NormalB keyTypeExp) []]] + let inst = [mkInstance predicates (AppT (ConT ''TypeScript) (foldl AppT (ConT name) (getDataTypeVars dti))) ([ + FunD 'getTypeScriptType [Clause [WildP] (NormalB getTypeScriptTypeExp) []] + , FunD 'getTypeScriptDeclarations [Clause [WildP] (NormalB declarationsFunctionBody) []] + , FunD 'getParentTypes [Clause [WildP] (NormalB getParentTypesExp) []] + ] <> keyTypeDecl)] + return (mconcat [x | ExtraTopLevelDecs x <- extraDeclsOrGenericInfos] <> inst) -- | 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) -handleConstructor options (DatatypeInfo {..}) genericVariables ci@(ConstructorInfo {}) = - if | isSingleConstructorType && not (getTagSingleConstructors options) -> (stringE interfaceNameWithBrackets, singleConstructorEncoding, True) - +handleConstructor :: ExtraTypeScriptOptions -> Options -> DatatypeInfo -> [(Name, (Suffix, Var))] -> ConstructorInfo -> WriterT [ExtraDeclOrGenericInfo] Q Exp +handleConstructor (ExtraTypeScriptOptions {..}) options (DatatypeInfo {..}) genericVariables ci = do + if | (length datatypeCons == 1) && not (getTagSingleConstructors options) -> do + writeSingleConstructorEncoding + brackets <- lift $ getBracketsExpression False genericVariables + lift [|$(TH.stringE interfaceName) <> $(return brackets)|] | allConstructorsAreNullary datatypeCons && allNullaryToStringTag options -> stringEncoding -- With UntaggedValue, nullary constructors are encoded as strings | (isUntaggedValue $ sumEncoding options) && isConstructorNullary ci -> stringEncoding -- Treat as a sum - | isObjectWithSingleField $ sumEncoding options -> (stringE [i|{#{show constructorNameToUse}: #{interfaceNameWithBrackets}}|], singleConstructorEncoding, False) - | isTwoElemArray $ sumEncoding options -> (stringE [i|[#{show constructorNameToUse}, #{interfaceNameWithBrackets}]|], singleConstructorEncoding, False) - | isUntaggedValue $ sumEncoding options -> (stringE interfaceNameWithBrackets, singleConstructorEncoding, True) - | otherwise -> (stringE interfaceNameWithBrackets, taggedConstructorEncoding, True) + | isObjectWithSingleField $ sumEncoding options -> do + writeSingleConstructorEncoding + brackets <- lift $ getBracketsExpression False genericVariables + lift [|"{" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ": " <> $(TH.stringE interfaceName) <> $(return brackets) <> "}"|] + | isTwoElemArray $ sumEncoding options -> do + writeSingleConstructorEncoding + brackets <- lift $ getBracketsExpression False genericVariables + lift [|"[" <> $(TH.stringE $ show $ constructorNameToUse options ci) <> ", " <> $(TH.stringE interfaceName) <> $(return brackets) <> "]"|] + | isUntaggedValue $ sumEncoding options -> do + writeSingleConstructorEncoding + brackets <- lift $ getBracketsExpression False genericVariables + lift [|$(TH.stringE interfaceName) <> $(return brackets)|] + | otherwise -> do + tagField :: [Exp] <- lift $ case sumEncoding options of + TaggedObject tagFieldName _ -> (: []) <$> [|TSField False $(TH.stringE tagFieldName) $(TH.stringE [i|"#{constructorNameToUse options ci}"|]) Nothing|] + _ -> return [] + + tsFields <- getTSFields + decl <- lift $ assembleInterfaceDeclaration (ListE (tagField ++ tsFields)) + tell [ExtraDecl decl] + brackets <- lift $ getBracketsExpression False genericVariables + lift [|$(TH.stringE interfaceName) <> $(return brackets)|] where - stringEncoding = (stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|], Nothing, True) - - singleConstructorEncoding = if | constructorVariant ci == NormalConstructor -> tupleEncoding - | otherwise -> Just $ assembleInterfaceDeclaration (ListE (getTSFields options namesAndTypes)) + stringEncoding = lift $ TH.stringE [i|"#{(constructorTagModifier options) $ getTypeName (constructorName ci)}"|] + + writeSingleConstructorEncoding = if + | constructorVariant ci == NormalConstructor -> do + encoding <- tupleEncoding + tell [ExtraDecl encoding] + +#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 + alternatives <- lift [|TSTypeAlternatives $(TH.stringE interfaceName) + $(genericVariablesListExpr True genericVariables) + [$(return stringExp)] + $(tryGetDoc haddockModifier (constructorName ci))|] + tell [ExtraDecl alternatives] +#endif - taggedConstructorEncoding = Just $ assembleInterfaceDeclaration (ListE (tagField ++ getTSFields options namesAndTypes)) + | otherwise -> do + tsFields <- getTSFields + decl <- lift $ assembleInterfaceDeclaration (ListE tsFields) + tell [ExtraDecl decl] -- * Type declaration to use - interfaceName = getInterfaceName ci - interfaceNameWithBrackets = interfaceName <> getGenericBrackets genericVariables - - tupleEncoding = Just $ applyToArgsE (ConE 'TSTypeAlternatives) [stringE $ interfaceName - , ListE [stringE x | x <- genericVariables] - , ListE [getTypeAsStringExp contentsTupleType]] - - namesAndTypes :: [(String, Type)] = case constructorVariant ci of - RecordConstructor names -> zip (fmap ((fieldLabelModifier options) . lastNameComponent') names) (constructorFields ci) - NormalConstructor -> case sumEncoding options of - TaggedObject _ contentsFieldName -> if | isConstructorNullary ci -> [] - | otherwise -> [(contentsFieldName, contentsTupleType)] - _ -> [(constructorNameToUse, contentsTupleType)] - - tagField = case sumEncoding options of - TaggedObject tagFieldName _ -> [(AppE (AppE (AppE (ConE 'TSField) (ConE 'False)) - (stringE tagFieldName)) - (stringE [i|"#{constructorNameToUse}"|]))] - _ -> [] - - isSingleConstructorType = length datatypeCons == 1 - - getInterfaceName (constructorName -> x) = "I" <> (lastNameComponent' x) - - constructorNameToUse = (constructorTagModifier options) $ lastNameComponent' (constructorName ci) - contentsTupleType = getTupleType (constructorFields ci) - - assembleInterfaceDeclaration members = AppE (AppE (AppE (ConE 'TSInterfaceDeclaration) (stringE interfaceName)) genericVariablesExp) members where - genericVariablesExp = (ListE [stringE x | x <- genericVariables]) - - --- | Helper for handleConstructor -getTSFields :: Options -> [(String, Type)] -> [Exp] -getTSFields options namesAndTypes = - [ (AppE (AppE (AppE (ConE 'TSField) optAsBool) - (stringE nameString)) - fieldTyp) - | (nameString, typ) <- namesAndTypes - , let (fieldTyp, optAsBool) = getFieldType options typ] - -getFieldType :: Options -> Type -> (Exp, Exp) -getFieldType options (AppT (ConT name) t) - | not (omitNothingFields options) && name == ''Maybe - = (AppE (AppE (VarE 'mappend) (getTypeAsStringExp t)) (stringE " | null"), getOptionalAsBoolExp t) -getFieldType _ typ = (getTypeAsStringExp typ, getOptionalAsBoolExp typ) - - --- * Getting type expression - --- | Get an expression to be used for getTypeScriptType. --- For datatypes of kind * this is easy, since we can just evaluate the string literal in TH. --- For higher-kinded types, we need to make an expression which evaluates the template types and fills it in. -#if MIN_VERSION_th_abstraction(0,3,0) -getTypeExpression :: DatatypeInfo -> Q Exp -getTypeExpression (DatatypeInfo {datatypeInstTypes=[], ..}) = return $ stringE $ getTypeName datatypeName -getTypeExpression (DatatypeInfo {datatypeInstTypes=vars, ..}) = do -#else -getTypeExpression :: DatatypeInfo -> Q Exp -getTypeExpression (DatatypeInfo {datatypeVars=[], ..}) = return $ stringE $ getTypeName datatypeName -getTypeExpression (DatatypeInfo {datatypeVars=vars, ..}) = do -#endif - let baseName = stringE $ getTypeName datatypeName - let typeNames = ListE [getTypeAsStringExp typ | typ <- vars] - let headType = AppE (VarE 'head) typeNames - let tailType = AppE (VarE 'tail) typeNames - let comma = stringE ", " - x <- newName "x" - let tailsWithCommas = AppE (VarE 'mconcat) (CompE [BindS (VarP x) tailType, NoBindS (AppE (AppE (VarE 'mappend) comma) (VarE x))]) - let brackets = AppE (VarE 'mconcat) (ListE [stringE "<", headType, tailsWithCommas, stringE ">"]) + interfaceName = "I" <> (lastNameComponent' $ constructorName ci) + + tupleEncoding = + lift [|TSTypeAlternatives $(TH.stringE interfaceName) + $(genericVariablesListExpr True genericVariables) + [getTypeScriptType (Proxy :: Proxy $(return (contentsTupleTypeSubstituted genericVariables ci)))] + $(tryGetDoc haddockModifier (constructorName ci))|] + + assembleInterfaceDeclaration members = [|TSInterfaceDeclaration $(TH.stringE interfaceName) + $(genericVariablesListExpr True genericVariables) + $(return members) + $(tryGetDoc haddockModifier (constructorName ci))|] + + 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) -> + ( , ) <$> [|$(getTypeAsStringExp t) <> " | null"|] <*> getOptionalAsBoolExp t + _ -> ( , ) <$> getTypeAsStringExp typ <*> getOptionalAsBoolExp typ + + lift [| TSField $(return optAsBool) $(TH.stringE nameString) $(return fieldTyp) $(tryGetDoc haddockModifier name) |] - return $ (AppE (AppE (VarE 'mappend) baseName) brackets) + isSingleRecordConstructor (constructorVariant -> RecordConstructor [_]) = True + isSingleRecordConstructor _ = False -- * Convenience functions -- | Convenience function to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instances simultaneously, so the instances are guaranteed to be in sync. -- --- This function is given mainly as an illustration. If you want some other permutation of instances, such as 'A.ToJSON' and 'A.TypeScript' only, just take a look at the source and write your own version. +-- This function is given mainly as an illustration. +-- If you want some other permutation of instances, such as 'A.ToJSON' and 'A.TypeScript' only, just take a look at the source and write your own version. -- -- @since 0.1.0.4 deriveJSONAndTypeScript :: Options @@ -352,107 +343,21 @@ deriveJSONAndTypeScript :: Options -> Name -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations. -> Q [Dec] -deriveJSONAndTypeScript options name = do - ts <- deriveTypeScript options name - json <- A.deriveJSON options name - return $ ts <> json +deriveJSONAndTypeScript options name = (<>) <$> (deriveTypeScript options name) <*> (A.deriveJSON options name) --- * Util stuff +deriveJSONAndTypeScript' :: Options + -- ^ Encoding options. + -> Name + -- ^ Name of the type for which to generate 'A.ToJSON', 'A.FromJSON', and 'TypeScript' instance declarations. + -> ExtraTypeScriptOptions + -- ^ Extra options to control advanced features. + -> Q [Dec] +deriveJSONAndTypeScript' options name extraOptions = (<>) <$> (deriveTypeScript' options name extraOptions) <*> (A.deriveJSON options name) -lastNameComponent :: String -> String -lastNameComponent x = T.unpack $ last $ T.splitOn "." (T.pack x) - -lastNameComponent' :: Name -> String -lastNameComponent' = lastNameComponent . show - -getTypeName :: Name -> String -getTypeName x = lastNameComponent $ show x - -allConstructorsAreNullary :: [ConstructorInfo] -> Bool -allConstructorsAreNullary constructors = and $ fmap isConstructorNullary constructors - -isConstructorNullary :: ConstructorInfo -> Bool -isConstructorNullary (ConstructorInfo {constructorVariant, constructorFields}) = (constructorVariant == NormalConstructor) && (constructorFields == []) - --- In Template Haskell 2.10.0.0 and later, Pred is just a synonm for Type --- In earlier versions, it has constructors -getDatatypePredicate :: Type -> Pred -#if MIN_VERSION_template_haskell(2,10,0) -getDatatypePredicate typ = AppT (ConT ''TypeScript) typ -#else -getDatatypePredicate typ = ClassP ''TypeScript [typ] -#endif - -getTypeAsStringExp :: Type -> Exp -getTypeAsStringExp typ = AppE (VarE 'getTypeScriptType) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ)) - -getOptionalAsBoolExp :: Type -> Exp -getOptionalAsBoolExp typ = AppE (VarE 'getTypeScriptOptional) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) typ)) - -isTaggedObject (sumEncoding -> TaggedObject _ _) = True -isTaggedObject _ = False - --- | Get the type of a tuple of constructor fields, as when we're packing a record-less constructor into a list -getTupleType constructorFields = case length constructorFields of - 0 -> AppT ListT (ConT ''()) - 1 -> head constructorFields - x -> applyToArgsT (ConT $ tupleTypeName x) constructorFields - --- | Helper to 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 -applyToArgsE :: Exp -> [Exp] -> Exp -applyToArgsE f [] = f -applyToArgsE f (x:xs) = applyToArgsE (AppE f x) xs - -stringE = LitE . StringL - --- Between Template Haskell 2.10 and 2.11, InstanceD got an additional argument -#if MIN_VERSION_template_haskell(2,11,0) -mkInstance context typ decs = InstanceD Nothing context typ decs -#else -mkInstance context typ decs = InstanceD context typ decs -#endif - --- Between Aeson 1.1.2.0 and 1.2.0.0, tagSingleConstructors was added -getTagSingleConstructors :: Options -> Bool -#if MIN_VERSION_aeson(1,2,0) -getTagSingleConstructors options = tagSingleConstructors options -#else -getTagSingleConstructors _ = False -#endif - --- Between Template Haskell 2.10 and 2.11, the ability to look up which extensions are turned on was added -assertExtensionsTurnedOn :: DatatypeInfo -> Q () -#if MIN_VERSION_template_haskell(2,11,0) -assertExtensionsTurnedOn (DatatypeInfo {..}) = do - -- Check that necessary language extensions are turned on - scopedTypeVariablesEnabled <- isExtEnabled ScopedTypeVariables - kindSignaturesEnabled <- isExtEnabled KindSignatures - when (not scopedTypeVariablesEnabled) $ error [i|The ScopedTypeVariables extension is required; please enable it before calling deriveTypeScript. (For example: put {-# LANGUAGE ScopedTypeVariables #-} at the top of the file.)|] - when ((not kindSignaturesEnabled) && (length datatypeVars > 0)) $ error [i|The KindSignatures extension is required since type #{datatypeName} is a higher order type; please enable it before calling deriveTypeScript. (For example: put {-# LANGUAGE KindSignatures #-} at the top of the file.)|] -#else -assertExtensionsTurnedOn _ = return () -#endif - --- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this -isObjectWithSingleField ObjectWithSingleField = True -isObjectWithSingleField _ = False - --- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this -isTwoElemArray TwoElemArray = True -isTwoElemArray _ = False - --- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this --- UntaggedValue was added between Aeson 0.11.3.0 and 1.0.0.0 -#if MIN_VERSION_aeson(1,0,0) -isUntaggedValue UntaggedValue = True -#endif -isUntaggedValue _ = False - -fst3 (x, _, _) = x -snd3 (_, y, _) = y -thd3 (_, _, z) = z +-- | Generates a 'TypeScript' instance declaration for the given data type. +deriveTypeScript :: Options + -- ^ Encoding options. + -> Name + -- ^ Name of the type for which to generate a 'TypeScript' instance declaration. + -> Q [Dec] +deriveTypeScript options name = deriveTypeScript' options name defaultExtraTypeScriptOptions diff --git a/src/Data/Aeson/TypeScript/Transform.hs b/src/Data/Aeson/TypeScript/Transform.hs new file mode 100644 index 0000000..f5494e1 --- /dev/null +++ b/src/Data/Aeson/TypeScript/Transform.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} + + +module Data.Aeson.TypeScript.Transform ( + transformTypeFamilies + ) where + +import Control.Monad.Writer +import Data.Aeson.TypeScript.Lookup +import Data.Aeson.TypeScript.Types +import qualified Data.List as L +import Data.Typeable +import Language.Haskell.TH hiding (stringE) +import qualified Language.Haskell.TH.Lib as TH + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + + +-- | Search the given type for type families. For each one found, emit a declaration for a new +-- corresponding concrete type and a TypeScript instance for it which emits a lookup type. +-- Then, replace all occurrences of the given type family with the concrete type in the return value. +-- Thus the type becomes "de-family-ified". +transformTypeFamilies :: ExtraTypeScriptOptions -> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type +transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) + | name `L.elem` typeFamiliesToMapToTypeScript = lift (reify name) >>= \case + FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) eqns) _ -> handle typeFamilyName eqns + +#if MIN_VERSION_template_haskell(2,15,0) + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle typeFamilyName [eqn | TySynInstD eqn <- decs] +#else + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle typeFamilyName [eqn | TySynInstD _name eqn <- decs] +#endif + + _ -> AppT (ConT name) <$> transformTypeFamilies eo typ + | otherwise = AppT (ConT name) <$> transformTypeFamilies eo typ + where + handle :: Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type + handle typeFamilyName eqns = do + name' <- lift $ newName (nameBase typeFamilyName <> "'") + + f <- lift $ newName "f" +#if MIN_VERSION_template_haskell(2,17,0) + let inst1 = DataD [] name' [PlainTV f ()] Nothing [] [] +#else + let inst1 = DataD [] name' [PlainTV f] Nothing [] [] +#endif + tell [ExtraTopLevelDecs [inst1]] + + imageTypes <- lift $ getClosedTypeFamilyImage eqns + inst2 <- lift $ [d|instance (Typeable g, TypeScript g) => TypeScript ($(conT name') g) where + getTypeScriptType _ = $(TH.stringE $ nameBase name) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]" + getTypeScriptDeclarations _ = [$(getClosedTypeFamilyInterfaceDecl name eqns)] + getParentTypes _ = $(listE [ [|TSType (Proxy :: Proxy $(return x))|] | x <- imageTypes]) + |] + tell [ExtraTopLevelDecs inst2] + + tell [ExtraParentType (AppT (ConT name') (ConT ''T))] + + ret <- transformTypeFamilies eo (AppT (ConT name') typ) + tell [ExtraConstraint (AppT (ConT ''TypeScript) ret)] + return ret +transformTypeFamilies eo (AppT typ1 typ2) = AppT <$> transformTypeFamilies eo typ1 <*> transformTypeFamilies eo typ2 +transformTypeFamilies eo (SigT typ kind) = flip SigT kind <$> transformTypeFamilies eo typ +transformTypeFamilies eo (InfixT typ1 n typ2) = InfixT <$> transformTypeFamilies eo typ1 <*> pure n <*> transformTypeFamilies eo typ2 +transformTypeFamilies eo (UInfixT typ1 n typ2) = UInfixT <$> transformTypeFamilies eo typ1 <*> pure n <*> transformTypeFamilies eo typ2 +transformTypeFamilies eo (ParensT typ) = ParensT <$> transformTypeFamilies eo typ +#if MIN_VERSION_template_haskell(2,15,0) +transformTypeFamilies eo (AppKindT typ kind) = flip AppKindT kind <$> transformTypeFamilies eo typ +transformTypeFamilies eo (ImplicitParamT s typ) = ImplicitParamT s <$> transformTypeFamilies eo typ +#endif +transformTypeFamilies _ typ = return typ diff --git a/src/Data/Aeson/TypeScript/TypeManipulation.hs b/src/Data/Aeson/TypeScript/TypeManipulation.hs new file mode 100644 index 0000000..9462d49 --- /dev/null +++ b/src/Data/Aeson/TypeScript/TypeManipulation.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Aeson.TypeScript.TypeManipulation ( + searchForConstraints + , hasFreeTypeVariable + , unifyGenericVariable + ) where + +import Control.Monad.Writer +import Data.Aeson.TypeScript.Types +import qualified Data.List as L +import Language.Haskell.TH + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + + +searchForConstraints :: ExtraTypeScriptOptions -> Type -> Name -> WriterT [GenericInfo] Q () +searchForConstraints eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) var + | typ == VarT var && (name `L.elem` typeFamiliesToMapToTypeScript) = lift (reify name) >>= \case + FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) _) _ -> do + tell [GenericInfo var (TypeFamilyKey typeFamilyName)] + searchForConstraints eo typ var + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) _ -> do + tell [GenericInfo var (TypeFamilyKey typeFamilyName)] + searchForConstraints eo typ var + _ -> searchForConstraints eo typ var + | otherwise = searchForConstraints eo typ var +searchForConstraints eo (AppT typ1 typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var +searchForConstraints eo (SigT typ _) var = searchForConstraints eo typ var +searchForConstraints eo (InfixT typ1 _ typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var +searchForConstraints eo (UInfixT typ1 _ typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var +searchForConstraints eo (ParensT typ) var = searchForConstraints eo typ var +#if MIN_VERSION_template_haskell(2,15,0) +searchForConstraints eo (AppKindT typ _) var = searchForConstraints eo typ var +searchForConstraints eo (ImplicitParamT _ typ) var = searchForConstraints eo typ var +#endif +searchForConstraints _ _ _ = return () + +hasFreeTypeVariable :: Type -> Bool +hasFreeTypeVariable (VarT _) = True +hasFreeTypeVariable (AppT typ1 typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2 +hasFreeTypeVariable (SigT typ _) = hasFreeTypeVariable typ +hasFreeTypeVariable (InfixT typ1 _ typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2 +hasFreeTypeVariable (UInfixT typ1 _ typ2) = hasFreeTypeVariable typ1 || hasFreeTypeVariable typ2 +hasFreeTypeVariable (ParensT typ) = hasFreeTypeVariable typ +#if MIN_VERSION_template_haskell(2,15,0) +hasFreeTypeVariable (AppKindT typ _) = hasFreeTypeVariable typ +hasFreeTypeVariable (ImplicitParamT _ typ) = hasFreeTypeVariable typ +#endif +hasFreeTypeVariable _ = False + +unifyGenericVariable :: [GenericInfo] -> String +unifyGenericVariable genericInfos = case [nameBase name | GenericInfo _ (TypeFamilyKey name) <- genericInfos] of + [] -> "" + names -> " extends keyof " <> (L.intercalate " & " names) diff --git a/src/Data/Aeson/TypeScript/Types.hs b/src/Data/Aeson/TypeScript/Types.hs index e688854..a96f635 100644 --- a/src/Data/Aeson/TypeScript/Types.hs +++ b/src/Data/Aeson/TypeScript/Types.hs @@ -1,12 +1,19 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, ExistentialQuantification, PolyKinds, StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Aeson.TypeScript.Types where import qualified Data.Aeson as A -import qualified Data.Aeson.TH as A +import Data.Aeson.TypeScript.LegalName +import Data.Function ((&)) +import qualified Data.List.NonEmpty as NonEmpty import Data.Proxy import Data.String +import qualified Data.Text as T import Data.Typeable +import Language.Haskell.TH -- | The typeclass that defines how a type is turned into TypeScript. -- @@ -47,13 +54,21 @@ class (Typeable a) => TypeScript a where getTypeScriptType :: Proxy a -> String -- ^ Get the type as a string. + getTypeScriptKeyType :: Proxy a -> String + getTypeScriptKeyType proxy = getTypeScriptType proxy + -- ^ Get the key type as a string. + getTypeScriptOptional :: Proxy a -> Bool -- ^ Get a flag representing whether this type is optional. getTypeScriptOptional _ = False getParentTypes :: Proxy a -> [TSType] - getParentTypes _ = [] -- ^ Get the types that this type depends on. This is useful for generating transitive closures of necessary types. + getParentTypes _ = [] + + isGenericVariable :: Proxy a -> Bool + -- ^ Special flag to indicate whether this type corresponds to a template variable. + isGenericVariable _ = False -- | An existential wrapper for any TypeScript instance. data TSType = forall a. (Typeable a, TypeScript a) => TSType { unTSType :: Proxy a } @@ -69,15 +84,22 @@ instance Show TSType where data TSDeclaration = TSInterfaceDeclaration { interfaceName :: String , interfaceGenericVariables :: [String] - , interfaceMembers :: [TSField] } + , interfaceMembers :: [TSField] + , interfaceDoc :: Maybe String } | TSTypeAlternatives { typeName :: String , typeGenericVariables :: [String] - , alternativeTypes :: [String]} + , alternativeTypes :: [String] + , typeDoc :: Maybe String } + | TSRawDeclaration { text :: String } deriving (Show, Eq, Ord) -data TSField = TSField { fieldOptional :: Bool - , fieldName :: String - , fieldType :: String } deriving (Show, Eq, Ord) +data TSField = TSField + { fieldOptional :: Bool + , fieldName :: String + , fieldType :: String + , fieldDoc :: Maybe String + -- ^ Haddock documentation for the field, if present + } deriving (Show, Eq, Ord) newtype TSString a = TSString { unpackTSString :: String } deriving Show @@ -93,14 +115,122 @@ data FormattingOptions = FormattingOptions -- ^ Function applied to generated interface names , typeNameModifier :: String -> String -- ^ Function applied to generated type names + , exportMode :: ExportMode + -- ^ Whether to include the export keyword in declarations + , typeAlternativesFormat :: SumTypeFormat + -- ^ How to format the declaration of the alternatives when multiple constructors exist } +data ExportMode = + ExportEach + -- ^ Prefix every declaration with the "export" keyword (suitable for putting in a TypeScripe module) + | ExportNone + -- ^ No exporting (suitable for putting in a .d.ts file) + +-- | TODO: docstrings here +data SumTypeFormat = + TypeAlias + | Enum + | EnumWithType + deriving (Eq, Show) + +defaultFormattingOptions :: FormattingOptions defaultFormattingOptions = FormattingOptions { numIndentSpaces = 2 - , interfaceNameModifier = id - , typeNameModifier = id + , interfaceNameModifier = defaultNameFormatter + , typeNameModifier = defaultNameFormatter + , exportMode = ExportNone + , typeAlternativesFormat = TypeAlias } +-- | The 'defaultNameFormatter' in the 'FormattingOptions' checks to see if +-- the name is a legal TypeScript name. If it is not, then it throws +-- a runtime error. +defaultNameFormatter :: String -> String +defaultNameFormatter str = + case NonEmpty.nonEmpty str of + Nothing -> + error "Name cannot be empty" + Just nameChars -> + case checkIllegalNameChars nameChars of + Just badChars -> + error $ concat + [ "The name ", str, " contains illegal characters: ", NonEmpty.toList badChars + , "\nConsider setting a default name formatter that replaces these characters, or renaming the type." + ] + Nothing -> + str + -- | Convenience typeclass class you can use to "attach" a set of Aeson encoding options to a type. class HasJSONOptions a where getJSONOptions :: (Proxy a) -> A.Options + +data T = T +data T1 = T1 +data T2 = T2 +data T3 = T3 +data T4 = T4 +data T5 = T5 +data T6 = T6 +data T7 = T7 +data T8 = T8 +data T9 = T9 +data T10 = T10 + +instance TypeScript T where getTypeScriptType _ = "T"; isGenericVariable _ = True +instance TypeScript T1 where getTypeScriptType _ = "T1"; isGenericVariable _ = True +instance TypeScript T2 where getTypeScriptType _ = "T2"; isGenericVariable _ = True +instance TypeScript T3 where getTypeScriptType _ = "T3"; isGenericVariable _ = True +instance TypeScript T4 where getTypeScriptType _ = "T4"; isGenericVariable _ = True +instance TypeScript T5 where getTypeScriptType _ = "T5"; isGenericVariable _ = True +instance TypeScript T6 where getTypeScriptType _ = "T6"; isGenericVariable _ = True +instance TypeScript T7 where getTypeScriptType _ = "T7"; isGenericVariable _ = True +instance TypeScript T8 where getTypeScriptType _ = "T8"; isGenericVariable _ = True +instance TypeScript T9 where getTypeScriptType _ = "T9"; isGenericVariable _ = True +instance TypeScript T10 where getTypeScriptType _ = "T10"; isGenericVariable _ = True + +allStarConstructors :: [Type] +allStarConstructors = [ConT ''T1, ConT ''T2, ConT ''T3, ConT ''T4, ConT ''T5, ConT ''T6, ConT ''T7, ConT ''T8, ConT ''T9, ConT ''T10] + +allStarConstructors' :: [Name] +allStarConstructors' = [''T1, ''T2, ''T3, ''T4, ''T5, ''T6, ''T7, ''T8, ''T9, ''T10] + +allStarConstructors'' :: [String] +allStarConstructors'' = ["T1", "T2", "T3", "T4", "T5", "T6", "T7", "T8", "T9", "T10"] + +-- | Type variable gathering + +data ExtraTypeScriptOptions = ExtraTypeScriptOptions { + typeFamiliesToMapToTypeScript :: [Name] + + , keyType :: Maybe String + + -- | Function which is applied to all Haddocks we read in. + -- By default, just drops leading whitespace from each line. + , haddockModifier :: String -> String + } + +defaultExtraTypeScriptOptions :: ExtraTypeScriptOptions +defaultExtraTypeScriptOptions = ExtraTypeScriptOptions [] Nothing stripStartEachLine + where + stripStartEachLine :: String -> String + stripStartEachLine s = s + & T.pack + & T.splitOn "\n" + & fmap T.stripStart + & T.intercalate "\n" + & T.unpack + +data ExtraDeclOrGenericInfo = ExtraDecl Exp + | ExtraGeneric GenericInfo + | ExtraTopLevelDecs [Dec] + | ExtraConstraint Type + | ExtraParentType Type + deriving Show + +data GenericInfo = GenericInfo Name GenericInfoExtra + deriving Show + +data GenericInfoExtra = NormalStar + | TypeFamilyKey Name + deriving Show diff --git a/src/Data/Aeson/TypeScript/Util.hs b/src/Data/Aeson/TypeScript/Util.hs new file mode 100644 index 0000000..cedf0bf --- /dev/null +++ b/src/Data/Aeson/TypeScript/Util.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Aeson.TypeScript.Util where + +import Control.Monad +import Data.Aeson as A +import Data.Aeson.TypeScript.Instances () +import Data.Aeson.TypeScript.Types +import qualified Data.List as L +import Data.Proxy +import Data.String.Interpolate +import qualified Data.Text as T +import Language.Haskell.TH hiding (stringE) +import Language.Haskell.TH.Datatype +import qualified Language.Haskell.TH.Lib as TH + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + + +type Suffix = String +type Var = String + +getDataTypeVars :: DatatypeInfo -> [Type] +#if MIN_VERSION_th_abstraction(0,3,0) +getDataTypeVars (DatatypeInfo {datatypeInstTypes}) = datatypeInstTypes +#else +getDataTypeVars (DatatypeInfo {datatypeVars}) = datatypeVars +#endif + +coveredByDataTypeVars :: [Type] -> Type -> Bool +-- Don't include a type found in a constructor if it's already found as a datatype var +coveredByDataTypeVars dataTypeVars candidate | candidate `L.elem` dataTypeVars = True +-- Don't include a type found in a constructor if the version with a simple star kind signature is already present +coveredByDataTypeVars dataTypeVars candidate | (SigT candidate StarT) `L.elem` dataTypeVars = True +coveredByDataTypeVars _ _ = False + +setDataTypeVars :: DatatypeInfo -> [Type] -> DatatypeInfo +#if MIN_VERSION_th_abstraction(0,3,0) +setDataTypeVars dti@(DatatypeInfo {}) vars = dti { datatypeInstTypes = vars } +#else +setDataTypeVars dti@(DatatypeInfo {}) vars = dti { datatypeVars = vars } +#endif + +dropLeadingIFromInterfaceName :: TSDeclaration -> TSDeclaration +dropLeadingIFromInterfaceName decl@(TSInterfaceDeclaration {interfaceName=('I':xs)}) = decl { interfaceName = xs } +dropLeadingIFromInterfaceName decl@(TSTypeAlternatives {typeName=('I':xs)}) = decl { typeName = xs } +dropLeadingIFromInterfaceName x = x + +lastNameComponent :: String -> String +lastNameComponent x = T.unpack $ last $ T.splitOn "." (T.pack x) + +lastNameComponent' :: Name -> String +lastNameComponent' = lastNameComponent . show + +getTypeName :: Name -> String +getTypeName x = lastNameComponent $ show x + +allConstructorsAreNullary :: [ConstructorInfo] -> Bool +allConstructorsAreNullary constructors = and $ fmap isConstructorNullary constructors + +isConstructorNullary :: ConstructorInfo -> Bool +isConstructorNullary (ConstructorInfo {constructorVariant, constructorFields}) = (constructorVariant == NormalConstructor) && (constructorFields == []) + +-- In Template Haskell 2.10.0.0 and later, Pred is just a synonm for Type +-- In earlier versions, it has constructors +getDatatypePredicate :: Type -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +getDatatypePredicate = AppT (ConT ''TypeScript) +#else +getDatatypePredicate typ = ClassP ''TypeScript [typ] +#endif + +getTypeAsStringExp :: Type -> Q Exp +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 +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 +applyToArgsE :: Exp -> [Exp] -> Exp +applyToArgsE f [] = f +applyToArgsE f (x:xs) = applyToArgsE (AppE f x) xs + +-- Between Aeson 1.1.2.0 and 1.2.0.0, tagSingleConstructors was added +getTagSingleConstructors :: Options -> Bool +#if MIN_VERSION_aeson(1,2,0) +getTagSingleConstructors = tagSingleConstructors +#else +getTagSingleConstructors _ = False +#endif + +-- Between Template Haskell 2.10 and 2.11, the ability to look up which extensions are turned on was added +assertExtensionsTurnedOn :: DatatypeInfo -> Q () +#if MIN_VERSION_template_haskell(2,11,0) +assertExtensionsTurnedOn (DatatypeInfo {..}) = do + -- Check that necessary language extensions are turned on + scopedTypeVariablesEnabled <- isExtEnabled ScopedTypeVariables + kindSignaturesEnabled <- isExtEnabled KindSignatures + unless scopedTypeVariablesEnabled $ + error [i|The ScopedTypeVariables extension is required; please enable it before calling deriveTypeScript. (For example: put {-\# LANGUAGE ScopedTypeVariables \#-} at the top of the file.)|] + unless (kindSignaturesEnabled || (L.null datatypeVars)) $ + error [i|The KindSignatures extension is required since type #{datatypeName} is a higher order type; please enable it before calling deriveTypeScript. (For example: put {-\# LANGUAGE KindSignatures \#-} at the top of the file.)|] +#else +assertExtensionsTurnedOn _ = return () +#endif + +-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this +isObjectWithSingleField :: SumEncoding -> Bool +isObjectWithSingleField ObjectWithSingleField = True +isObjectWithSingleField _ = False + +-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this +isTwoElemArray :: SumEncoding -> Bool +isTwoElemArray TwoElemArray = True +isTwoElemArray _ = False + +-- Older versions of Aeson don't have an Eq instance for SumEncoding so we do this +-- UntaggedValue was added between Aeson 0.11.3.0 and 1.0.0.0 +isUntaggedValue :: SumEncoding -> Bool +#if MIN_VERSION_aeson(1,0,0) +isUntaggedValue UntaggedValue = True +#endif +isUntaggedValue _ = False + +-- Between Template Haskell 2.10 and 2.11, InstanceD got an additional argument +mkInstance :: Cxt -> Type -> [Dec] -> Dec +#if MIN_VERSION_template_haskell(2,11,0) +mkInstance = InstanceD Nothing +#else +mkInstance = InstanceD +#endif + +namesAndTypes :: Options -> [(Name, (Suffix, Var))] -> ConstructorInfo -> [(Name, String, Type)] +namesAndTypes options genericVariables ci = case constructorVariant ci of + RecordConstructor names -> zip3 names (fmap ((fieldLabelModifier options) . lastNameComponent') names) (constructorFields ci) + _ -> case sumEncoding options of + TaggedObject _ contentsFieldName + | isConstructorNullary ci -> [] + | otherwise -> [(mkName "", contentsFieldName, contentsTupleTypeSubstituted genericVariables ci)] + _ -> [(constructorName ci, constructorNameToUse options ci, contentsTupleTypeSubstituted genericVariables ci)] + +constructorNameToUse :: Options -> ConstructorInfo -> String +constructorNameToUse options ci = (constructorTagModifier options) $ lastNameComponent' (constructorName ci) + +-- | Get the type of a tuple of constructor fields, as when we're packing a record-less constructor into a list +contentsTupleType :: ConstructorInfo -> Type +contentsTupleType ci = let fields = constructorFields ci in + case fields of + [] -> AppT ListT (ConT ''()) + [x] -> x + xs-> applyToArgsT (ConT $ tupleTypeName (L.length xs)) fields + +contentsTupleTypeSubstituted :: [(Name, (Suffix, Var))] -> ConstructorInfo -> Type +contentsTupleTypeSubstituted genericVariables ci = let fields = constructorFields ci in + case fields of + [] -> AppT ListT (ConT ''()) + [x] -> mapType genericVariables x + xs -> applyToArgsT (ConT $ tupleTypeName (L.length xs)) (fmap (mapType genericVariables) xs) + +mapType :: [(Name, (Suffix, Var))] -> Type -> Type +mapType g x@(VarT name) = tryPromote x g name +mapType g x@(ConT name) = tryPromote x g name +mapType g x@(PromotedT name) = tryPromote x g name +mapType g (AppT typ1 typ2) = AppT (mapType g typ1) (mapType g typ2) +mapType g (SigT typ x) = SigT (mapType g typ) x +mapType g (InfixT typ1 x typ2) = InfixT (mapType g typ1) x (mapType g typ2) +mapType g (UInfixT typ1 x typ2) = UInfixT (mapType g typ1) x (mapType g typ2) +mapType g (ParensT typ) = ParensT (mapType g typ) +#if MIN_VERSION_template_haskell(2,15,0) +mapType g (AppKindT typ x) = AppKindT (mapType g typ) x +mapType g (ImplicitParamT x typ) = ImplicitParamT x (mapType g typ) +#endif +mapType _ x = x + +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 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T2")) = ConT ''T2 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T3")) = ConT ''T3 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T4")) = ConT ''T4 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T5")) = ConT ''T5 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T6")) = ConT ''T6 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T7")) = ConT ''T7 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T8")) = ConT ''T8 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T9")) = ConT ''T9 +tryPromote _ genericVariables (flip L.lookup genericVariables -> Just (_, "T10")) = ConT ''T10 +tryPromote x _ _ = x + +getBracketsExpression :: Bool -> [(Name, (Suffix, Var))] -> Q Exp +getBracketsExpression _ [] = [|""|] +getBracketsExpression includeSuffix names = + [|let vars = $(genericVariablesListExpr includeSuffix names) in "<" <> L.intercalate ", " vars <> ">"|] + +getBracketsExpressionAllTypesNoSuffix :: [(Name, (Suffix, Var))] -> Q Exp +getBracketsExpressionAllTypesNoSuffix [] = [|""|] +getBracketsExpressionAllTypesNoSuffix names = [|"<" <> L.intercalate ", " $(listE [ [|(getTypeScriptType (Proxy :: Proxy $(varT x)))|] | (x, (_suffix, _)) <- names]) <> ">"|] + +genericVariablesListExpr :: Bool -> [(Name, (Suffix, Var))] -> Q Exp +genericVariablesListExpr includeSuffix genericVariables = listE (fmap (\((_, (suffix, _)), correspondingGeneric) -> + [|(getTypeScriptType (Proxy :: Proxy $(return correspondingGeneric))) <> $(TH.stringE (if includeSuffix then suffix else ""))|]) + (case genericVariables of + [x] -> [(x, ConT ''T)] + xs -> zip xs allStarConstructors) + ) + +isStarType :: Type -> Maybe Name +isStarType (SigT (VarT n) StarT) = Just n +isStarType _ = Nothing + +nothingOnFail :: Q a -> Q (Maybe a) +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 + x -> return x +#else + let maybeDoc = Nothing +#endif + + case maybeDoc of + Just (Just doc) -> [|Just $(TH.stringE doc)|] + _ -> [|Nothing|] diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml new file mode 100644 index 0000000..2b383ea --- /dev/null +++ b/stack-8.10.7.yaml @@ -0,0 +1,5 @@ + +resolver: lts-18.28 + +packages: +- . diff --git a/stack-8.10.7.yaml.lock b/stack-8.10.7.yaml.lock new file mode 100644 index 0000000..da10c3e --- /dev/null +++ b/stack-8.10.7.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 + size: 590100 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml + original: lts-18.28 diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml new file mode 100644 index 0000000..fe2c91a --- /dev/null +++ b/stack-9.0.2.yaml @@ -0,0 +1,5 @@ + +resolver: lts-19.33 + +packages: +- . diff --git a/stack-9.0.2.yaml.lock b/stack-9.0.2.yaml.lock new file mode 100644 index 0000000..d79c369 --- /dev/null +++ b/stack-9.0.2.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4 + size: 619204 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml + original: lts-19.33 diff --git a/stack-9.2.8.yaml b/stack-9.2.8.yaml new file mode 100644 index 0000000..028d2f7 --- /dev/null +++ b/stack-9.2.8.yaml @@ -0,0 +1,5 @@ + +resolver: lts-20.26 + +packages: +- . diff --git a/stack-9.2.8.yaml.lock b/stack-9.2.8.yaml.lock new file mode 100644 index 0000000..ea5a850 --- /dev/null +++ b/stack-9.2.8.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 + size: 650475 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml + original: lts-20.26 diff --git a/stack-9.4.7.yaml b/stack-9.4.7.yaml new file mode 100644 index 0000000..13994e4 --- /dev/null +++ b/stack-9.4.7.yaml @@ -0,0 +1,5 @@ + +resolver: lts-21.20 + +packages: +- . diff --git a/stack-9.4.7.yaml.lock b/stack-9.4.7.yaml.lock new file mode 100644 index 0000000..1b8f599 --- /dev/null +++ b/stack-9.4.7.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 5921ddc75f5dd3f197fbc32e1e5676895a8e7b971d4f82ef6b556657801dd18a + size: 640054 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/20.yaml + original: lts-21.20 diff --git a/stack.yaml b/stack.yaml index 51dd2aa..8e34e8c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,5 @@ -resolver: lts-17.7 +resolver: lts-22.7 packages: - . diff --git a/stack.yaml.lock b/stack.yaml.lock index d4d1cc5..5fe18da 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 565715 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/7.yaml - sha256: 1b5e4124989399e60e7a7901f0cefd910beea546131fb07a13a7208c4cc8b7ee - original: lts-17.7 + sha256: 7b975b104cb3dbf0c297dfd01f936a4d2ee523241dd0b1ae960522b833fe3027 + size: 714096 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/7.yaml + original: lts-22.7 diff --git a/test/Basic.hs b/test/Basic.hs new file mode 100644 index 0000000..18c226d --- /dev/null +++ b/test/Basic.hs @@ -0,0 +1,36 @@ + +module Basic (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 Unit1 = Unit1 +$(deriveTypeScript A.defaultOptions ''Unit1) + +data Unit2 = Unit2 +$(deriveTypeScript (A.defaultOptions { A.tagSingleConstructors = True + , A.constructorTagModifier = const "foo" }) ''Unit2) + +tests :: SpecWith () +tests = describe "Basic tests" $ do + describe "tagSingleConstructors and constructorTagModifier" $ do + it [i|Works with a normal unit|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy Unit1)) `shouldBe` ([ + TSTypeAlternatives "Unit1" [] ["IUnit1"] Nothing + , TSTypeAlternatives "IUnit1" [] ["void[]"] Nothing + ]) + + it [i|Works with a unit with constructorTagModifier|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy Unit2)) `shouldBe` ([ + TSTypeAlternatives "Unit2" [] ["\"foo\""] Nothing + ]) + + +main :: IO () +main = hspec tests diff --git a/test/ClosedTypeFamilies.hs b/test/ClosedTypeFamilies.hs new file mode 100644 index 0000000..0e75647 --- /dev/null +++ b/test/ClosedTypeFamilies.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ClosedTypeFamilies (tests) where + +import Data.Aeson as A +import Data.Aeson.TypeScript.Recursive +import Data.Aeson.TypeScript.TH +import Data.Aeson.TypeScript.Types +import Data.Functor.Identity +import Data.Proxy +import Data.String.Interpolate +import qualified Data.Text as T +import Prelude hiding (Double) +import Test.Hspec +import TestBoilerplate + + +type family DeployEnvironment env = result | result -> env where + DeployEnvironment SingleNodeEnvironment = SingleDE + DeployEnvironment K8SEnvironment = K8SDE + DeployEnvironment T = () +data UserT env f = User { + _userUsername :: Columnar f T.Text + , _userCreatedAt :: Columnar f Int + , _userDeployEnvironment :: Columnar f (DeployEnvironment env) + } +$(deriveTypeScript' A.defaultOptions ''UserT (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''DeployEnvironment] })) + +type family DeployEnvironment2 env = result | result -> env where + DeployEnvironment2 SingleNodeEnvironment = SingleDE + DeployEnvironment2 K8SEnvironment = K8SDE + DeployEnvironment2 T = () +newtype Simple env = Simple (DeployEnvironment2 env) +$(deriveTypeScript' A.defaultOptions ''Simple (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''DeployEnvironment2] })) + +tests :: SpecWith () +tests = describe "Closed type families" $ do + describe "simple newtype" $ do + it [i|makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Simple T))) `shouldBe` ([ + TSInterfaceDeclaration "DeployEnvironment2" [] [ + TSField False "\"k8s_env\"" "\"k8s\"" Nothing + , TSField False "\"single_node_env\"" "\"single\"" Nothing + , TSField False "T" "void" Nothing + ] Nothing + , TSTypeAlternatives "ISimple" ["T extends keyof DeployEnvironment2"] ["DeployEnvironment2[T]"] Nothing + , TSTypeAlternatives "Simple" ["T extends keyof DeployEnvironment2"] ["ISimple"] Nothing + ]) + + describe "Complicated Beam-like user type" $ do + it [i|makes the declaration and types correctly|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([ + TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser"] Nothing + , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [ + TSField False "_userUsername" "string" Nothing + , TSField False "_userCreatedAt" "number" Nothing + , TSField False "_userDeployEnvironment" "DeployEnvironment[T]" Nothing + ] Nothing + ]) + + it [i|get the declarations recursively|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([ + TSInterfaceDeclaration "DeployEnvironment" [] [ + TSField False "\"k8s_env\"" "\"k8s\"" Nothing + , TSField False "\"single_node_env\"" "\"single\"" Nothing + , TSField False "T" "void" Nothing + ] Nothing + , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [ + TSField False "_userUsername" "string" Nothing + , TSField False "_userCreatedAt" "number" Nothing + , TSField False "_userDeployEnvironment" "DeployEnvironment[T]" Nothing + ] Nothing + , TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser"] Nothing + ]) + +main :: IO () +main = hspec tests diff --git a/test/Formatting.hs b/test/Formatting.hs new file mode 100644 index 0000000..a86f948 --- /dev/null +++ b/test/Formatting.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +module Formatting (tests) where + +import Control.Exception +import Data.Aeson (SumEncoding(UntaggedValue), defaultOptions, sumEncoding, tagSingleConstructors) +import Data.Aeson.TypeScript.TH +import Data.Proxy +import Data.String.Interpolate +import Test.Hspec + + +data D = S | F deriving (Eq, Show) +$(deriveTypeScript defaultOptions ''D) + +data D2 = S2 | F2 deriving (Eq, Show) +$(deriveTypeScript defaultOptions ''D2) + +-- A.encode U --> "[]" +data Unit = U deriving (Eq, Show) +$(deriveTypeScript defaultOptions ''Unit) + +-- A.encode UTagSingle --> "\"UTagSingle\"" +data UnitTagSingle = UTagSingle deriving (Eq, Show) +$(deriveTypeScript (defaultOptions { tagSingleConstructors = True, sumEncoding = UntaggedValue }) ''UnitTagSingle) + +data PrimeInType' = PrimeInType +$(deriveTypeScript defaultOptions ''PrimeInType') + +data PrimeInConstr = PrimeInConstr' +$(deriveTypeScript defaultOptions ''PrimeInConstr) + +data FooBar = + Foo { + -- | @no-emit-typescript + recordString :: String + , recordInt :: Int + } + | + -- | @no-emit-typescript + Bar { + barInt :: Int + } +$(deriveTypeScript defaultOptions ''FooBar) + +data NormalConstructors = + -- | @no-emit-typescript + Con1 String + | Con2 Int +$(deriveTypeScript defaultOptions ''NormalConstructors) + +tests :: Spec +tests = describe "Formatting" $ do + describe "when given a Sum Type" $ do + describe "and the TypeAlias format option is set" $ + it "should generate a TS string literal type" $ + formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @D Proxy) `shouldBe` + [i|type D = "S" | "F";|] + + describe "and the Enum format option is set" $ do + it "should generate a TS Enum" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = Enum }) (getTypeScriptDeclarations @D Proxy) `shouldBe` + [i|enum D { S="S", F="F" }|] + + it "should generate a TS Enum with multiple" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = Enum }) (getTypeScriptDeclarations @D Proxy <> getTypeScriptDeclarations @D2 Proxy) `shouldBe` + [__i|enum D { S="S", F="F" } + + enum D2 { S2="S2", F2="F2" }|] + + it "should generate a normal type from Unit, singe tagSingleConstructors=False by default" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = Enum }) (getTypeScriptDeclarations @Unit Proxy) `shouldBe` + [__i|type Unit = IU; + + type IU = void[];|] + + it "should generate a suitable enum from UnitTagSingle" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = Enum }) (getTypeScriptDeclarations @UnitTagSingle Proxy) `shouldBe` + [__i|enum UnitTagSingle { UTagSingle="UTagSingle" }|] + + describe "and the EnumWithType format option is set" $ do + it "should generate a TS Enum with a type declaration" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = EnumWithType }) (getTypeScriptDeclarations @D Proxy) `shouldBe` + [i|enum DEnum { S="S", F="F" }\n\ntype D = keyof typeof DEnum;|] + + it "should also work for UnitTagSingle" $ + formatTSDeclarations' (defaultFormattingOptions { typeAlternativesFormat = EnumWithType }) (getTypeScriptDeclarations @UnitTagSingle Proxy) `shouldBe` + [i|enum UnitTagSingleEnum { UTagSingle="UTagSingle" }\n\ntype UnitTagSingle = keyof typeof UnitTagSingleEnum;|] + + describe "when the name has an apostrophe" $ do + describe "in the type" $ do + it "throws an error" $ do + evaluate (formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @PrimeInType' Proxy)) `shouldThrow` anyErrorCall + + describe "in the constructor" $ do + it "throws an error" $ do + evaluate (formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @PrimeInConstr Proxy)) `shouldThrow` anyErrorCall + +#if MIN_VERSION_template_haskell(2,18,0) + describe "when @no-emit-typescript is present" $ do + it [i|works on records and constructors of record types|] $ do + formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @FooBar Proxy) `shouldBe` [i|type FooBar = IFoo;\n\ninterface IFoo {\n tag: "Foo";\n recordInt: number;\n}|] + + it [i|works on normal constructors|] $ do + formatTSDeclarations' defaultFormattingOptions (getTypeScriptDeclarations @NormalConstructors Proxy) `shouldBe` [i|type NormalConstructors = ICon2;\n\ninterface ICon2 {\n tag: "Con2";\n contents: number;\n}|] +#endif + +main :: IO () +main = hspec tests diff --git a/test/Generic.hs b/test/Generic.hs new file mode 100644 index 0000000..68f92fb --- /dev/null +++ b/test/Generic.hs @@ -0,0 +1,61 @@ + +module Generic (tests) where + +import Data.Aeson as A +import Data.Aeson.TypeScript.Recursive +import Data.Aeson.TypeScript.TH +import Data.Aeson.TypeScript.Types +import Data.Map +import Data.Proxy +import Data.String.Interpolate +import Data.Text +import Prelude hiding (Double) +import Test.Hspec + + +data Complex a = Product Int a | Unary Int +$(deriveTypeScript defaultOptions ''Complex) + +data Complex2 a = Product2 Int a +$(deriveTypeScript (defaultOptions { sumEncoding = UntaggedValue }) ''Complex2) + +data Complex3 k = Product3 { record3 :: [k] } +$(deriveTypeScript defaultOptions ''Complex3) + +data Complex4 k = Product4 { record4 :: Map Text k } +$(deriveTypeScript defaultOptions ''Complex4) + +tests :: SpecWith () +tests = describe "Generic instances" $ do + it [i|Complex makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Complex String))) `shouldBe` [ + TSInterfaceDeclaration "IProduct" ["T"] [TSField False "tag" "\"Product\"" Nothing, TSField False "contents" "[number, T]" Nothing] Nothing + ,TSInterfaceDeclaration "IUnary" ["T"] [TSField False "tag" "\"Unary\"" Nothing, TSField False "contents" "number" Nothing] Nothing + ,TSTypeAlternatives "Complex" ["T"] ["IProduct","IUnary"] Nothing + ] + + it [i|Complex2 makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Complex2 String))) `shouldBe` [ + TSTypeAlternatives "Complex2" ["T"] ["IProduct2"] Nothing + ,TSTypeAlternatives "IProduct2" ["T"] ["[number, T]"] Nothing + ] + + it [i|Complex3 makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Complex3 String))) `shouldBe` [ + TSInterfaceDeclaration "IProduct3" ["T"] [TSField False "record3" "T[]" Nothing] Nothing + ,TSTypeAlternatives "Complex3" ["T"] ["IProduct3"] Nothing + ] + + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Complex3 Int))) `shouldBe` [ + TSInterfaceDeclaration "IProduct3" ["T"] [TSField False "record3" "T[]" Nothing] Nothing + ,TSTypeAlternatives "Complex3" ["T"] ["IProduct3"] Nothing + ] + + it [i|Complex4 makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Complex4 String))) `shouldBe` [ + TSInterfaceDeclaration "IProduct4" ["T"] [TSField False "record4" "{[k in string]?: T}" Nothing] Nothing + ,TSTypeAlternatives "Complex4" ["T"] ["IProduct4"] Nothing + ] + +main :: IO () +main = hspec tests diff --git a/test/GetDoc.hs b/test/GetDoc.hs new file mode 100644 index 0000000..73f25b7 --- /dev/null +++ b/test/GetDoc.hs @@ -0,0 +1,33 @@ + +module GetDoc (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 + + +-- | OneField type doc +data OneField = + -- | OneField constructor doc + OneField { + -- | This is a simple string + simpleString :: String + } +$(deriveTypeScript A.defaultOptions ''OneField) + +tests :: SpecWith () +tests = describe "getDoc tests" $ do + it [i|Works with a simple record type|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy OneField)) `shouldBe` ([ + TSTypeAlternatives "OneField" [] ["IOneField"] (Just "OneField type doc") + , TSInterfaceDeclaration "IOneField" [] [ + TSField False "simpleString" "string" (Just "This is a simple string") + ] (Just "OneField constructor doc") + ]) + +main :: IO () +main = hspec tests diff --git a/test/HigherKind.hs b/test/HigherKind.hs index f913b06..3587785 100644 --- a/test/HigherKind.hs +++ b/test/HigherKind.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} module HigherKind (tests) where @@ -8,7 +7,7 @@ import Data.Aeson.TypeScript.TH import Data.Aeson.TypeScript.Types import Data.Monoid import Data.Proxy -import Data.String.Interpolate.IsString +import Data.String.Interpolate import Prelude hiding (Double) import Test.Hspec import Util @@ -32,12 +31,13 @@ $(deriveTypeScript A.defaultOptions ''HigherKindWithUnary) $(deriveJSON A.defaultOptions ''HigherKindWithUnary) +tests :: SpecWith () tests = describe "Higher kinds" $ do describe "Kind * -> *" $ do it [i|makes the declaration and types correctly|] $ do - (getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) `shouldBe` ([ - TSTypeAlternatives "HigherKind" ["T"] ["IHigherKind"], - TSInterfaceDeclaration "IHigherKind" ["T"] [TSField False "higherKindList" "T[]"] + (getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) `shouldBe` ([ + TSTypeAlternatives "HigherKind" ["T"] ["IHigherKind"] Nothing, + TSInterfaceDeclaration "IHigherKind" ["T"] [TSField False "higherKindList" "T[]" Nothing] Nothing ]) (getTypeScriptType (Proxy :: Proxy (HigherKind Int))) `shouldBe` "HigherKind" @@ -45,22 +45,23 @@ tests = describe "Higher kinds" $ do it [i|works when referenced in another type|] $ do (getTypeScriptDeclarations (Proxy :: Proxy Foo)) `shouldBe` ([ - TSInterfaceDeclaration "Foo" [] [TSField False "fooString" "string" - , TSField False "fooHigherKindReference" "HigherKind"] + TSTypeAlternatives "Foo" [] ["IFoo"] Nothing, + TSInterfaceDeclaration "IFoo" [] [TSField False "fooString" "string" Nothing + , TSField False "fooHigherKindReference" "HigherKind" Nothing] Nothing ]) it [i|works with an interface inside|] $ do - (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary)) `shouldBe` ([ - TSTypeAlternatives "HigherKindWithUnary" ["T"] ["IUnary"], - TSTypeAlternatives "IUnary" ["T"] ["number"] + (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T))) `shouldBe` ([ + TSTypeAlternatives "HigherKindWithUnary" ["T"] ["IUnary"] Nothing, + TSTypeAlternatives "IUnary" ["T"] ["number"] Nothing ]) describe "Kind * -> * -> *" $ do it [i|makes the declaration and type correctly|] $ do - (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) `shouldBe` ([ - TSTypeAlternatives "DoubleHigherKind" ["T1","T2"] ["IDoubleHigherKind"], - TSInterfaceDeclaration "IDoubleHigherKind" ["T1","T2"] [TSField False "someList" "T2[]" - , TSField False "higherKindThing" "HigherKind"] + (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) `shouldBe` ([ + TSTypeAlternatives "DoubleHigherKind" ["T1","T2"] ["IDoubleHigherKind"] Nothing, + TSInterfaceDeclaration "IDoubleHigherKind" ["T1","T2"] [TSField False "someList" "T2[]" Nothing + , TSField False "higherKindThing" "HigherKind" Nothing] Nothing ]) (getTypeScriptType (Proxy :: Proxy (DoubleHigherKind Int String))) `shouldBe` "DoubleHigherKind" @@ -68,9 +69,9 @@ tests = describe "Higher kinds" $ do describe "TSC compiler checks" $ do it "type checks everything with tsc" $ do - let declarations = ((getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) <> - (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) <> - (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary)) + let declarations = ((getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) <> + (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) <> + (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T))) ) let typesAndValues = [(getTypeScriptType (Proxy :: Proxy (HigherKind Int)) , A.encode (HigherKind [42 :: Int])) @@ -85,11 +86,12 @@ tests = describe "Higher kinds" $ do testTypeCheckDeclarations declarations typesAndValues +main :: IO () main = hspec tests - +main' :: IO () main' = putStrLn $ formatTSDeclarations ( - (getTypeScriptDeclarations (Proxy :: Proxy HigherKind)) <> - (getTypeScriptDeclarations (Proxy :: Proxy DoubleHigherKind)) <> - (getTypeScriptDeclarations (Proxy :: Proxy HigherKindWithUnary)) + (getTypeScriptDeclarations (Proxy :: Proxy (HigherKind T))) <> + (getTypeScriptDeclarations (Proxy :: Proxy (DoubleHigherKind T1 T2))) <> + (getTypeScriptDeclarations (Proxy :: Proxy (HigherKindWithUnary T))) ) diff --git a/test/LegalNameSpec.hs b/test/LegalNameSpec.hs new file mode 100644 index 0000000..638f314 --- /dev/null +++ b/test/LegalNameSpec.hs @@ -0,0 +1,24 @@ + +module LegalNameSpec where + +import Data.Aeson.TypeScript.LegalName +import Data.List.NonEmpty (NonEmpty (..)) +import Test.Hspec + +tests :: Spec +tests = describe "Data.Aeson.TypeScript.LegalName" $ do + describe "checkIllegalNameChars" $ do + describe "legal Haskell names" $ do + it "allows an uppercase letter" $ do + checkIllegalNameChars ('A' :| []) + `shouldBe` Nothing + it "allows an underscore" $ do + checkIllegalNameChars ('_' :| "asdf") + `shouldBe` Nothing + it "reports that ' is illegal" $ do + checkIllegalNameChars ('F' :| "oo'") + `shouldBe` Just ('\'' :| []) + describe "illegal Haskell names" $ do + it "allows a $" $ do + checkIllegalNameChars ('$' :| "asdf") + `shouldBe` Nothing diff --git a/test/NoOmitNothingFields.hs b/test/NoOmitNothingFields.hs index 2a3f2c6..148e822 100644 --- a/test/NoOmitNothingFields.hs +++ b/test/NoOmitNothingFields.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module NoOmitNothingFields (tests) where +module NoOmitNothingFields (allTests) where import Data.Aeson as A import Data.Aeson.TypeScript.TH @@ -9,20 +8,14 @@ import Data.Proxy import Test.Hspec import TestBoilerplate -$(testDeclarations "NoOmitNothingFields" (A.defaultOptions {omitNothingFields=False})) +$(testDeclarations "NoOmitNothingFields" (A.defaultOptions {omitNothingFields = False})) -main = hspec $ describe "NoOmitNothingFields" $ do +allTests :: SpecWith () +allTests = describe "NoOmitNothingFields" $ do it "encodes as expected" $ do let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional) - decls `shouldBe` [TSInterfaceDeclaration { - interfaceName = "Optional" - , interfaceGenericVariables = [] - , interfaceMembers = [ - TSField {fieldOptional = False - , fieldName = "optionalInt" - , fieldType = "number | null"} - ] - }] + decls `shouldBe` [TSTypeAlternatives "Optional" [] ["IOptional"] Nothing + , TSInterfaceDeclaration "IOptional" [] [TSField False "optionalInt" "number | null" Nothing] Nothing] tests diff --git a/test/ObjectWithSingleFieldNoTagSingleConstructors.hs b/test/ObjectWithSingleFieldNoTagSingleConstructors.hs index 531cb00..c075759 100644 --- a/test/ObjectWithSingleFieldNoTagSingleConstructors.hs +++ b/test/ObjectWithSingleFieldNoTagSingleConstructors.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module ObjectWithSingleFieldNoTagSingleConstructors (tests) where +module ObjectWithSingleFieldNoTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate -import Util $(testDeclarations "ObjectWithSingleField with tagSingleConstructors=False" (A.defaultOptions {sumEncoding=ObjectWithSingleField})) +main :: IO () main = hspec tests diff --git a/test/ObjectWithSingleFieldTagSingleConstructors.hs b/test/ObjectWithSingleFieldTagSingleConstructors.hs index ad5f4e6..42807f0 100644 --- a/test/ObjectWithSingleFieldTagSingleConstructors.hs +++ b/test/ObjectWithSingleFieldTagSingleConstructors.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module ObjectWithSingleFieldTagSingleConstructors (tests) where +module ObjectWithSingleFieldTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util $(testDeclarations "ObjectWithSingleField with tagSingleConstructors=True" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=ObjectWithSingleField})) +main :: IO () main = hspec tests diff --git a/test/OmitNothingFields.hs b/test/OmitNothingFields.hs deleted file mode 100644 index 5a0de8c..0000000 --- a/test/OmitNothingFields.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} - -module OmitNothingFields (tests) where - -import Data.Aeson as A -import Data.Aeson.TypeScript.TH -import Data.Aeson.TypeScript.Types -import Data.Proxy -import Test.Hspec -import TestBoilerplate - -$(testDeclarations "OmitNothingFields" (A.defaultOptions {omitNothingFields=True})) - -main = hspec $ describe "OmitNothingFields" $ do - it "encodes as expected" $ do - let decls = getTypeScriptDeclarations (Proxy :: Proxy Optional) - - decls `shouldBe` [TSInterfaceDeclaration { - interfaceName = "Optional" - , interfaceGenericVariables = [] - , interfaceMembers = [ - TSField {fieldOptional = True - , fieldName = "optionalInt" - , fieldType = "number"} - ] - }] - - tests diff --git a/test/OpenTypeFamilies.hs b/test/OpenTypeFamilies.hs new file mode 100644 index 0000000..52a148e --- /dev/null +++ b/test/OpenTypeFamilies.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +module OpenTypeFamilies (tests) where + +import Data.Aeson as A +import Data.Aeson.TypeScript.Recursive +import Data.Aeson.TypeScript.TH +import Data.Aeson.TypeScript.Types +import Data.Functor.Identity +import Data.Proxy +import Data.String.Interpolate +import qualified Data.Text as T +import Prelude hiding (Double) +import Test.Hspec +import TestBoilerplate + + +type family DeployEnvironment env = result | result -> env +type instance DeployEnvironment SingleNodeEnvironment = SingleDE +type instance DeployEnvironment K8SEnvironment = K8SDE +type instance DeployEnvironment T = () +data UserT env f = User { + _userUsername :: Columnar f T.Text + , _userCreatedAt :: Columnar f Int + , _userDeployEnvironment :: Columnar f (DeployEnvironment env) + } +$(deriveTypeScript' A.defaultOptions ''UserT (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''DeployEnvironment] })) + +type family DeployEnvironment2 env = result | result -> env +type instance DeployEnvironment2 SingleNodeEnvironment = SingleDE +type instance DeployEnvironment2 K8SEnvironment = K8SDE +type instance DeployEnvironment2 T = () +newtype Simple env = Simple (DeployEnvironment2 env) +$(deriveTypeScript' A.defaultOptions ''Simple (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''DeployEnvironment2] })) + +tests :: SpecWith () +tests = describe "Open type families" $ do + describe "simple newtype" $ do + it [i|makes the declaration and types correctly|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Simple T))) `shouldBe` ([ + TSInterfaceDeclaration "DeployEnvironment2" [] [ + TSField False "\"single_node_env\"" "\"single\"" Nothing + , TSField False "\"k8s_env\"" "\"k8s\"" Nothing + , TSField False "T" "void" Nothing + ] Nothing + , TSTypeAlternatives "ISimple" ["T extends keyof DeployEnvironment2"] ["DeployEnvironment2[T]"] Nothing + , TSTypeAlternatives "Simple" ["T extends keyof DeployEnvironment2"] ["ISimple"] Nothing + ]) + + describe "Complicated Beam-like user type" $ do + it [i|makes the declaration and types correctly|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([ + TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser"] Nothing + , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [ + TSField False "_userUsername" "string" Nothing + , TSField False "_userCreatedAt" "number" Nothing + , TSField False "_userDeployEnvironment" "DeployEnvironment[T]" Nothing + ] Nothing + ]) + + it [i|get the declarations recursively|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (UserT T Identity))) `shouldBe` ([ + TSInterfaceDeclaration "DeployEnvironment" [] [ + TSField False "\"single_node_env\"" "\"single\"" Nothing + , TSField False "\"k8s_env\"" "\"k8s\"" Nothing + , TSField False "T" "void" Nothing + ] Nothing + , TSInterfaceDeclaration "IUser" ["T extends keyof DeployEnvironment"] [ + TSField False "_userUsername" "string" Nothing + , TSField False "_userCreatedAt" "number" Nothing + , TSField False "_userDeployEnvironment" "DeployEnvironment[T]" Nothing + ] Nothing + , TSTypeAlternatives "UserT" ["T extends keyof DeployEnvironment"] ["IUser"] Nothing + ]) + +main :: IO () +main = hspec tests diff --git a/test/Spec.hs b/test/Spec.hs index 4ffa194..a8c1a70 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE CPP #-} 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 LegalNameSpec +import qualified NoOmitNothingFields import qualified ObjectWithSingleFieldNoTagSingleConstructors import qualified ObjectWithSingleFieldTagSingleConstructors import qualified TaggedObjectNoTagSingleConstructors @@ -12,18 +21,26 @@ import qualified TwoElemArrayNoTagSingleConstructors import qualified TwoElemArrayTagSingleConstructors import qualified UntaggedNoTagSingleConstructors import qualified UntaggedTagSingleConstructors -import qualified OmitNothingFields -import qualified NoOmitNothingFields +import qualified UnwrapUnaryRecords -main = hspec $ do - ObjectWithSingleFieldTagSingleConstructors.tests - ObjectWithSingleFieldNoTagSingleConstructors.tests - TaggedObjectTagSingleConstructors.tests - TaggedObjectNoTagSingleConstructors.tests - TwoElemArrayTagSingleConstructors.tests - TwoElemArrayNoTagSingleConstructors.tests - UntaggedTagSingleConstructors.tests - UntaggedNoTagSingleConstructors.tests - HigherKind.tests - OmitNothingFields.tests - NoOmitNothingFields.tests +main :: IO () +main = hspec $ parallel $ do + Basic.tests + ClosedTypeFamilies.tests + Formatting.tests + Generic.tests + HigherKind.tests + LegalNameSpec.tests + NoOmitNothingFields.allTests + ObjectWithSingleFieldNoTagSingleConstructors.tests + ObjectWithSingleFieldTagSingleConstructors.tests + TaggedObjectNoTagSingleConstructors.tests + TaggedObjectTagSingleConstructors.tests + TwoElemArrayNoTagSingleConstructors.tests + TwoElemArrayTagSingleConstructors.tests + UntaggedNoTagSingleConstructors.tests + UntaggedTagSingleConstructors.tests + UnwrapUnaryRecords.allTests +#if MIN_VERSION_template_haskell(2,18,0) + GetDoc.tests +#endif diff --git a/test/TaggedObjectNoTagSingleConstructors.hs b/test/TaggedObjectNoTagSingleConstructors.hs index 28684f0..91266e5 100644 --- a/test/TaggedObjectNoTagSingleConstructors.hs +++ b/test/TaggedObjectNoTagSingleConstructors.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module TaggedObjectNoTagSingleConstructors (tests) where +module TaggedObjectNoTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate -import Util $(testDeclarations "TaggedObject with tagSingleConstructors=False" A.defaultOptions) +main :: IO () main = hspec tests diff --git a/test/TaggedObjectTagSingleConstructors.hs b/test/TaggedObjectTagSingleConstructors.hs index 3d927cb..b5dba98 100644 --- a/test/TaggedObjectTagSingleConstructors.hs +++ b/test/TaggedObjectTagSingleConstructors.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module TaggedObjectTagSingleConstructors (tests) where +module TaggedObjectTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util $(testDeclarations "TaggedObject with tagSingleConstructors=True" (setTagSingleConstructors A.defaultOptions)) +main :: IO () main = hspec tests diff --git a/test/TestBoilerplate.hs b/test/TestBoilerplate.hs index e172d55..3b45997 100644 --- a/test/TestBoilerplate.hs +++ b/test/TestBoilerplate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} module TestBoilerplate where @@ -6,10 +6,20 @@ import Control.Monad.Writer.Lazy hiding (Product) import qualified Data.Aeson as A import Data.Aeson.TH as A import Data.Aeson.TypeScript.TH +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Identity +import Data.Functor.Product +import Data.Kind +import Data.List.NonEmpty import Data.Proxy -import Language.Haskell.TH +import Data.String.Interpolate +import Data.Word +import Language.Haskell.TH hiding (Type) +import Numeric.Natural (Natural) import Test.Hspec import Util +import Util.Aeson data Unit = Unit data OneFieldRecordless = OneFieldRecordless Int @@ -20,7 +30,51 @@ 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 AesonTypes = AesonTypes { aesonValue :: A.Value, aesonObject :: A.Object } +data Numbers = Numbers { + natural :: Natural + , word :: Word + , word16 :: Word16 + , word32 :: Word32 + , word64 :: Word64 + } +data FancyFunctors = FancyFunctors { + nonEmpty :: NonEmpty Int + , const :: Const Int Int + , product :: Product Identity Identity Int + , compose :: Compose Identity Identity Int + } +-- * Values + +fancyFunctorsValue :: FancyFunctors +fancyFunctorsValue = FancyFunctors (42 :| []) (Const 42) (Pair 42 42) (Compose 42) + +-- * For testing type families + +instance TypeScript Identity where getTypeScriptType _ = "any" + +data SingleDE = SingleDE +instance TypeScript SingleDE where getTypeScriptType _ = [i|"single"|] + +data K8SDE = K8SDE +instance TypeScript K8SDE where getTypeScriptType _ = [i|"k8s"|] + +data SingleNodeEnvironment = SingleNodeEnvironment deriving (Eq, Show) +instance TypeScript SingleNodeEnvironment where getTypeScriptType _ = [i|"single_node_env"|] + +data K8SEnvironment = K8SEnvironment deriving (Eq, Show) +instance TypeScript K8SEnvironment where getTypeScriptType _ = [i|"k8s_env"|] + +data Nullable (c :: Type -> Type) x +data Exposed x +type family Columnar (f :: Type -> Type) x where + Columnar Exposed x = Exposed x + Columnar Identity x = x + Columnar (Nullable c) x = Columnar c (Maybe x) + Columnar f x = f x + +-- * Declarations testDeclarations :: String -> A.Options -> Q [Dec] testDeclarations testName aesonOptions = do @@ -34,6 +88,9 @@ testDeclarations testName aesonOptions = do deriveInstances ''TwoConstructor deriveInstances ''Complex deriveInstances ''Optional + deriveInstances ''AesonTypes + deriveInstances ''Numbers + deriveInstances ''FancyFunctors typesAndValues :: Exp <- [e|[(getTypeScriptType (Proxy :: Proxy Unit), A.encode Unit) @@ -55,9 +112,18 @@ testDeclarations testName aesonOptions = do , (getTypeScriptType (Proxy :: Proxy (Complex Int)), A.encode (Unary 42 :: Complex Int)) , (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 Optional), A.encode (Optional { optionalInt = Just 1 })) + + , (getTypeScriptType (Proxy :: Proxy AesonTypes), A.encode (AesonTypes { + aesonValue = A.object [("foo" :: AesonKey, A.Number 42)] + , aesonObject = aesonFromList [("foo", A.Number 42)] + })) + + , (getTypeScriptType (Proxy :: Proxy Numbers), A.encode (Numbers 42 42 42 42 42)) + , (getTypeScriptType (Proxy :: Proxy FancyFunctors), A.encode fancyFunctorsValue) + ]|] declarations :: Exp <- [e|getTypeScriptDeclarations (Proxy :: Proxy Unit) <> getTypeScriptDeclarations (Proxy :: Proxy OneFieldRecordless) @@ -66,11 +132,15 @@ testDeclarations testName aesonOptions = do <> getTypeScriptDeclarations (Proxy :: Proxy TwoField) <> getTypeScriptDeclarations (Proxy :: Proxy Hybrid) <> getTypeScriptDeclarations (Proxy :: Proxy TwoConstructor) - <> getTypeScriptDeclarations (Proxy :: Proxy Complex) + <> getTypeScriptDeclarations (Proxy :: Proxy (Complex T)) <> getTypeScriptDeclarations (Proxy :: Proxy Optional) + <> getTypeScriptDeclarations (Proxy :: Proxy AesonTypes) + <> getTypeScriptDeclarations (Proxy :: Proxy Numbers) + <> getTypeScriptDeclarations (Proxy :: Proxy FancyFunctors) |] - tests <- [d|tests = describe $(return $ LitE $ StringL testName) $ it "type checks everything with tsc" $ testTypeCheckDeclarations $(return declarations) $(return typesAndValues)|] + tests <- [d|tests :: SpecWith () + tests = describe $(return $ LitE $ StringL testName) $ it "type checks everything with tsc" $ testTypeCheckDeclarations $(return declarations) $(return typesAndValues)|] return $ decls ++ tests diff --git a/test/TwoElemArrayNoTagSingleConstructors.hs b/test/TwoElemArrayNoTagSingleConstructors.hs index f7a051d..cc0bd2c 100644 --- a/test/TwoElemArrayNoTagSingleConstructors.hs +++ b/test/TwoElemArrayNoTagSingleConstructors.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module TwoElemArrayNoTagSingleConstructors (tests) where +module TwoElemArrayNoTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate -import Util $(testDeclarations "TwoElemArray with tagSingleConstructors=False" (A.defaultOptions {sumEncoding=TwoElemArray})) +main :: IO () main = hspec tests diff --git a/test/TwoElemArrayTagSingleConstructors.hs b/test/TwoElemArrayTagSingleConstructors.hs index 585a2c2..7bff5f1 100644 --- a/test/TwoElemArrayTagSingleConstructors.hs +++ b/test/TwoElemArrayTagSingleConstructors.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} -module TwoElemArrayTagSingleConstructors (tests) where +module TwoElemArrayTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util $(testDeclarations "TwoElemArray with tagSingleConstructors=True" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=TwoElemArray})) +main :: IO () main = hspec tests diff --git a/test/UntaggedNoTagSingleConstructors.hs b/test/UntaggedNoTagSingleConstructors.hs index f72f324..d4862e6 100644 --- a/test/UntaggedNoTagSingleConstructors.hs +++ b/test/UntaggedNoTagSingleConstructors.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} +{-# LANGUAGE CPP #-} -module UntaggedNoTagSingleConstructors (tests) where +module UntaggedNoTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate -import Util -- Between Aeson 0.11.3.0 and 1.0.0.0, UntaggedValue was added -- Disable these tests if it's not present @@ -16,4 +14,5 @@ $(testDeclarations "UntaggedNoTagSingleConstructors" (A.defaultOptions {sumEncod tests = describe "UntaggedNoTagSingleConstructors" $ it "tests are disabled for this Aeson version" $ 2 `shouldBe` 2 #endif +main :: IO () main = hspec tests diff --git a/test/UntaggedTagSingleConstructors.hs b/test/UntaggedTagSingleConstructors.hs index 9bd19ba..d94b811 100644 --- a/test/UntaggedTagSingleConstructors.hs +++ b/test/UntaggedTagSingleConstructors.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns, KindSignatures #-} +{-# LANGUAGE CPP #-} -module UntaggedTagSingleConstructors (tests) where +module UntaggedTagSingleConstructors (main, tests) where import Data.Aeson as A -import Data.Aeson.TH as A import Test.Hspec import TestBoilerplate import Util @@ -13,7 +12,9 @@ import Util #if MIN_VERSION_aeson(1,0,0) $(testDeclarations "UntaggedTagSingleConstructors" (setTagSingleConstructors $ A.defaultOptions {sumEncoding=UntaggedValue})) #else +tests :: SpecWith () tests = describe "UntaggedTagSingleConstructors" $ it "tests are disabled for this Aeson version" $ 2 `shouldBe` 2 #endif +main :: IO () main = hspec tests diff --git a/test/UnwrapUnaryRecords.hs b/test/UnwrapUnaryRecords.hs new file mode 100644 index 0000000..1a75fb2 --- /dev/null +++ b/test/UnwrapUnaryRecords.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} + +module UnwrapUnaryRecords (allTests) where + +import Data.Aeson as A +import Data.Aeson.TypeScript.TH +import Data.Aeson.TypeScript.Types +import Data.Proxy +import Test.Hspec +import TestBoilerplate + + +#if MIN_VERSION_aeson(0,10,0) +$(testDeclarations "UnwrapUnaryRecords" (A.defaultOptions {unwrapUnaryRecords = True})) + +allTests :: SpecWith () +allTests = describe "UnwrapUnaryRecords" $ do + it "encodes as expected" $ do + let decls = getTypeScriptDeclarations (Proxy :: Proxy OneField) + + decls `shouldBe` [ + TSTypeAlternatives "OneField" [] ["IOneField"] Nothing + ,TSTypeAlternatives "IOneField" [] ["string"] Nothing + ] + + tests +#else +tests :: SpecWith () +tests = describe "UnwrapUnaryRecords" $ it "tests are disabled for this Aeson version" $ 2 `shouldBe` 2 + +allTests = tests +#endif + +main :: IO () +main = hspec allTests diff --git a/test/Util.hs b/test/Util.hs index 46cd051..8436f05 100644 --- a/test/Util.hs +++ b/test/Util.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings, TemplateHaskell, RecordWildCards, ScopedTypeVariables, NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Util where import Control.Monad import Data.Aeson as A -import Data.Aeson.TH as A import Data.Aeson.TypeScript.TH import qualified Data.ByteString.Lazy as B import Data.Proxy -import Data.String.Interpolate.IsString +import Data.String.Interpolate import qualified Data.Text as T import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO.Temp -import System.Process +import System.Process hiding (cwd) + +npmInstallScript, yarnInstallScript, localTSC :: String npmInstallScript = "test/assets/npm_install.sh" yarnInstallScript = "test/assets/yarn_install.sh" localTSC = "test/assets/node_modules/.bin/tsc" @@ -25,14 +26,12 @@ isCI :: IO Bool isCI = lookupEnv "CI" >>= (return . (== (Just "true"))) getTSC :: IO FilePath -getTSC = do - isCI <- isCI - case isCI of - True -> do - return "tsc" -- Assume it's set up on the path - False -> do - ensureTSCExists - return localTSC +getTSC = isCI >>= \case + True -> do + return "tsc" -- Assume it's set up on the path + False -> do + ensureTSCExists + return localTSC testTypeCheck :: forall a. (TypeScript a, ToJSON a) => a -> IO () testTypeCheck obj = withSystemTempDirectory "typescript_test" $ \folder -> do @@ -46,19 +45,20 @@ let x: #{tsType} = #{A.encode obj}; -- "--diagnostics", "--listFiles" tsc <- getTSC - readProcess tsc ["--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] "" + void $ readProcess tsc ["--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] "" return () where tsDeclarations :: [TSDeclaration] = getTypeScriptDeclarations (Proxy :: Proxy a) tsType :: String = getTypeScriptType (Proxy :: Proxy a) +getTSFile :: [TSDeclaration] -> [(String, B.ByteString)] -> String getTSFile tsDeclarations typesAndVals = [i| #{formatTSDeclarations tsDeclarations} #{T.unlines typeLines} |] - where typeLines = [[i|let x#{index}: #{typ} = #{val};|] | (index, (typ, val)) <- zip [1..] typesAndVals] + where typeLines = [[i|let x#{index}: #{typ} = #{val};|] | (index, (typ, val)) <- zip [(1 :: Int)..] typesAndVals] testTypeCheckDeclarations :: [TSDeclaration] -> [(String, B.ByteString)] -> IO () @@ -70,12 +70,19 @@ testTypeCheckDeclarations tsDeclarations typesAndVals = withSystemTempDirectory writeFile tsFile contents tsc <- getTSC - (code, output, err) <- readProcessWithExitCode tsc ["--strict", "--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] "" + (code, sout, serr) <- readProcessWithExitCode tsc ["--strict", "--noEmit", "--skipLibCheck", "--traceResolution", "--noResolve", tsFile] "" - when (code /= ExitSuccess) $ do - error [i|TSC check failed: #{output}. File contents were\n\n#{contents}|] + when (code /= ExitSuccess) $ + error [__i|TSC check failed. + File contents: + #{contents} - return () + Stdout: + #{sout} + + Stderr: + #{serr} + |] ensureTSCExists :: IO () diff --git a/test/Util/Aeson.hs b/test/Util/Aeson.hs new file mode 100644 index 0000000..38aded1 --- /dev/null +++ b/test/Util/Aeson.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +module Util.Aeson where + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM + +aesonFromList :: [(K.Key, v)] -> KM.KeyMap v +aesonFromList = KM.fromList + +type AesonKey = K.Key +#else +import Data.Aeson as A +import Data.HashMap.Strict as HM +import Data.Text as T + +aesonFromList :: [(T.Text, Value)] -> HM.HashMap Text A.Value +aesonFromList = HM.fromList + +type AesonKey = Text +#endif diff --git a/test/assets/package.json b/test/assets/package.json index 29171df..4c6aec1 100644 --- a/test/assets/package.json +++ b/test/assets/package.json @@ -1,9 +1,5 @@ { "private": true, - "scripts": { - - }, - "dependencies": {}, "devDependencies": { "typescript": "2.5.3" } diff --git a/test/assets/yarn.lock b/test/assets/yarn.lock index faf7597..45ab7c0 100644 --- a/test/assets/yarn.lock +++ b/test/assets/yarn.lock @@ -1,7 +1,34 @@ -# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. -# yarn lockfile v1 +# This file is generated by running "yarn install" inside your project. +# Manual changes might be lost - proceed with caution! +__metadata: + version: 8 + cacheKey: 10c0 -typescript@2.5.3: - version "2.5.3" - resolved "https://registry.yarnpkg.com/typescript/-/typescript-2.5.3.tgz#df3dcdc38f3beb800d4bc322646b04a3f6ca7f0d" +"root-workspace-0b6124@workspace:.": + version: 0.0.0-use.local + resolution: "root-workspace-0b6124@workspace:." + dependencies: + typescript: "npm:2.5.3" + languageName: unknown + linkType: soft + +"typescript@npm:2.5.3": + version: 2.5.3 + resolution: "typescript@npm:2.5.3" + bin: + tsc: ./bin/tsc + tsserver: ./bin/tsserver + checksum: 56092000fa36c9af67e2be79722e95e72c35450dba3e830afae602d38c009af18d1aed07bf545dee446adb598812612acd73abd81955687b65343632fa159a1b + languageName: node + linkType: hard + +"typescript@patch:typescript@npm%3A2.5.3#optional!builtin": + version: 2.5.3 + resolution: "typescript@patch:typescript@npm%3A2.5.3#optional!builtin::version=2.5.3&hash=3bafbf" + bin: + tsc: ./bin/tsc + tsserver: ./bin/tsserver + checksum: aaf016a1f934cb088930e7b5ffeea9a1d910aba4df5a5e8ff89f6bc742da6776f860ac9deebb74849466462b5c73f4392aeb0a0d806d8d8fd813652e38ae761f + languageName: node + linkType: hard diff --git a/weeder.dhall b/weeder.dhall new file mode 100644 index 0000000..e3bbc53 --- /dev/null +++ b/weeder.dhall @@ -0,0 +1 @@ +{ roots = [ "formatTSDeclarations", "deriveJSONAndTypeScript", "main", "getTransitiveClosure" ], type-class-roots = True }