├── .github ├── CODEOWNERS ├── actions │ └── cabal-cache │ │ └── action.yml └── workflows │ ├── check.yml │ └── publish.yml ├── .gitignore ├── .golden ├── e2e │ └── example │ │ └── golden.ts └── ts │ ├── .gitignore │ ├── named-export │ ├── golden.ts │ └── golden.tsx │ ├── nested-select │ └── golden.ts │ ├── package.json │ ├── tsconfig.json │ ├── typedef │ ├── golden.ts │ └── golden.tsx │ └── yarn.lock ├── .hlint.yaml ├── .vscode └── settings.json ├── ARCHITECTURE.md ├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.project ├── cli ├── CLI.hs └── Main.hs ├── flake.lock ├── flake.nix ├── intlc.cabal ├── lib ├── Intlc │ ├── Backend │ │ ├── ICU │ │ │ └── Compiler.hs │ │ ├── JSON │ │ │ └── Compiler.hs │ │ ├── JavaScript │ │ │ ├── Compiler.hs │ │ │ └── Language.hs │ │ └── TypeScript │ │ │ ├── Compiler.hs │ │ │ └── Language.hs │ ├── Compiler.hs │ ├── Core.hs │ ├── Error.hs │ ├── ICU.hs │ ├── Linter.hs │ ├── Parser.hs │ ├── Parser │ │ ├── Error.hs │ │ ├── ICU.hs │ │ └── JSON.hs │ ├── Prettify.hs │ └── Printer.hs └── Utils.hs └── test ├── Intlc ├── Backend │ └── TypeScriptSpec.hs ├── CompilerSpec.hs ├── EndToEndSpec.hs ├── ICUSpec.hs ├── LinterSpec.hs ├── Parser │ ├── ICUSpec.hs │ └── JSONSpec.hs └── PrettifySpec.hs ├── Spec.hs └── UtilsSpec.hs /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | # These users will be the default owners for everything in the repo. 2 | # See https://github.com/blog/2392-introducing-code-owners 3 | 4 | * @unsplash/web -------------------------------------------------------------------------------- /.github/actions/cabal-cache/action.yml: -------------------------------------------------------------------------------- 1 | name: Cabal dependency and incremental build caches 2 | runs: 3 | using: composite 4 | steps: 5 | - name: Cache dependencies 6 | uses: actions/cache@v4 7 | with: 8 | path: ~/.local/state/cabal/store/ 9 | key: cabal-${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('cabal.project.freeze') }} 10 | restore-keys: | 11 | cabal-${{ runner.os }}-${{ runner.arch }} 12 | - name: Cache incremental build 13 | uses: actions/cache@v4 14 | with: 15 | path: ./dist-newstyle/ 16 | key: dist-${{ runner.os }}-${{ runner.arch }}-${{ github.sha }} 17 | restore-keys: | 18 | dist-${{ runner.os }}-${{ runner.arch }} 19 | -------------------------------------------------------------------------------- /.github/workflows/check.yml: -------------------------------------------------------------------------------- 1 | name: Check 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | validate-nix: 11 | name: Validate Nix 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v4 15 | - uses: cachix/install-nix-action@v26 16 | - run: nix flake check 17 | build: 18 | name: Build 19 | runs-on: ubuntu-latest 20 | steps: 21 | - uses: actions/checkout@v4 22 | - uses: cachix/install-nix-action@v26 23 | - run: nix develop -c cabal update 24 | - run: nix develop -c cabal freeze 25 | - uses: ./.github/actions/cabal-cache 26 | - run: nix develop -c cabal build 27 | test: 28 | name: Test 29 | runs-on: ubuntu-latest 30 | steps: 31 | - uses: actions/checkout@v4 32 | - uses: cachix/install-nix-action@v26 33 | - run: nix develop -c cabal update 34 | - run: nix develop -c cabal freeze 35 | - uses: ./.github/actions/cabal-cache 36 | - run: nix develop -c cabal test 37 | lint: 38 | name: Lint 39 | runs-on: ubuntu-latest 40 | steps: 41 | - uses: actions/checkout@v4 42 | - uses: cachix/install-nix-action@v26 43 | - run: nix develop -c hlint lib cli test 44 | fmt: 45 | name: Formatting 46 | runs-on: ubuntu-latest 47 | steps: 48 | - uses: actions/checkout@v4 49 | - uses: cachix/install-nix-action@v26 50 | # stylish-haskell doesn't have a check/dry run option, so we'll run it 51 | # against files in place and test if there are any diffs with Git. 52 | - run: | 53 | nix develop -c stylish-haskell -ir lib cli test 54 | git diff-index --exit-code HEAD 55 | typecheck-ts: 56 | name: Typecheck TypeScript 57 | runs-on: ubuntu-latest 58 | defaults: 59 | run: 60 | working-directory: .golden/ts/ 61 | steps: 62 | - uses: actions/checkout@v4 63 | - uses: cachix/install-nix-action@v26 64 | - uses: actions/cache@v4 65 | with: 66 | path: ~/.cache/yarn/v6 67 | key: yarn-${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('.golden/ts/yarn.lock') }} 68 | restore-keys: | 69 | yarn-${{ runner.os }}-${{ runner.arch }} 70 | - run: nix develop .#golden -c yarn install --frozen-lockfile 71 | - run: nix develop .#golden -c yarn typecheck 72 | -------------------------------------------------------------------------------- /.github/workflows/publish.yml: -------------------------------------------------------------------------------- 1 | name: Publish 2 | 3 | on: 4 | push: 5 | tags: 6 | - v*.*.* 7 | 8 | jobs: 9 | publish: 10 | name: Publish binaries 11 | strategy: 12 | matrix: 13 | os: 14 | [ 15 | { name: "linux-x86_64", runner: "ubuntu-latest" }, 16 | { name: "macos-aarch64", runner: "macos-latest" }, 17 | ] 18 | runs-on: ${{ matrix.os.runner }} 19 | permissions: 20 | contents: write 21 | steps: 22 | - uses: actions/checkout@v4 23 | # Using Nix causes dynamic linking issues on macOS. It's easier to 24 | # workaround on Linux with patchelf at least. (Yes, building statically 25 | # would be substantially better.) 26 | - uses: haskell-actions/setup@v2 27 | with: 28 | ghc-version: 9.6.4 29 | - run: cabal freeze 30 | - uses: ./.github/actions/cabal-cache 31 | - name: Build 32 | run: | 33 | # Unlike `cabal build`, `cabal install` appears to build in a 34 | # different working directory, which means our githash dependency 35 | # can't access Git at compile time. Related: 36 | # https://github.com/snoyberg/githash/issues/9 37 | cabal build 38 | mv $(find ./dist-newstyle/ -name intlc -type f) dist-newstyle/intlc-${{ github.ref_name }}-${{ matrix.os.name }} 39 | - name: Release 40 | uses: softprops/action-gh-release@v2 41 | with: 42 | files: | 43 | dist-newstyle/intlc-${{ github.ref_name }}-${{ matrix.os.name }} 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /.golden/**/*/actual* 3 | -------------------------------------------------------------------------------- /.golden/e2e/example/golden.ts: -------------------------------------------------------------------------------- 1 | export const greeting: (x: { age: number; bold: (x: string) => string; name: string }) => string = x => `Hello ${x.bold(`${x.name}`)}, ${new Intl.NumberFormat('en-US').format(x.age)}!` 2 | export const title: () => string = () => `Unsplash` -------------------------------------------------------------------------------- /.golden/ts/.gitignore: -------------------------------------------------------------------------------- 1 | node_modules/ 2 | -------------------------------------------------------------------------------- /.golden/ts/named-export/golden.ts: -------------------------------------------------------------------------------- 1 | export const test: (x: { age: number; bold: (x: string) => string; currTime: Date; isDev: boolean; magicNumber: number; name: ('Sam' | 'Ashley') & string; todayDate: Date }) => string = x => `Hello ${x.bold(`${x.name}`)}! You are ${(() => { switch (x.age as typeof x.age) { case 42: return `very cool`; default: { switch (new Intl.PluralRules('te-ST').select(x.age)) { case 'zero': return `new around here`; default: return `not all that interesting`; } } } })()}. Regardless, the magic number is most certainly ${new Intl.NumberFormat('te-ST').format(x.magicNumber)}! The date is ${new Intl.DateTimeFormat('te-ST', { dateStyle: 'short' }).format(x.todayDate)}, and the time is ${new Intl.DateTimeFormat('te-ST', { timeStyle: 'full' }).format(x.currTime)}. And just to recap, your name is ${(() => { switch (x.name as typeof x.name) { case 'Sam': return `undoubtedly excellent`; case 'Ashley': return `fairly good`; } })()}. Finally, you are ${(() => { switch (x.isDev as typeof x.isDev) { case true: return `a software engineer`; case false: return `something less fun`; } })()}. Bonus: Some characters that might need escaping! \` \`\`` -------------------------------------------------------------------------------- /.golden/ts/named-export/golden.tsx: -------------------------------------------------------------------------------- 1 | export const test: (x: { age: number; bold: (x: ReactElement) => ReactElement; currTime: Date; isDev: boolean; magicNumber: number; name: ('Sam' | 'Ashley') & string; todayDate: Date }) => ReactElement = x => <>Hello {x.bold(<>{x.name})}! You are {(() => { switch (x.age as typeof x.age) { case 42: return <>very cool; default: { switch (new Intl.PluralRules('te-ST').select(x.age)) { case 'zero': return <>new around here; default: return <>not all that interesting; } } } })()}. Regardless, the magic number is most certainly {new Intl.NumberFormat('te-ST').format(x.magicNumber)}! The date is {new Intl.DateTimeFormat('te-ST', { dateStyle: 'short' }).format(x.todayDate)}, and the time is {new Intl.DateTimeFormat('te-ST', { timeStyle: 'full' }).format(x.currTime)}. And just to recap, your name is {(() => { switch (x.name as typeof x.name) { case 'Sam': return <>undoubtedly excellent; case 'Ashley': return <>fairly good; } })()}. Finally, you are {(() => { switch (x.isDev as typeof x.isDev) { case true: return <>a software engineer; case false: return <>something less fun; } })()}. Bonus: Some characters that might need escaping! ` `` -------------------------------------------------------------------------------- /.golden/ts/nested-select/golden.ts: -------------------------------------------------------------------------------- 1 | export const test: (x: { x: 'a' | 'b' }) => string = x => `${(() => { switch (x.x as typeof x.x) { case 'a': return ``; case 'b': return `${(() => { switch (x.x as typeof x.x) { case 'a': return ``; case 'b': return ``; } })()}`; } })()}` -------------------------------------------------------------------------------- /.golden/ts/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "scripts": { 3 | "typecheck": "tsc --noEmit" 4 | }, 5 | "devDependencies": { 6 | "typescript": "^4.5.5" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /.golden/ts/tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "lib": ["es2020"], 4 | "strict": true 5 | } 6 | } 7 | -------------------------------------------------------------------------------- /.golden/ts/typedef/golden.ts: -------------------------------------------------------------------------------- 1 | export type Test = (x: { age: number; bold: (x: string) => string; currTime: Date; isDev: boolean; magicNumber: number; name: ('Sam' | 'Ashley') & string; todayDate: Date }) => string -------------------------------------------------------------------------------- /.golden/ts/typedef/golden.tsx: -------------------------------------------------------------------------------- 1 | export type Test = (x: { age: number; bold: (x: ReactElement) => ReactElement; currTime: Date; isDev: boolean; magicNumber: number; name: ('Sam' | 'Ashley') & string; todayDate: Date }) => ReactElement -------------------------------------------------------------------------------- /.golden/ts/yarn.lock: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. 2 | # yarn lockfile v1 3 | 4 | 5 | typescript@^4.5.5: 6 | version "4.5.5" 7 | resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.5.5.tgz#d8c953832d28924a9e3d37c73d729c846c5896f3" 8 | integrity sha512-TCTIul70LyWe6IJWT8QSYeA54WQe8EjQFU4wY52Fasj5UKx88LNYKCgBEHcOMOrFF1rKGbD8v/xcNWVUq9SymA== 9 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [-XQuasiQuotes] 2 | - ignore: {name: Use newtype instead of data} 3 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "haskell.formattingProvider": "stylish-haskell" 3 | } 4 | -------------------------------------------------------------------------------- /ARCHITECTURE.md: -------------------------------------------------------------------------------- 1 | # Architecture 2 | 3 | The project is split into two parts, `cli` and `lib`. 4 | 5 | ## CLI 6 | 7 | The CLI portion is fairly small and handles taking user input and producing output. Thinking of a “functional core, imperative shell”, this is the shell. The data flow starts here, moves into the library, and ends up back here again. 8 | 9 | ## Library 10 | 11 | The library is the pure functional core. It takes care of parsing and compiling, taking anticipated valid JSON input and outputting, if all goes well, a string representing code in the format of the requested backend. 12 | 13 | ```mermaid 14 | flowchart 15 | subgraph CLI 16 | CLIParse[Parse CLI opts] 17 | --> 18 | CLIReadFile[Read file at provided path] 19 | 20 | CLIStdOut[Print to stdout] 21 | end 22 | 23 | subgraph Library 24 | Parser 25 | 26 | Compiler 27 | end 28 | 29 | subgraph Parser 30 | parserJSON[Parse JSON] 31 | --> 32 | parserICU[Parse ICU messages] 33 | end 34 | 35 | subgraph Compiler 36 | compilerIntermediary[Convert to intermediary AST] 37 | --> 38 | compilerCode[Compile to code string] 39 | end 40 | 41 | CLIReadFile --> Parser --> Compiler --> CLIStdOut 42 | ``` 43 | 44 | ### Parsing 45 | 46 | The ICU message parser is a [recursive descent parser](https://en.wikipedia.org/wiki/Recursive_descent_parser) written with [Megaparsec](https://hackage.haskell.org/package/megaparsec). Recursive descent essentially means for the mental model that we have a recursive tree of parsers that will each try in turn to match on some amount of the text on the left-hand side of our string, progressively parsing from left-to-right until we reach the end. 47 | 48 | For example, given an ICU message `hello {name}`, we’d first try parsing for an interpolation or tag, and failing that would parse plaintext, which we’d do until we encountered a reason to stop, in this case the tag opening character. We’ve stored "hello " as plaintext and will now continue along, this time succeeding in parsing the tag. We’ll now recursively parse inside the bounds of the tag, reusing the same top-level parser we were just using, this time parsing an interpolation. Having done this we’ve _consumed_ the entire input string and have successfully parsed a recursive list of nodes making up our [AST](https://en.wikipedia.org/wiki/Abstract_syntax_tree). 49 | 50 | JSON parsing is handled internally for better interop with the ICU parser. 51 | 52 | ### Compilation 53 | 54 | Should parsing succeed the ICU AST will be passed along to the relevant backend compiler, which takes care of compilation and potentially some validation. The compilers generally exist in isolation from one-another and can be implemented in completely different ways; our JavaScript and TypeScript compilers are a special case in which they know about each other for code reuse due to the runtime representations being identical. This flexibility will make it easier to implement new backends for distinct languages. 55 | 56 | The compilers take the ICU AST and recursively compile each node into an output string, which is all concatenated together to form our output code. This is in a sense the exact inverse of the parsing we did before. An implementation detail of the compilers we have so far is that for comprehensibility they first convert the ICU AST into a minimal target-language AST, before compiling against this intermediary AST. 57 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | This project adheres to semantic versioning. 4 | 5 | ## 0.8.4 (2024-11-21) 6 | 7 | Make TypeScript output compatible with `verbatimModuleSyntax`. 8 | 9 | ## 0.8.3 (2024-04-24) 10 | 11 | Fixed dynamic linking in macos-aarch64 binary. 12 | 13 | ## 0.8.2 (2024-04-23) 14 | 15 | Allowed "✓" character in internal linter. 16 | 17 | ## 0.8.1 (2023-02-20) 18 | 19 | Fixed flattening in the presence of callback tags. 20 | 21 | ## 0.8.0 (2023-01-23) 22 | 23 | Added `--indent` option to the flatten and prettify commands. This enables explicit configuration of formatting indentation either as tabs or as a number of spaces. The option is ignored in the presence of `--minify` where applicable. 24 | 25 | Shifted everything from the "internal" binary into the main binary behind hidden flags. 26 | 27 | Improved CI binary naming, clarifying in particular which architecture they're built against. 28 | 29 | Added a `--version` option. 30 | 31 | Added a changelog. Everything prior to this release may not be perfectly accurate. 32 | 33 | ## 0.7.0 (2023-01-13) 34 | 35 | Prettify JSON by default. A `--minify` flag has been added to retain the old behaviour. 36 | 37 | ## 0.6.1 (2022-12-08) 38 | 39 | Fixed linking of binaries produced in CI. 40 | 41 | ## 0.6.0 (2022-11-21) 42 | 43 | Added ICU prettify command. 44 | 45 | Redundant interpolations can now be parsed. They are linted against instead of being wholly disallowed. Further lint rules have been added, and linting output is now substantially better. 46 | 47 | ## 0.5.0 (2022-07-23) 48 | 49 | Added linting. 50 | 51 | ## 0.4.1 (2022-07-05) 52 | 53 | Fixed parsing of escaped ICU leaking across JSON messages. 54 | 55 | ## 0.4.0 (2022-07-01) 56 | 57 | Improved error reporting to now eagerly report as many errors as possible before halting. 58 | 59 | Fixed TypeScript output producing a type error because tsc tries to be too smart. 60 | 61 | Fixed formatting of plurals in flattened output. 62 | 63 | Added an "internal" binary intended for Unsplash, featuring lint rules for specific use cases and plural expansion. 64 | 65 | ## 0.3.2 (2022-04-08) 66 | 67 | Fixed `boolean` interpolations not being flattened. 68 | 69 | ## 0.3.1 (2022-04-05) 70 | 71 | Fixed codegen of interpolations inside `boolean` interpolations. 72 | 73 | ## 0.3.0 (2022-03-17) 74 | 75 | Added a `boolean` type. 76 | 77 | Typechecking of output TypeScript code is now offloaded to downstream tsc. 78 | 79 | Improved JSON key validation. 80 | 81 | Compiled output is now alphabetical. 82 | 83 | Fixed various codegen issues, and parsing of `#` in `select` interpolations. 84 | 85 | ## 0.2.2 (2022-03-04) 86 | 87 | Fixed description key not being preserved when flattening. 88 | 89 | ## 0.2.1 (2022-02-03) 90 | 91 | ICU parsing is now stricter, JSON keys are somewhat validated, and React import statements are conditional. 92 | 93 | Fixed parsing of nested `#` plural interpolations. 94 | 95 | intlc is now MIT licensed. 96 | 97 | ## 0.2.0 (2022-01-26) 98 | 99 | Added flattening and `--help`. 100 | 101 | ## 0.1.1 (2022-01-25) 102 | 103 | Fixed React import casing. 104 | 105 | ## 0.1.0 (2022-01-24) 106 | 107 | Hello world! 108 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Unsplash 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # intlc 2 | 3 | Compile ICU messages into code. Supports TypeScript and JSX. No runtime. 4 | 5 | - **Compatible** - supports most common ICU syntax [with some optional extras](https://github.com/unsplash/intlc/wiki/ICU-syntax). 6 | - **Typesafe** - embraces TypeScript output, taking advantage of unions to forgo the need for wildcards. 7 | - **Lightweight** - no runtime, so no bundle or performance bloat. Just plain functions. 8 | - **Fast** - compiles via a native binary. Most projects can expect everything to compile in under a second. 9 | - **Unopinionated** - JSON/ICU in, code out. Structure your application around this in whichever way suits you. 10 | - **Maintained** - in production at [unsplash.com](https://unsplash.com). 11 | 12 | https://user-images.githubusercontent.com/6402443/194868749-23c86dd1-4996-4c60-a0b6-88685078fb38.mov 13 | 14 | ## CLI 15 | 16 | Grab a binary from the releases page: https://github.com/unsplash/intlc/releases 17 | 18 | ``` 19 | Usage: intlc COMMAND 20 | Compile ICU messages into code. 21 | 22 | Available options: 23 | -h,--help Show this help text 24 | --version Print version information 25 | 26 | Available commands: 27 | compile 28 | flatten 29 | lint 30 | prettify 31 | ``` 32 | 33 | ### Compiling 34 | 35 | Take a JSON object of ICU messages, and a locale, and output TypeScript to stdout. 36 | 37 | ```console 38 | $ cat translations.json 39 | {"welcome":{"message": "Hello {name}"}} 40 | $ intlc compile translations.json -l en-US > translations.ts 41 | $ cat translations.ts 42 | export const welcome: (x: { name: string }) => string = x => `Hello ${x.name}` 43 | ``` 44 | 45 | Check out an example project integration in our wiki: https://github.com/unsplash/intlc/wiki/Example-project-integration 46 | 47 | ### Flattening 48 | 49 | Hoist selectors up as much as possible. This is often preferred by translators. 50 | 51 | ```console 52 | $ cat translations.json 53 | {"openSource":{"message": "Open source at {company} is {company, select, Unsplash {encouraged!} other {unknown}}"}} 54 | $ intlc flatten --minify translations.json 55 | {"openSource":{"message":"{company, select, Unsplash {Open source at {company} is encouraged!} other {Open source at {company} is unknown}}"}} 56 | ``` 57 | 58 | ### Linting 59 | 60 | Lint against suboptimal use of ICU syntax. 61 | 62 | ```console 63 | $ cat translations.json 64 | {"welcome":{"message": "Hello {name, select, other {{name}}}"}} 65 | $ intlc lint translation.json 66 | translations.json:1:32: 67 | | 68 | 1 | {"welcome":{"message": "Hello {name, select, other {{name}}}"}} 69 | | ^^^^ 70 | redundant-select: Select named `name` is redundant as it only contains a wildcard. 71 | 72 | Learn more: https://github.com/unsplash/intlc/wiki/Lint-rules-reference#redundant-select 73 | ``` 74 | 75 | A reference for lint rules can be found in our wiki: https://github.com/unsplash/intlc/wiki/Lint-rules-reference 76 | 77 | ### Formatting 78 | 79 | Pretty-print an ICU message. Useful for inspecting larger messages such as flattened ones. 80 | 81 | ```console 82 | $ cat translations.json 83 | {"tagline": {"message":"{hasTags, boolean, true {{type, select, overLimit {{upperLimit, number}+ best free {formattedListOfTags} photos on Unsplash} belowLimit {{photoTotal, number} best free {formattedListOfTags} photos on Unsplash}}} false {{type, select, overLimit {{upperLimit, number}+ best free photos on Unsplash} belowLimit {{photoTotal, number} best free photos on Unsplash}}}}"}} 84 | $ intlc prettify $(cat translations.json | jq -r .tagline.message) 85 | {hasTags, boolean, 86 | true {{type, select, 87 | overLimit {{upperLimit, number}+ best free {formattedListOfTags} photos on Unsplash} 88 | belowLimit {{photoTotal, number} best free {formattedListOfTags} photos on Unsplash} 89 | }} 90 | false {{type, select, 91 | overLimit {{upperLimit, number}+ best free photos on Unsplash} 92 | belowLimit {{photoTotal, number} best free photos on Unsplash} 93 | }} 94 | } 95 | 96 | ``` 97 | 98 | ## Schema 99 | 100 | Translation files should be encoded as JSON and might look something like this: 101 | 102 | ```json 103 | { 104 | "welcome": { 105 | "message": "Hello {name}", 106 | "description": "Welcome message", 107 | "backend": "ts" 108 | } 109 | } 110 | ``` 111 | 112 | At present, the following backends (compilation targets) are supported: 113 | 114 | - TypeScript (`ts`, default) 115 | - TypeScript/React (`tsx`) 116 | 117 | The description is optional and ignored by intlc. It can be used documentatively for developers and/or translators. 118 | 119 | ## Contributing 120 | 121 | Check out `ARCHITECTURE.md`. 122 | 123 | Currently building against GHC 9.6.4. A Nix flake is included with all necessary dependencies. 124 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./intlc.cabal 2 | 3 | -------------------------------------------------------------------------------- /cli/CLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module CLI (Opts (..), getOpts, ICUModifiers (..)) where 4 | 5 | import GitHash (giTag, tGitInfoCwd) 6 | import qualified Intlc.Backend.JSON.Compiler as JSON 7 | import Intlc.Core (Locale (..)) 8 | import Intlc.Linter (LintRuleset (..)) 9 | import Intlc.Printer (IndentStyle (..), def) 10 | import Options.Applicative 11 | import Prelude 12 | 13 | -- False positive possibly fixed in v3.8. 14 | {-# ANN module ("HLint: ignore Unused LANGUAGE pragma" :: String) #-} 15 | 16 | data Opts 17 | = Compile FilePath Locale 18 | | Flatten FilePath JSON.Formatting [ICUModifiers] 19 | | Lint FilePath LintRuleset 20 | | Prettify Text IndentStyle 21 | 22 | data ICUModifiers 23 | = ExpandPlurals 24 | 25 | getOpts :: IO Opts 26 | getOpts = execParser (info (opts <**> helper <**> version) (progDesc h)) 27 | where h = "Compile ICU messages into code." 28 | 29 | version :: Parser (a -> a) 30 | version = infoOption (giTag gi) (long "version" <> help msg <> hidden) 31 | where msg = "Print version information" 32 | gi = $$tGitInfoCwd 33 | 34 | opts :: Parser Opts 35 | opts = subparser . mconcat $ 36 | [ command "compile" (info (compile <**> helper) mempty) 37 | , command "flatten" (info (flatten <**> helper) mempty) 38 | , command "lint" (info (lint <**> helper) mempty) 39 | , command "prettify" (info (prettify <**> helper) mempty) 40 | ] 41 | 42 | compile :: Parser Opts 43 | compile = Compile <$> pathp <*> localep 44 | 45 | flatten :: Parser Opts 46 | flatten = Flatten <$> pathp <*> jsonfmtp <*> expandp 47 | where expandp = flag mempty (pure ExpandPlurals) (long "expand-plurals" <> hidden) 48 | jsonfmtp = f <$> minifyp <*> indentp 49 | where f False x = JSON.Pretty x 50 | f True _ = JSON.Minified 51 | minifyp = flag False True (long "minify") 52 | 53 | lint :: Parser Opts 54 | lint = Lint <$> pathp <*> internalp 55 | where internalp = flag ExternalLintsOnly AllLints (long "with-internal" <> hidden) 56 | 57 | msgp :: Parser Text 58 | msgp = argument str (metavar "message") 59 | 60 | pathp :: Parser FilePath 61 | pathp = argument str (metavar "filepath") 62 | 63 | localep :: Parser Locale 64 | localep = Locale <$> strOption (short 'l' <> long "locale") 65 | 66 | prettify :: Parser Opts 67 | prettify = Prettify <$> msgp <*> indentp 68 | 69 | indentp :: Parser IndentStyle 70 | indentp = option (eitherReader parseIndentation) (value def <> long "indent" <> metavar "NAT") 71 | where parseIndentation x 72 | | x == "tab" || x == "tabs" = Right Tabs 73 | | otherwise = maybe (Left e) (Right . Spaces) (readMaybe x) 74 | where e = "Requires a natural number of spaces or tabs." 75 | -------------------------------------------------------------------------------- /cli/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import CLI (ICUModifiers (..), Opts (..), getOpts) 4 | import qualified Data.Text as T 5 | import Intlc.Compiler (compileDataset, compileToJSON, 6 | expandPlurals, flatten) 7 | import Intlc.Core 8 | import Intlc.ICU (AnnNode, Message, Node, sansAnn) 9 | import Intlc.Linter 10 | import Intlc.Parser (parseDataset, parseMessage, printErr) 11 | import Intlc.Parser.Error (ParseFailure) 12 | import Intlc.Prettify (prettify) 13 | import Intlc.Printer (IndentStyle) 14 | import Prelude 15 | 16 | main :: IO () 17 | main = getOpts >>= \case 18 | Compile path loc -> tryGetParsedAtSansAnn path >>= compile loc 19 | Flatten path fo ms -> tryGetParsedAtSansAnn path >>= (compileToJSON f fo >>> putTextLn) 20 | -- Beware that not all transformations can safely fuse. For example 21 | -- flattening must run against the entire AST by itself to necessarily be 22 | -- coherent. 23 | -- 24 | -- Beware also a simple `mconcat` against `mods` without the clarifying 25 | -- `Endo`! 26 | where f = appEndo (mconcat (Endo <$> mods)) . flatten 27 | mods = ms <&> \case 28 | ExpandPlurals -> expandPlurals 29 | Lint path lr -> lint lr path 30 | Prettify msg fo -> tryPrettify fo msg 31 | 32 | compile :: MonadIO m => Locale -> Dataset (Translation (Message Node)) -> m () 33 | compile loc = compileDataset loc >>> \case 34 | Left es -> die . T.unpack . ("Invalid keys:\n" <>) . T.intercalate "\n" . fmap ("\t" <>) . toList $ es 35 | Right x -> putTextLn x 36 | 37 | lint :: MonadIO m => LintRuleset -> FilePath -> m () 38 | lint lr path = do 39 | raw <- readFileAt path 40 | dataset <- parserDie $ parseDataset path raw 41 | whenJust (lintDataset lr path raw dataset) $ die . T.unpack 42 | 43 | tryPrettify :: MonadIO m => IndentStyle -> Text -> m () 44 | tryPrettify fmt = either (die . printErr) (putTextLn . prettify fmt . fmap sansAnn) . parseMessage "input" 45 | 46 | tryGetParsedAtSansAnn :: MonadIO m => FilePath -> m (Dataset (Translation (Message Node))) 47 | tryGetParsedAtSansAnn = parserDie . fmap datasetSansAnn <=< getParsedAt 48 | 49 | tryGetParsedAt :: MonadIO m => FilePath -> m (Dataset (Translation (Message AnnNode))) 50 | tryGetParsedAt = parserDie <=< getParsedAt 51 | 52 | parserDie :: MonadIO m => Either ParseFailure a -> m a 53 | parserDie = either (die . printErr) pure 54 | 55 | getParsedAt :: MonadIO m => FilePath -> m (Either ParseFailure (Dataset (Translation (Message AnnNode)))) 56 | getParsedAt x = parseDataset x <$> readFileAt x 57 | 58 | readFileAt :: MonadIO m => FilePath -> m Text 59 | readFileAt = fmap decodeUtf8 . readFileBS 60 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1710146030, 9 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1713805509, 24 | "narHash": "sha256-YgSEan4CcrjivCNO5ZNzhg7/8ViLkZ4CB/GrGBVSudo=", 25 | "owner": "nixos", 26 | "repo": "nixpkgs", 27 | "rev": "1e1dc66fe68972a76679644a5577828b6a7e8be4", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "nixos", 32 | "ref": "nixpkgs-unstable", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 4 | flake-utils.url = "github:numtide/flake-utils"; 5 | }; 6 | 7 | outputs = { self, nixpkgs, flake-utils }: 8 | flake-utils.lib.eachDefaultSystem (system: 9 | let pkgs = nixpkgs.legacyPackages.${system}; 10 | 11 | # We'll stick with the "default" version of GHC in nixpkgs to benefit 12 | # from the binary cache: 13 | # https://github.com/NixOS/nixpkgs/blob/master/doc/languages-frameworks/haskell.section.md#available-packages-haskell-available-packages 14 | ghcVer = "ghc964"; 15 | 16 | haskPkgs = pkgs.haskell.packages."${ghcVer}"; 17 | in { 18 | devShells = { 19 | default = pkgs.mkShell { 20 | nativeBuildInputs = with pkgs; [ 21 | cabal-install 22 | haskell.compiler."${ghcVer}" 23 | haskPkgs.haskell-language-server 24 | hlint 25 | haskPkgs.hspec-golden 26 | stylish-haskell 27 | ]; 28 | }; 29 | 30 | golden = pkgs.mkShell { 31 | nativeBuildInputs = with pkgs; [ 32 | nodejs 33 | yarn 34 | ]; 35 | }; 36 | }; 37 | }); 38 | } 39 | -------------------------------------------------------------------------------- /intlc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: intlc 3 | version: 0.8.4 4 | license: MIT 5 | build-type: Simple 6 | 7 | common common 8 | default-language: GHC2021 9 | default-extensions: 10 | LambdaCase 11 | NoImplicitPrelude 12 | OverloadedRecordDot 13 | OverloadedStrings 14 | ghc-options: 15 | -Wall 16 | build-depends: 17 | base ^>=4.18 18 | , bytestring ^>=0.11 19 | , comonad ^>=5.0 20 | , containers ^>=0.6 21 | , data-fix ^>=0.3 22 | , deriving-compat ^>=0.6 23 | , extra ^>=1.7 24 | , free ^>=5.1 25 | , mtl ^>=2.3 26 | , recursion-schemes ^>=5.2 27 | , relude ^>=1.2 28 | , text ^>=2.0 29 | , validation ^>=1.1 30 | mixins: 31 | base hiding (Prelude) 32 | , relude (Relude as Prelude) 33 | , relude 34 | 35 | executable intlc 36 | import: common 37 | hs-source-dirs: cli/ 38 | main-is: Main.hs 39 | build-depends: 40 | intlc 41 | , githash ^>=0.1 42 | , optparse-applicative ^>=0.18 43 | other-modules: 44 | CLI 45 | 46 | library 47 | import: common 48 | hs-source-dirs: lib/ 49 | build-depends: 50 | parser-combinators ^>=1.2 51 | , megaparsec ^>=9.5 52 | exposed-modules: 53 | Intlc.Compiler 54 | Intlc.Backend.JavaScript.Language 55 | Intlc.Backend.JavaScript.Compiler 56 | Intlc.Backend.JSON.Compiler 57 | Intlc.Backend.ICU.Compiler 58 | Intlc.Backend.TypeScript.Language 59 | Intlc.Backend.TypeScript.Compiler 60 | Intlc.Core 61 | Intlc.Error 62 | Intlc.ICU 63 | Intlc.Linter 64 | Intlc.Parser 65 | Intlc.Parser.Error 66 | Intlc.Parser.JSON 67 | Intlc.Parser.ICU 68 | Intlc.Prettify 69 | Intlc.Printer 70 | Utils 71 | 72 | test-suite test-intlc 73 | import: common 74 | default-extensions: 75 | QuasiQuotes 76 | hs-source-dirs: test/ 77 | main-is: Spec.hs 78 | type: exitcode-stdio-1.0 79 | build-depends: 80 | intlc 81 | , filepath ^>=1.4 82 | , hspec ^>=2.11 83 | , hspec-golden ^>=0.2 84 | , hspec-megaparsec ^>=2.2 85 | , megaparsec ^>=9.5 86 | , raw-strings-qq ^>=1.1 87 | build-tool-depends: 88 | hspec-discover:hspec-discover 89 | other-modules: 90 | Intlc.Backend.TypeScriptSpec 91 | Intlc.CompilerSpec 92 | Intlc.EndToEndSpec 93 | Intlc.ICUSpec 94 | Intlc.LinterSpec 95 | Intlc.Parser.JSONSpec 96 | Intlc.Parser.ICUSpec 97 | Intlc.PrettifySpec 98 | UtilsSpec 99 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/ICU/Compiler.hs: -------------------------------------------------------------------------------- 1 | -- This module is essentially the inverse of the parsing we perform; it's 2 | -- semantically reversible in that respect if not precisely due to formatting, 3 | -- no preservation of the presence of defaults, etc. 4 | -- 5 | -- This is a special backend in that it's not exposed as a "backend" but is 6 | -- instead used post-flattening. Additionally it only operates upon individual 7 | -- ICU messages, offloading JSON handling to the caller. 8 | 9 | module Intlc.Backend.ICU.Compiler (compileMsg, Formatting (..), pluralExact, pluralRule) where 10 | 11 | import Data.Functor.Foldable (cata) 12 | import qualified Data.Text as T 13 | import Intlc.ICU hiding (selectCases, wildcard) 14 | import Intlc.Printer (IndentStyle, indenter) 15 | import Prelude 16 | import Utils ((<>^)) 17 | 18 | compileMsg :: Formatting -> Message Node -> Text 19 | compileMsg x y = node x (unMessage y) 20 | 21 | data Formatting 22 | = SingleLine 23 | | MultiLine IndentStyle 24 | 25 | data Config = Config 26 | -- Expected to be potentially supplied externally. 27 | { fmt :: Formatting 28 | -- Expected to be supplied internally. 29 | , indentLevels :: Nat 30 | } 31 | 32 | type Compiler = Reader Config 33 | 34 | increment :: Compiler a -> Compiler a 35 | increment = local $ \x -> x { indentLevels = x.indentLevels + 1 } 36 | 37 | node :: Formatting -> Node -> Text 38 | node fo ast = runReader (cata go ast) (Config fo 0) where 39 | go :: NodeF (Compiler Text) -> Compiler Text 40 | go = \case 41 | Fin -> pure mempty 42 | 43 | (Char c next) -> (T.singleton c <>) <$> next 44 | 45 | (Bool { arg, trueCase, falseCase, next }) -> 46 | let cs = sequence [("true",) <$> trueCase, ("false",) <$> falseCase] 47 | in boolean arg cs <>^ next 48 | 49 | (String n next) -> (string n <>) <$> next 50 | 51 | (Number n next) -> (number n <>) <$> next 52 | 53 | (Date n fmt next) -> (date n fmt <>) <$> next 54 | 55 | (Time n fmt next) -> (time n fmt <>) <$> next 56 | 57 | (CardinalExact n xs next) -> cardinal n (exactPluralCases xs) <>^ next 58 | 59 | (CardinalInexact n xs ys w next) -> 60 | let cs = join <$> sequence [exactPluralCases xs, rulePluralCases ys, pure . wildcard <$> w] 61 | in cardinal n cs <>^ next 62 | 63 | (Ordinal n xs ys w next) -> 64 | let cs = join <$> sequence [exactPluralCases xs, rulePluralCases ys, pure . wildcard <$> w] 65 | in ordinal n cs <>^ next 66 | 67 | (PluralRef _ next) -> ("#" <>) <$> next 68 | 69 | (SelectNamed n xs y) -> select n (selectCases xs) <>^ y 70 | 71 | (SelectWild n w x) -> select n (pure . wildcard <$> w) <>^ x 72 | 73 | (SelectNamedWild n xs w next) -> 74 | let cs = (<>) <$> selectCases xs <*> (pure . wildcard <$> w) 75 | in select n cs <>^ next 76 | 77 | (Callback n xs next) -> (callback n <$> xs) <>^ next 78 | 79 | cardinal :: Arg -> Compiler [Case] -> Compiler Text 80 | cardinal n x = typedInterp "plural" n <$> (pure <$> cases x) 81 | 82 | ordinal :: Arg -> Compiler [Case] -> Compiler Text 83 | ordinal n x = typedInterp "selectordinal" n <$> (pure <$> cases x) 84 | 85 | select :: Arg -> Compiler [Case] -> Compiler Text 86 | select n x = typedInterp "select" n <$> (pure <$> cases x) 87 | 88 | boolean :: Arg -> Compiler [Case] -> Compiler Text 89 | boolean n x = typedInterp "boolean" n <$> (pure <$> cases x) 90 | 91 | datetime :: Text -> Arg -> DateTimeFmt -> Text 92 | datetime t n f = typedInterp t n (pure . dateTimeFmt $ f) 93 | 94 | date :: Arg -> DateTimeFmt -> Text 95 | date = datetime "date" 96 | 97 | time :: Arg -> DateTimeFmt -> Text 98 | time = datetime "time" 99 | 100 | typedInterp :: Text -> Arg -> [Text] -> Text 101 | typedInterp t n xs = interp n (t : xs) 102 | 103 | number :: Arg -> Text 104 | number = flip interp (pure "number") 105 | 106 | string :: Arg -> Text 107 | string = flip interp mempty 108 | 109 | interp :: Arg -> [Text] -> Text 110 | interp n xs = "{" <> interpPieces (unArg n : xs) <> "}" 111 | 112 | interpPieces :: [Text] -> Text 113 | interpPieces = T.intercalate ", " 114 | 115 | callback :: Arg -> Text -> Text 116 | callback n x = "<" <> unArg n <> ">" <> x <> " unArg n <> ">" 117 | 118 | type Case = (Text, Text) 119 | 120 | -- | This is where we'll manage indentation for all case-style interpolations, 121 | -- hence taking a monadic input. 122 | cases :: Compiler [Case] -> Compiler Text 123 | cases mcs = asks fmt >>= \case 124 | SingleLine -> unwords . fmap (uncurry case') <$> mcs 125 | MultiLine style -> do 126 | i <- asks indentLevels 127 | let indentedCase = (indentBy (i + 1) <>) . uncurry case' 128 | cs <- fmap indentedCase <$> increment mcs 129 | pure $ newline <> T.intercalate newline cs <> newline <> indentBy i 130 | where newline = "\n" 131 | indentBy = indenter style 132 | 133 | case' :: Text -> Text -> Text 134 | case' n x = n <> " {" <> x <> "}" 135 | 136 | wildcard :: Text -> Case 137 | wildcard = ("other",) 138 | 139 | selectCases :: Traversable t => t (SelectCaseF (Compiler Text)) -> Compiler [Case] 140 | selectCases = fmap toList . traverse selectCaseF 141 | 142 | selectCaseF :: Functor f => SelectCaseF (f Text) -> f Case 143 | selectCaseF (n, mx) = selectCase . (n,) <$> mx 144 | 145 | selectCase :: SelectCaseF Text -> Case 146 | selectCase = id 147 | 148 | exactPluralCases :: Traversable t => t (PluralCaseF PluralExact (Compiler Text)) -> Compiler [Case] 149 | exactPluralCases = fmap toList . traverse exactPluralCaseF 150 | 151 | exactPluralCaseF :: PluralCaseF PluralExact (Compiler Text) -> Compiler Case 152 | exactPluralCaseF (n, mx) = exactPluralCase . (n,) <$> mx 153 | 154 | exactPluralCase :: PluralCaseF PluralExact Text -> Case 155 | exactPluralCase = first pluralExact 156 | 157 | rulePluralCases :: Traversable t => t (PluralCaseF PluralRule (Compiler Text)) -> Compiler [Case] 158 | rulePluralCases = fmap toList . traverse rulePluralCaseF 159 | 160 | rulePluralCaseF :: PluralCaseF PluralRule (Compiler Text) -> Compiler Case 161 | rulePluralCaseF (r, mx) = rulePluralCase . (r,) <$> mx 162 | 163 | rulePluralCase :: PluralCaseF PluralRule Text -> Case 164 | rulePluralCase = first pluralRule 165 | 166 | pluralRule :: PluralRule -> Text 167 | pluralRule Zero = "zero" 168 | pluralRule One = "one" 169 | pluralRule Two = "two" 170 | pluralRule Few = "few" 171 | pluralRule Many = "many" 172 | 173 | pluralExact :: PluralExact -> Text 174 | pluralExact (PluralExact n) = "=" <> n 175 | 176 | dateTimeFmt :: DateTimeFmt -> Text 177 | dateTimeFmt Short = "short" 178 | dateTimeFmt Medium = "medium" 179 | dateTimeFmt Long = "long" 180 | dateTimeFmt Full = "full" 181 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/JSON/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Backend.JSON.Compiler where 2 | 3 | import Data.List.Extra (escapeJSON) 4 | import qualified Data.Map as M 5 | import qualified Data.Text as T 6 | import qualified Intlc.Backend.ICU.Compiler as ICU 7 | import Intlc.Core 8 | import Intlc.ICU (Message, Node) 9 | import Intlc.Printer (IndentStyle, indenter) 10 | import Prelude 11 | 12 | type Compiler = Reader Config 13 | 14 | data Config = Config 15 | -- Expected to be potentially supplied externally. 16 | { fmt :: Formatting 17 | -- Expected to be supplied internally. 18 | , indentLevels :: Nat 19 | } 20 | 21 | -- | For prettified formatting we simply indent and inject newlines at objects. 22 | data Formatting 23 | = Minified 24 | | Pretty IndentStyle 25 | 26 | increment :: Compiler a -> Compiler a 27 | increment = local $ \x -> x { indentLevels = x.indentLevels + 1 } 28 | 29 | -- Assumes unescaped input. 30 | dblqts :: Text -> Text 31 | dblqts v = "\"" <> escapeJSONText v <> "\"" 32 | where escapeJSONText = T.pack . escapeJSON . T.unpack 33 | 34 | strVal :: Text -> Text 35 | strVal = dblqts 36 | 37 | nullVal :: Text 38 | nullVal = "null" 39 | 40 | objKey :: Text -> Text 41 | objKey = dblqts 42 | 43 | -- | This is where we'll manage indentation for all objects, hence taking a 44 | -- monadic input. 45 | obj :: Compiler [(Text, Text)] -> Compiler Text 46 | obj xs = asks fmt >>= \case 47 | Minified -> do 48 | let objPair k v = objKey k <> ":" <> v 49 | contents <- T.intercalate "," . fmap (uncurry objPair) <$> xs 50 | pure $ "{" <> contents <> "}" 51 | Pretty style -> do 52 | i <- asks indentLevels 53 | let objPair k v = newline <> indentBy (i + 1) <> objKey k <> ": " <> v 54 | contents <- fmap (T.intercalate "," . fmap (uncurry objPair)) . increment $ xs 55 | pure $ "{" <> contents <> newline <> indentBy i <> "}" 56 | where newline = "\n" 57 | indentBy = indenter style 58 | 59 | compileDataset :: Formatting -> Dataset (Translation (Message Node)) -> Text 60 | compileDataset fo ds = runReader (dataset ds) (Config fo 0) 61 | where dataset = obj . traverse (uncurry f) . M.toList 62 | f x = fmap (x,) . translation 63 | 64 | translation :: Translation (Message Node) -> Compiler Text 65 | translation Translation { message, backend, mdesc } = obj . pure . fromList $ ys 66 | where ys = 67 | [ ("message", strVal . ICU.compileMsg ICU.SingleLine $ message) 68 | , ("backend", backendVal) 69 | , ("description", maybe nullVal strVal mdesc) 70 | ] 71 | backendVal = strVal $ 72 | case backend of 73 | TypeScript -> "ts" 74 | TypeScriptReact -> "tsx" 75 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/JavaScript/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Backend.JavaScript.Compiler (InterpStrat (..), Overrides (..), emptyOverrides, compileStmt, buildReactImport, emptyModule, validateKey) where 2 | 3 | import Control.Monad.Extra (pureIf) 4 | import Data.Char (isAlpha, isDigit) 5 | import qualified Data.Text as T 6 | import Intlc.Backend.JavaScript.Language 7 | import Intlc.Core (Backend (..), Dataset, 8 | Locale (Locale), 9 | Translation (backend)) 10 | import qualified Intlc.ICU as ICU 11 | import Prelude 12 | import Utils (apply2, (<>^)) 13 | 14 | type Compiler = Reader Cfg 15 | 16 | -- Allow other compilers to leverage this one, overriding only specific parts 17 | -- of it. What's here and in what form is merely ad hoc. 18 | data Overrides = Overrides 19 | { stmtOverride :: Maybe (Text -> Text -> Text) 20 | , matchLitCondOverride :: Maybe (Text -> Text) 21 | } 22 | 23 | emptyOverrides :: Overrides 24 | emptyOverrides = Overrides mempty mempty 25 | 26 | fromOverride :: (Overrides -> Maybe a) -> a -> Compiler a 27 | fromOverride f x = fromMaybe x <$> asks (f . overrides) 28 | 29 | override :: (Overrides -> Maybe (a -> a)) -> a -> Compiler a 30 | override f x = maybe x ($ x) <$> asks (f . overrides) 31 | 32 | data Cfg = Cfg 33 | { locale :: Locale 34 | , interp :: InterpStrat 35 | , overrides :: Overrides 36 | } 37 | 38 | compileStmt :: Overrides -> InterpStrat -> Locale -> Text -> ICU.Message ICU.Node -> Text 39 | compileStmt o s l k m = f' fromKeyedMsg' 40 | where f' = flip runReader (Cfg l s o) . stmt 41 | fromKeyedMsg' = runReader (fromKeyedMsg k m) l 42 | 43 | data InterpStrat 44 | = TemplateLit 45 | | JSX 46 | 47 | data Interp = Interp 48 | { open :: Text 49 | , close :: Text 50 | , interpOpen :: Text 51 | , interpClose :: Text 52 | } 53 | 54 | fromStrat :: InterpStrat -> Interp 55 | fromStrat TemplateLit = Interp 56 | { open = "`" 57 | , close = "`" 58 | , interpOpen = "${" 59 | , interpClose = "}" 60 | } 61 | fromStrat JSX = Interp 62 | { open = "<>" 63 | , close = "" 64 | , interpOpen = "{" 65 | , interpClose = "}" 66 | } 67 | 68 | -- | Everything shares a single argument object whence we can access 69 | -- interpolations. 70 | argName :: Text 71 | argName = "x" 72 | 73 | prop :: ICU.Arg -> Text 74 | prop (ICU.Arg x) = argName <> "." <> x 75 | 76 | wrap :: Text -> Compiler Text 77 | wrap x = do 78 | (o, c) <- asks ((open &&& close) . fromStrat . interp) 79 | pure $ o <> x <> c 80 | 81 | interpc :: Text -> Compiler Text 82 | interpc x = do 83 | (o, c) <- asks ((interpOpen &&& interpClose) . fromStrat . interp) 84 | pure $ o <> x <> c 85 | 86 | stmt :: Stmt -> Compiler Text 87 | stmt (Stmt n xs) = do 88 | r <- wrap =<< exprs xs 89 | (fmap (apply2 n r) . stmtOverride) `fromOverride` ("export const " <> n <> " = " <> r) 90 | 91 | exprs :: Foldable f => f Expr -> Compiler Text 92 | exprs = foldMapM expr 93 | 94 | expr :: Expr -> Compiler Text 95 | expr (TPrint x) = asks interp <&> \case 96 | TemplateLit -> T.concatMap escape x 97 | _ -> x 98 | where escape '`' = "\\`" 99 | escape c = T.singleton c 100 | expr (TStr x) = interpc (prop x) 101 | expr (TNum x) = do 102 | (Locale l) <- asks locale 103 | interpc $ "new Intl.NumberFormat('" <> l <> "').format(" <> prop x <> ")" 104 | expr (TDate x fmt) = interpc =<< date x fmt 105 | expr (TTime x fmt) = interpc =<< time x fmt 106 | expr (TApply x ys) = interpc =<< apply x ys 107 | expr (TMatch x) = interpc =<< match x 108 | 109 | apply :: ICU.Arg -> [Expr] -> Compiler Text 110 | apply x ys = pure (prop x <> "(") <>^ (wrap =<< exprs ys) <>^ pure ")" 111 | 112 | match :: Match -> Compiler Text 113 | match = fmap iife . go where 114 | go (Match n c m) = case m of 115 | LitMatchRet bs -> switch <$> cond <*> branches bs 116 | NonLitMatchRet bs w -> switch <$> cond <*> wildBranches bs w 117 | RecMatchRet bs m' -> switch <$> cond <*> recBranches bs (go m') 118 | where cond = matchCond n c 119 | iife x = "(() => { " <> x <> " })()" 120 | switch x ys = "switch (" <> x <> ") { " <> ys <> " }" 121 | branches xs = concatBranches . toList <$> mapM branch xs 122 | where branch (Branch x ys) = pure ("case " <> x <> ": return ") <>^ (wrap =<< exprs ys) <>^ pure ";" 123 | concatBranches = unwords 124 | wildBranches xs w = (<>) <$> branches xs <*> ((" " <>) <$> wildcard w) 125 | where wildcard (Wildcard xs') = pure "default: return " <>^ (wrap =<< exprs xs') <>^ pure ";" 126 | recBranches xs y = (<>) <$> branches xs <*> ((" " <>) . nest <$> y) 127 | where nest x = "default: { " <> x <> " }" 128 | 129 | matchCond :: ICU.Arg -> MatchCond -> Compiler Text 130 | matchCond n LitCond = override matchLitCondOverride (prop n) 131 | matchCond n CardinalPluralRuleCond = f <$> asks locale 132 | where f (Locale l) = "new Intl.PluralRules('" <> l <> "').select(" <> prop n <> ")" 133 | matchCond n OrdinalPluralRuleCond = f <$> asks locale 134 | where f (Locale l) = "new Intl.PluralRules('" <> l <> "', { type: 'ordinal' }).select(" <> prop n <> ")" 135 | 136 | date :: ICU.Arg -> ICU.DateTimeFmt -> Compiler Text 137 | date n d = do 138 | (Locale l) <- asks locale 139 | pure $ "new Intl.DateTimeFormat('" <> l <> "', { dateStyle: '" <> dateTimeFmt d <> "' }).format(" <> prop n <> ")" 140 | 141 | time :: ICU.Arg -> ICU.DateTimeFmt -> Compiler Text 142 | time n d = do 143 | (Locale l) <- asks locale 144 | pure $ "new Intl.DateTimeFormat('" <> l <> "', { timeStyle: '" <> dateTimeFmt d <> "' }).format(" <> prop n <> ")" 145 | 146 | dateTimeFmt :: ICU.DateTimeFmt -> Text 147 | dateTimeFmt ICU.Short = "short" 148 | dateTimeFmt ICU.Medium = "medium" 149 | dateTimeFmt ICU.Long = "long" 150 | dateTimeFmt ICU.Full = "full" 151 | 152 | -- A no-op that clarifies a JS/TS file as an ES module. 153 | emptyModule :: Text 154 | emptyModule = "export {}" 155 | 156 | buildReactImport :: Dataset (Translation a) -> Maybe Text 157 | buildReactImport = flip pureIf text . any ((TypeScriptReact ==) . backend) 158 | where text = "import type { ReactElement } from 'react'" 159 | 160 | validateKey :: Text -> Either Text () 161 | validateKey k 162 | | T.null k = Left "[Empty identifier found.]" 163 | | k `elem` reservedWords = Left $ k <> ": reserved word." 164 | | not (isValidIdent (T.unpack k)) = Left $ k <> ": invalid identifier." 165 | | otherwise = Right () 166 | -- https://developer.mozilla.org/en-US/docs/Glossary/identifier 167 | where isValidIdent [] = False -- Technically already caught by `T.null`. 168 | isValidIdent (c:cs) = isValidIdentHeadChar c && all isValidIdentTailChar cs 169 | isValidIdentHeadChar = liftA2 (||) isAlpha (`elem` ['$', '_']) 170 | isValidIdentTailChar = liftA2 (||) isValidIdentHeadChar isDigit 171 | 172 | -- Useful docs: 173 | -- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar#keywords 174 | reservedWords :: [Text] 175 | reservedWords = es2015 <> future <> module' <> legacy <> literals where 176 | es2015 = 177 | [ "break" 178 | , "case" 179 | , "catch" 180 | , "class" 181 | , "const" 182 | , "continue" 183 | , "debugger" 184 | , "default" 185 | , "delete" 186 | , "do" 187 | , "else" 188 | , "export" 189 | , "extends" 190 | , "finally" 191 | , "for" 192 | , "function" 193 | , "if" 194 | , "import" 195 | , "in" 196 | , "instanceof" 197 | , "new" 198 | , "return" 199 | , "super" 200 | , "switch" 201 | , "this" 202 | , "throw" 203 | , "try" 204 | , "typeof" 205 | , "var" 206 | , "void" 207 | , "while" 208 | , "with" 209 | , "yield" 210 | ] 211 | future = 212 | [ "enum" 213 | , "implements" 214 | , "interface" 215 | , "let" 216 | , "package" 217 | , "private" 218 | , "protected" 219 | , "public" 220 | , "static" 221 | , "yield" 222 | ] 223 | module' = 224 | [ "await" 225 | ] 226 | legacy = 227 | [ "abstract" 228 | , "boolean" 229 | , "byte" 230 | , "char" 231 | , "double" 232 | , "final" 233 | , "float" 234 | , "goto" 235 | , "int" 236 | , "long" 237 | , "native" 238 | , "short" 239 | , "synchronized" 240 | , "throws" 241 | , "transient" 242 | , "volatile" 243 | ] 244 | literals = 245 | [ "null" 246 | , "true" 247 | , "false" 248 | ] 249 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/JavaScript/Language.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Backend.JavaScript.Language where 2 | 3 | import Data.Functor.Foldable (cataA) 4 | import qualified Data.Text as T 5 | import Intlc.Core (Locale) 6 | import qualified Intlc.ICU as ICU 7 | import Prelude 8 | import Utils ((<>^)) 9 | 10 | type ASTCompiler = Reader Locale 11 | 12 | -- | A representation of the output we will be compiling. It's a little verbose 13 | -- split into these various sum types, but in doing so it's correct by 14 | -- construction. 15 | data Stmt = Stmt Text [Expr] 16 | deriving (Show, Eq) 17 | 18 | data Expr 19 | = TPrint Text 20 | | TStr ICU.Arg 21 | | TNum ICU.Arg 22 | | TDate ICU.Arg ICU.DateTimeFmt 23 | | TTime ICU.Arg ICU.DateTimeFmt 24 | | TApply ICU.Arg [Expr] 25 | | TMatch Match 26 | deriving (Show, Eq) 27 | 28 | data Match = Match ICU.Arg MatchCond MatchRet 29 | deriving (Show, Eq) 30 | 31 | data MatchCond 32 | = LitCond 33 | | CardinalPluralRuleCond 34 | | OrdinalPluralRuleCond 35 | deriving (Show, Eq) 36 | 37 | data MatchRet 38 | = LitMatchRet (NonEmpty Branch) 39 | | NonLitMatchRet [Branch] Wildcard 40 | | RecMatchRet (NonEmpty Branch) Match 41 | deriving (Show, Eq) 42 | 43 | data Branch = Branch Text [Expr] 44 | deriving (Show, Eq) 45 | 46 | newtype Wildcard = Wildcard [Expr] 47 | deriving (Show, Eq) 48 | 49 | fromKeyedMsg :: Text -> ICU.Message ICU.Node -> ASTCompiler Stmt 50 | fromKeyedMsg n (ICU.Message x) = Stmt n <$> fromNode x 51 | 52 | fromNode :: ICU.Node -> ASTCompiler [Expr] 53 | fromNode = cataA $ \case 54 | ICU.Fin -> pure mempty 55 | (ICU.Char c x) -> pure (pure (TPrint (T.singleton c))) <>^ x 56 | (ICU.Bool { ICU.arg, ICU.trueCase, ICU.falseCase, ICU.next }) -> do 57 | l <- fromBoolCase True trueCase 58 | r <- fromBoolCase False falseCase 59 | let start = TMatch . Match arg LitCond . LitMatchRet $ l :| [r] 60 | pure (pure start) <>^ next 61 | (ICU.String n x) -> pure (pure (TStr n)) <>^ x 62 | (ICU.Number n x) -> pure (pure (TNum n)) <>^ x 63 | (ICU.Date n x y) -> pure (pure (TDate n x)) <>^ y 64 | (ICU.Time n x y) -> pure (pure (TTime n x)) <>^ y 65 | (ICU.CardinalExact n lcs x) -> (pure . TMatch . Match n LitCond . LitMatchRet <$> (fromExactPluralCase `mapM` lcs)) <>^ x 66 | (ICU.CardinalInexact n lcs [] w x) -> (pure . TMatch . Match n LitCond <$> ret) <>^ x 67 | where ret = NonLitMatchRet <$> (fromExactPluralCase `mapM` lcs) <*> (Wildcard <$> w) 68 | (ICU.CardinalInexact n [] rcs w x) -> (pure . TMatch . Match n CardinalPluralRuleCond <$> ret) <>^ x 69 | where ret = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> (Wildcard <$> w) 70 | (ICU.CardinalInexact n (lc:lcs) rcs w x) -> (pure . TMatch . Match n LitCond <$> litRet) <>^ x 71 | where litRet = RecMatchRet <$> (fromExactPluralCase `mapM` lcs') <*> (Match n CardinalPluralRuleCond <$> ruleRet) 72 | ruleRet = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> (Wildcard <$> w) 73 | lcs' = lc :| lcs 74 | (ICU.Ordinal n [] rcs w x) -> (pure . TMatch . Match n OrdinalPluralRuleCond <$> m) <>^ x 75 | where m = NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> (Wildcard <$> w) 76 | (ICU.Ordinal n (lc:lcs) rcs w x) -> (pure . TMatch . Match n LitCond <$> m) <>^ x 77 | where m = RecMatchRet <$> ((:|) <$> fromExactPluralCase lc <*> (fromExactPluralCase `mapM` lcs)) <*> im 78 | im = Match n OrdinalPluralRuleCond <$> (NonLitMatchRet <$> (fromRulePluralCase `mapM` rcs) <*> (Wildcard <$> w)) 79 | (ICU.PluralRef n x) -> pure (pure (TNum n)) <>^ x 80 | (ICU.SelectNamed n cs x) -> (pure . TMatch . Match n LitCond . LitMatchRet <$> ret) <>^ x 81 | where ret = fromSelectCase `mapM` cs 82 | (ICU.SelectWild n w x) -> (pure . TMatch . Match n LitCond <$> ret) <>^ x 83 | where ret = NonLitMatchRet mempty <$> (Wildcard <$> w) 84 | (ICU.SelectNamedWild n cs w x) -> (pure . TMatch . Match n LitCond <$> ret) <>^ x 85 | where ret = NonLitMatchRet <$> (toList <$> fromSelectCase `mapM` cs) <*> (Wildcard <$> w) 86 | (ICU.Callback n x y) -> (pure . TApply n <$> x) <>^ y 87 | 88 | fromExactPluralCase :: ICU.PluralCaseF ICU.PluralExact (ASTCompiler [Expr]) -> ASTCompiler Branch 89 | fromExactPluralCase (ICU.PluralExact n, x) = Branch n <$> x 90 | 91 | fromRulePluralCase :: ICU.PluralCaseF ICU.PluralRule (ASTCompiler [Expr]) -> ASTCompiler Branch 92 | fromRulePluralCase (r, x) = Branch (qts matcher) <$> x 93 | where matcher = case r of 94 | ICU.Zero -> "zero" 95 | ICU.One -> "one" 96 | ICU.Two -> "two" 97 | ICU.Few -> "few" 98 | ICU.Many -> "many" 99 | qts y = "'" <> y <> "'" 100 | 101 | fromSelectCase :: ICU.SelectCaseF (ASTCompiler [Expr]) -> ASTCompiler Branch 102 | fromSelectCase (x, y) = Branch ("'" <> x <> "'") <$> y 103 | 104 | fromBoolCase :: Bool -> ASTCompiler [Expr] -> ASTCompiler Branch 105 | fromBoolCase b x = Branch b' <$> x 106 | where b' = if b then "true" else "false" 107 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/TypeScript/Compiler.hs: -------------------------------------------------------------------------------- 1 | -- This module mostly only concerns itself with what the type-level output will 2 | -- look like. The value-level output is JavaScript and resides almost entirely 3 | -- in the corresponding module. They have been written with one-another in mind. 4 | 5 | module Intlc.Backend.TypeScript.Compiler (compileNamedExport, compileTypeof, validateKey) where 6 | 7 | import Data.Functor.Foldable (project) 8 | import qualified Data.Map as M 9 | import qualified Data.Text as T 10 | import Intlc.Backend.JavaScript.Compiler (InterpStrat (..)) 11 | import qualified Intlc.Backend.JavaScript.Compiler as JS 12 | import Intlc.Backend.TypeScript.Language 13 | import Intlc.Core 14 | import qualified Intlc.ICU as ICU 15 | import Prelude 16 | import Utils ((<>^)) 17 | 18 | compileNamedExport :: InterpStrat -> Locale -> Text -> ICU.Message ICU.Node -> Text 19 | compileNamedExport s l k v = JS.compileStmt o s l k v 20 | where o = JS.emptyOverrides { JS.stmtOverride = Just stmt, JS.matchLitCondOverride = Just matchLitCond } 21 | stmt n r = "export const " <> n <> ": " <> compileTypeof s v <> " = " <> arg <> " => " <> r 22 | -- Prevents TypeScript from narrowing, which absent this causes some 23 | -- nested switch output to fail typechecking. 24 | matchLitCond x = x <> " as typeof " <> x 25 | arg = if hasInterpolations (ICU.unMessage v) then "x" else "()" 26 | hasInterpolations = project >>> \case 27 | ICU.Fin -> False 28 | (ICU.Char _ n) -> hasInterpolations n 29 | _ -> True 30 | 31 | compileTypeof :: InterpStrat -> ICU.Message ICU.Node -> Text 32 | compileTypeof x = let o = fromStrat x in flip runReader o . typeof . fromMsg o 33 | 34 | fromStrat :: InterpStrat -> Out 35 | fromStrat TemplateLit = TTemplate 36 | fromStrat JSX = TFragment 37 | 38 | type Compiler = Reader Out 39 | 40 | -- The parameter name is functionally irrelevant in TypeScript type signatures. 41 | argName :: Text 42 | argName = "x" 43 | 44 | union :: Foldable f => f Text -> Text 45 | union = T.intercalate " | " . toList 46 | 47 | typeof :: TypeOf -> Compiler Text 48 | typeof (Lambda as r) = lambda as r 49 | 50 | lambda :: Args -> Out -> Compiler Text 51 | lambda as r = args as <>^ pure " => " <>^ out r 52 | 53 | args :: Args -> Compiler Text 54 | args xs 55 | | M.null xs = pure "()" 56 | | otherwise = do 57 | y <- fmap (T.intercalate "; " . M.elems) . M.traverseWithKey arg $ xs 58 | pure $ "(" <> argName <> ": { " <> y <> " })" 59 | where arg (ICU.Arg k) (v :| []) = ((k <> ": ") <>) <$> in' v 60 | arg (ICU.Arg k) vs = ((k <> ": ") <>) . intersect . toList <$> ins `mapM` vs 61 | -- Unions with at least two members need wrapping in disambiguating 62 | -- parentheses, other types do not. 63 | ins x 64 | | isMultiUnion x = parens <$> in' x 65 | | otherwise = in' x 66 | intersect = T.intercalate " & " 67 | parens x = "(" <> x <> ")" 68 | 69 | in' :: In -> Compiler Text 70 | in' TStr = pure "string" 71 | in' (TStrLitUnion xs) = pure . union $ qts <$> xs 72 | where qts x = "'" <> x <> "'" 73 | in' (TNumLitUnion xs) = pure . union $ xs 74 | in' TNum = pure "number" 75 | in' TBool = pure "boolean" 76 | in' TDate = pure "Date" 77 | in' TEndo = endo 78 | 79 | out :: Out -> Compiler Text 80 | out TTemplate = pure "string" 81 | out TFragment = pure "ReactElement" 82 | 83 | endo :: Compiler Text 84 | endo = do 85 | x <- out =<< ask 86 | pure $ "(" <> argName <> ": " <> x <> ") => " <> x 87 | 88 | -- Words like `namespace` and `type` aren't reserved at the value-level. `enum` 89 | -- is already reserved in JS spec. As such, we can directly reuse JS key 90 | -- validation. 91 | validateKey :: Text -> Either Text () 92 | validateKey = JS.validateKey 93 | -------------------------------------------------------------------------------- /lib/Intlc/Backend/TypeScript/Language.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Backend.TypeScript.Language where 2 | 3 | import Data.Functor.Foldable (cata) 4 | import Data.List.NonEmpty (nub) 5 | import qualified Data.Map as M 6 | import qualified Intlc.ICU as ICU 7 | import Prelude 8 | 9 | -- | A representation of the type-level output we will be compiling. It's a 10 | -- little verbose split into these various sum types, but in doing so it's 11 | -- correct by construction. 12 | data TypeOf = Lambda Args Out 13 | deriving (Show, Eq) 14 | 15 | type UncollatedArgs = [(ICU.Arg, In)] 16 | type Args = Map ICU.Arg (NonEmpty In) 17 | 18 | data In 19 | = TStr 20 | | TStrLitUnion (NonEmpty Text) 21 | | TNumLitUnion (NonEmpty Text) 22 | | TNum 23 | | TBool 24 | | TDate 25 | -- An endomorphism on `Out`. Omitted as an argument to enforce that it's the 26 | -- same type as the output of the top-level `Lambda`. 27 | | TEndo 28 | deriving (Show, Eq) 29 | 30 | data Out 31 | = TTemplate 32 | | TFragment 33 | deriving (Show, Eq) 34 | 35 | isMultiUnion :: In -> Bool 36 | isMultiUnion (TStrLitUnion xs) = length xs > 1 37 | isMultiUnion (TNumLitUnion xs) = length xs > 1 38 | isMultiUnion _ = False 39 | 40 | -- Collate arguments with the same name. 41 | collateArgs :: UncollatedArgs -> Args 42 | collateArgs = fmap nub . M.fromListWith (<>) . fmap (second pure) 43 | 44 | fromMsg :: Out -> ICU.Message ICU.Node -> TypeOf 45 | fromMsg x (ICU.Message y) = Lambda (collateArgs . fromNode $ y) x 46 | 47 | fromNode :: ICU.Node -> UncollatedArgs 48 | fromNode = cata $ (maybeToList . marg) <> fold 49 | 50 | marg :: ICU.NodeF a -> Maybe (ICU.Arg, In) 51 | marg = \case 52 | ICU.Bool n _ _ _ -> pure (n, TBool) 53 | ICU.String n _ -> pure (n, TStr) 54 | ICU.Number n _ -> pure (n, TNum) 55 | ICU.Date n _ _ -> pure (n, TDate) 56 | ICU.Time n _ _ -> pure (n, TDate) 57 | -- We can compile exact cardinal plurals (i.e. those without a wildcard) to a 58 | -- union of number literals. 59 | ICU.CardinalExact n ls _ -> pure (n, TNumLitUnion (caseLit <$> ls)) 60 | where caseLit (ICU.PluralExact y, _) = y 61 | ICU.CardinalInexact n _ _ _ _ -> pure (n, TNum) 62 | ICU.Ordinal n _ _ _ _ -> pure (n, TNum) 63 | ICU.SelectWild n _ _ -> pure (n, TStr) 64 | ICU.SelectNamedWild n _ _ _ -> pure (n, TStr) 65 | -- When there's no wildcard case we can compile to a union of string literals. 66 | ICU.SelectNamed n cs _ -> pure (n, TStrLitUnion (fst <$> cs)) 67 | ICU.Callback n _ _ -> pure (n, TEndo) 68 | -- Plural references are treated as a no-op. 69 | _ -> empty 70 | -------------------------------------------------------------------------------- /lib/Intlc/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Compiler (compileDataset, compileToJSON, flatten, expandPlurals, expandRules) where 2 | 3 | import Data.Foldable (elem) 4 | import Data.Functor.Foldable (cata, embed, project) 5 | import Data.List.Extra (unionBy) 6 | import qualified Data.Map as M 7 | import qualified Data.Text as T 8 | import Intlc.Backend.JavaScript.Compiler as JS 9 | import qualified Intlc.Backend.JSON.Compiler as JSON 10 | import qualified Intlc.Backend.TypeScript.Compiler as TS 11 | import Intlc.Core 12 | import qualified Intlc.ICU as ICU 13 | import Prelude hiding (elem) 14 | 15 | compileDataset :: Locale -> Dataset (Translation (ICU.Message ICU.Node)) -> Either (NonEmpty Text) Text 16 | compileDataset l d = validateKeys d $> 17 | case stmts of 18 | [] -> JS.emptyModule 19 | stmts' -> T.intercalate "\n" stmts' 20 | where stmts = imports <> exports 21 | imports = maybeToList $ JS.buildReactImport d 22 | -- We'll `foldr` with `mempty`, avoiding `mconcat`, to preserve 23 | -- insertion order. 24 | exports = M.foldrWithKey buildCompiledTranslations mempty d 25 | buildCompiledTranslations k v acc = compileTranslation l k v : acc 26 | 27 | validateKeys :: Dataset (Translation (ICU.Message ICU.Node)) -> Either (NonEmpty Text) () 28 | validateKeys = toEither . lefts . fmap (uncurry validate) . M.toList 29 | where toEither [] = Right () 30 | toEither (e:es) = Left $ e :| es 31 | validate k t = k & case backend t of 32 | TypeScript -> TS.validateKey 33 | TypeScriptReact -> TS.validateKey 34 | 35 | compileTranslation :: Locale -> Text -> Translation (ICU.Message ICU.Node) -> Text 36 | compileTranslation l k (Translation v be _) = case be of 37 | TypeScript -> TS.compileNamedExport TemplateLit l k v 38 | TypeScriptReact -> TS.compileNamedExport JSX l k v 39 | 40 | compileToJSON :: (ICU.Node -> ICU.Node) -> JSON.Formatting -> Dataset (Translation (ICU.Message ICU.Node)) -> Text 41 | compileToJSON f fmt = JSON.compileDataset fmt . mapMsgs (fmap f) 42 | 43 | mapMsgs :: (ICU.Message ICU.Node -> ICU.Message ICU.Node) -> Dataset (Translation (ICU.Message ICU.Node)) -> Dataset (Translation (ICU.Message ICU.Node)) 44 | mapMsgs f = fmap $ \x -> x { message = f x.message } 45 | 46 | 47 | -- | Recursively push a @Callback@ inside interpolations. 48 | -- 49 | -- __Example:__ 50 | -- 51 | -- @ 52 | -- pushCallbackInInterp n (SelectNamedWild' n' b c) = SelectNamedWild' n' (Callback' n b) (Callback' n c) 53 | -- @ 54 | pushCallbackInInterp :: ICU.Arg -> ICU.Node -> ICU.Node 55 | pushCallbackInInterp n body = 56 | let rec = pushCallbackInInterp n in 57 | case project body of 58 | ICU.Bool n' x y _ -> ICU.Bool' n' (rec x) (rec y) 59 | ICU.CardinalExact n' xs _ -> ICU.CardinalExact' n' (mapPluralCase rec <$> xs) 60 | ICU.CardinalInexact n' xs ys w _ -> ICU.CardinalInexact' n' (mapPluralCase rec <$> xs) (mapPluralCase rec <$> ys) (rec w) 61 | ICU.Ordinal n' xs ys w _ -> ICU.Ordinal' n' (mapPluralCase rec <$> xs) (mapPluralCase rec <$> ys) (rec w) 62 | ICU.SelectNamed n' xs _ -> ICU.SelectNamed' n' (mapPluralCase rec <$> xs) 63 | ICU.SelectWild n' w _ -> ICU.SelectWild' n' (rec w) 64 | ICU.SelectNamedWild n' xs w _ -> ICU.SelectNamedWild' n' (mapPluralCase rec <$> xs) (rec w) 65 | _ -> ICU.Callback' n body 66 | 67 | flatten :: ICU.Node -> ICU.Node 68 | flatten = go True mempty 69 | where go :: Bool -> ICU.Node -> ICU.Node -> ICU.Node 70 | go shouldFlattenCallback prev rest = 71 | let (curr, mnext) = ICU.sever rest 72 | next = fold mnext 73 | rec mid = go shouldFlattenCallback (embed ICU.Fin) (prev <> mid <> next) 74 | in case project curr of 75 | ICU.Fin -> prev 76 | ICU.Bool n x y _ -> ICU.Bool' n (rec x) (rec y) 77 | ICU.CardinalExact n xs _ -> ICU.CardinalExact' n (mapPluralCase rec <$> xs) 78 | ICU.CardinalInexact n xs ys w _ -> ICU.CardinalInexact' n (mapPluralCase rec <$> xs) (mapPluralCase rec <$> ys) (rec w) 79 | ICU.Ordinal n xs ys w _ -> ICU.Ordinal' n (mapPluralCase rec <$> xs) (mapPluralCase rec <$> ys) (rec w) 80 | ICU.SelectNamed n xs _ -> ICU.SelectNamed' n (mapSelectCase rec <$> xs) 81 | ICU.SelectWild n w _ -> ICU.SelectWild' n (rec w) 82 | ICU.SelectNamedWild n xs w _ -> ICU.SelectNamedWild' n (mapSelectCase rec <$> xs) (rec w) 83 | ICU.Callback n body _ | shouldFlattenCallback -> 84 | -- We flatten the body of the callback before calling `pushCallbackInInterp` 85 | -- so that interpolations have been hoisted and thus easy to extract. 86 | -- Once extracted, we call `go` on the resulting node in order for the 87 | -- extracted interpolations to be correctly flattened. We must temporarily 88 | -- disable callback flattening because the next callback that would be 89 | -- flattened is the already flattened callback that's been pushed into the 90 | -- extracted interpolations. 91 | go False prev (pushCallbackInInterp n (flatten body) <> next) 92 | _ -> go True (prev <> curr) next 93 | 94 | 95 | -- Expands any plural with a rule to contain every rule. This makes ICU plural 96 | -- syntax usable on platforms which don't support ICU; translators can reuse 97 | -- copy across unneeded plural rules. 98 | -- 99 | -- Added plural rules inherit the content of the wildcard. Output order of 100 | -- rules is unspecified. 101 | expandPlurals :: ICU.Node -> ICU.Node 102 | expandPlurals = cata (embed . f) 103 | where f (ICU.CardinalInexact n exacts rules w y) = 104 | ICU.CardinalInexact n exacts (toList $ expandRules rules w) w y 105 | f (ICU.Ordinal n exacts rules w y) = 106 | ICU.Ordinal n exacts (toList $ expandRules rules w) w y 107 | f y = y 108 | 109 | expandRules :: (Functor f, Foldable f) => f (ICU.PluralCase ICU.PluralRule) -> ICU.Node -> NonEmpty (ICU.PluralCase ICU.PluralRule) 110 | -- `fromList` is a cheap way to promise the compiler that we'll return a 111 | -- non-empty list. This is logically guaranteed by one of the inputs to 112 | -- `unionBy` being non-empty, namely `extraCases` - though given the complexity 113 | -- this is unit tested for confidence. 114 | expandRules ys w = fromList $ unionBy ((==) `on` caseRule) (toList ys) extraCases 115 | where extraCases = (, w) <$> missingRules 116 | missingRules = filter (not . flip elem presentRules) allRules 117 | presentRules = caseRule <$> ys 118 | allRules = universe 119 | caseRule (x, _) = x 120 | 121 | mapSelectCase :: (a -> a) -> ICU.SelectCaseF a -> ICU.SelectCaseF a 122 | mapSelectCase = second 123 | 124 | mapPluralCase :: (b -> b) -> ICU.PluralCaseF a b -> ICU.PluralCaseF a b 125 | mapPluralCase = second 126 | -------------------------------------------------------------------------------- /lib/Intlc/Core.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Core where 2 | 3 | import Intlc.ICU (AnnNode, Message, Node, sansAnn) 4 | import Prelude 5 | 6 | -- Locales are too broad and too much of a moving target to validate, so this 7 | -- is a source of unsafety for consumers. 8 | newtype Locale = Locale Text 9 | deriving (Show, Eq) 10 | 11 | type UnparsedMessage = Text 12 | 13 | data Backend 14 | = TypeScript 15 | | TypeScriptReact 16 | deriving (Show, Eq, Generic) 17 | 18 | data Translation a = Translation 19 | { message :: a 20 | , backend :: Backend 21 | , mdesc :: Maybe Text 22 | } 23 | deriving (Show, Eq) 24 | 25 | type Dataset = Map Text 26 | 27 | datasetSansAnn :: Dataset (Translation (Message AnnNode)) -> Dataset (Translation (Message Node)) 28 | datasetSansAnn = fmap translationSansAnn 29 | 30 | translationSansAnn :: Translation (Message AnnNode) -> Translation (Message Node) 31 | translationSansAnn x = x { message = sansAnn <$> x.message } 32 | -------------------------------------------------------------------------------- /lib/Intlc/Error.hs: -------------------------------------------------------------------------------- 1 | -- We reuse Megaparsec's infrastructure to format arbitrary application errors 2 | -- with source annotations. 3 | 4 | module Intlc.Error (WithAnn, fmt) where 5 | 6 | import qualified Data.Text as T 7 | import Prelude 8 | import Text.Megaparsec 9 | import Text.Megaparsec.Error.Builder 10 | 11 | type WithAnn a = (Int, a) 12 | 13 | fmt :: ShowErrorComponent a => FilePath -> Text -> NonEmpty (WithAnn a) -> Text 14 | fmt path content lints = T.pack $ errorBundlePretty (buildParseErrBundle path content lints) 15 | 16 | buildParseErrBundle :: FilePath -> Text -> NonEmpty (WithAnn a) -> ParseErrorBundle Text a 17 | buildParseErrBundle path content lints = ParseErrorBundle (buildParseErr <$> lints) (buildPosState path content) 18 | 19 | buildParseErr :: WithAnn a -> ParseError Text a 20 | buildParseErr (i, x) = errFancy i . fancy . ErrorCustom $ x 21 | 22 | -- This could probably be rewritten to be more efficient. 23 | buildPosState :: FilePath -> Text -> PosState Text 24 | buildPosState path content = PosState content 0 (initialPos path) defaultTabWidth mempty 25 | -------------------------------------------------------------------------------- /lib/Intlc/ICU.hs: -------------------------------------------------------------------------------- 1 | -- This module defines an AST for ICU messages. We do not necessarily behave 2 | -- identically to other implementations. 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Intlc.ICU where 7 | 8 | import Control.Comonad.Cofree (Cofree) 9 | import Control.Comonad.Trans.Cofree (CofreeF ((:<))) 10 | import Data.Eq.Deriving (deriveEq1) 11 | import Data.Fix (Fix (Fix)) 12 | import Data.Functor.Foldable (cata, embed, project) 13 | import Prelude 14 | import Text.Show.Deriving (deriveShow1) 15 | 16 | newtype Message a = Message a 17 | deriving (Show, Eq, Functor) 18 | 19 | unMessage :: Message a -> a 20 | unMessage (Message x) = x 21 | 22 | newtype Arg = Arg Text 23 | deriving (Show, Eq, Ord, IsString) 24 | 25 | unArg :: Arg -> Text 26 | unArg (Arg x) = x 27 | 28 | -- | A `NodeF` is either an interpolation - some sort of identifier for input - 29 | -- or mere plaintext. A collection of nodes make up any message. The entire AST 30 | -- is represented as a single recursive node with the trailing `NodeF` always 31 | -- representing the following sibling. Termination is represented by `Fin`, 32 | -- equivalent to a list's `Nil`. 33 | -- 34 | -- On interpolations we diverge from icu4j by supporting a boolean type, and 35 | -- not necessarily requiring wildcard cases. 36 | -- 37 | -- This core type is represented as a "pattern functor". Useful for recursion 38 | -- schemes and pairing additional data to nodes via the likes of `Cofree`. 39 | data NodeF a 40 | = Fin 41 | | Char 42 | { char :: Char 43 | , next :: a 44 | } 45 | | Bool 46 | { arg :: Arg 47 | , trueCase :: a 48 | , falseCase :: a 49 | , next :: a 50 | } 51 | | String 52 | { arg :: Arg 53 | , next :: a 54 | } 55 | | Number 56 | { arg :: Arg 57 | , next :: a 58 | } 59 | | Date 60 | { arg :: Arg 61 | , format :: DateTimeFmt 62 | , next :: a 63 | } 64 | | Time 65 | { arg :: Arg 66 | , format :: DateTimeFmt 67 | , next :: a 68 | } 69 | -- The only cardinal plurals which do not require a wildcard are those 70 | -- consisting solely of literal/exact cases. This is because within the AST we 71 | -- only care about correctness and prospective type safety, not optimal use of 72 | -- ICU syntax. 73 | | CardinalExact 74 | { arg :: Arg 75 | , exactCasesNE :: NonEmpty (PluralCaseF PluralExact a) 76 | , next :: a 77 | } 78 | | CardinalInexact 79 | { arg :: Arg 80 | , exactCases :: [PluralCaseF PluralExact a] 81 | , ruleCases :: [PluralCaseF PluralRule a] 82 | , wildcard :: a 83 | , next :: a 84 | } 85 | -- Ordinal plurals always require a wildcard as per their intended usage with 86 | -- rules, however as with the cardinal plural type we'll allow a wider set of 87 | -- suboptimal usages that we can then lint against. 88 | | Ordinal 89 | { arg :: Arg 90 | , exactCases :: [PluralCaseF PluralExact a] 91 | , ruleCases :: [PluralCaseF PluralRule a] 92 | , wildcard :: a 93 | , next :: a 94 | } 95 | -- Plural hash references have their own distinct type rather than merely 96 | -- taking on `Number` to allow compilers to infer appropriately. 97 | | PluralRef 98 | { arg :: Arg 99 | , next :: a 100 | } 101 | | SelectNamed 102 | { arg :: Arg 103 | , selectCases :: NonEmpty (SelectCaseF a) 104 | , next :: a 105 | } 106 | | SelectWild 107 | { arg :: Arg 108 | , wildcard :: a 109 | , next :: a 110 | } 111 | | SelectNamedWild 112 | { arg :: Arg 113 | , selectCases :: NonEmpty (SelectCaseF a) 114 | , wildcard :: a 115 | , next :: a 116 | } 117 | | Callback 118 | { arg :: Arg 119 | , child :: a 120 | , next :: a 121 | } 122 | deriving (Show, Eq, Functor, Foldable, Traversable, Generic) 123 | 124 | -- | `NodeF` recursing on itself, forming a typical, simple AST. By convention 125 | -- `Fix` won't generally be referenced directly, with code instead leaning on 126 | -- recursion schemes' `project` and `embed`, which themselves are implemented 127 | -- for `Fix`. 128 | type Node = Fix NodeF 129 | 130 | -- | A `Node` annotated with an `Int` representing a source offset. 131 | type AnnNode = Cofree NodeF Int 132 | 133 | -- | Drop all annotations from an AST/`Node`. 134 | sansAnn :: AnnNode -> Node 135 | -- Explanation: https://stackoverflow.com/a/51050171/3369753 136 | sansAnn = cata $ \(_ :< x) -> embed x 137 | 138 | -- Concatenating two `NodeF Node`s places the second at the tail of the first: 139 | -- Char 'a' Fin <> Char 'b' (Char 'c' Fin) = Char 'a' (Char 'b' (Char 'c' Fin)) 140 | -- 141 | -- This is equivalent to what concatenation would look like if the sibling 142 | -- parameter in `Node`'s constructors were removed and replaced with a list. 143 | instance Semigroup (NodeF Node) where 144 | l <> r = case l of 145 | Fin -> r 146 | Char c l' -> Char c (l' `fconcat` r) 147 | Bool n t f l' -> Bool n t f (l' `fconcat` r) 148 | String n l' -> String n (l' `fconcat` r) 149 | Number n l' -> Number n (l' `fconcat` r) 150 | Date n f l' -> Date n f (l' `fconcat` r) 151 | Time n f l' -> Time n f (l' `fconcat` r) 152 | CardinalExact n pe l' -> CardinalExact n pe (l' `fconcat` r) 153 | CardinalInexact n pe pr w l' -> CardinalInexact n pe pr w (l' `fconcat` r) 154 | Ordinal n pe pr w l' -> Ordinal n pe pr w (l' `fconcat` r) 155 | PluralRef n l' -> PluralRef n (l' `fconcat` r) 156 | SelectNamed n c l' -> SelectNamed n c (l' `fconcat` r) 157 | SelectWild n w l' -> SelectWild n w (l' `fconcat` r) 158 | SelectNamedWild n c w l' -> SelectNamedWild n c w (l' `fconcat` r) 159 | Callback n c l' -> Callback n c (l' `fconcat` r) 160 | where fconcat x y = embed $ project x <> y 161 | 162 | instance Semigroup Node where 163 | l <> r = embed (project l <> project r) 164 | 165 | instance Monoid (NodeF Node) where 166 | mempty = Fin 167 | 168 | instance Monoid Node where 169 | mempty = embed Fin 170 | 171 | -- "abc" = Char 'a' (Char 'b' (Char 'c' Fin)) 172 | instance IsString Node where 173 | fromString = foldr (\c x -> embed (Char c x)) (embed Fin) 174 | 175 | data DateTimeFmt 176 | = Short 177 | | Medium 178 | | Long 179 | | Full 180 | deriving (Show, Eq) 181 | 182 | type PluralCase a = PluralCaseF a Node 183 | type PluralCaseF a b = (a, b) 184 | 185 | -- `Text` here is our count. It's represented as a string so that we can dump 186 | -- it back out without thinking about converting numeric types across 187 | -- languages. 188 | newtype PluralExact = PluralExact Text 189 | deriving (Show, Eq, IsString) 190 | 191 | -- "Other" is implied in the wildcard. 192 | data PluralRule 193 | = Zero 194 | | One 195 | | Two 196 | | Few 197 | | Many 198 | deriving (Show, Eq, Ord, Enum, Bounded) 199 | 200 | type SelectCase = SelectCaseF Node 201 | type SelectCaseF a = (Text, a) 202 | 203 | -- Use Template Haskell to generate lifted typeclass instances for `NodeF`. 204 | -- Needs to appear after all the type aliases that `NodeF` references are 205 | -- defined. Anything else leaning on these instances must appear after this 206 | -- point. 207 | $(deriveShow1 ''NodeF) 208 | $(deriveEq1 ''NodeF) 209 | 210 | getNext :: NodeF a -> Maybe a 211 | getNext Fin = Nothing 212 | getNext (Char _ x) = Just x 213 | getNext (String _ x) = Just x 214 | getNext (Number _ x) = Just x 215 | getNext (Date _ _ x) = Just x 216 | getNext (Time _ _ x) = Just x 217 | getNext (PluralRef _ x) = Just x 218 | getNext (Bool _ _ _ x) = Just x 219 | getNext (CardinalExact _ _ x) = Just x 220 | getNext (CardinalInexact _ _ _ _ x) = Just x 221 | getNext (Ordinal _ _ _ _ x) = Just x 222 | getNext (SelectNamed _ _ x) = Just x 223 | getNext (SelectWild _ _ x) = Just x 224 | getNext (SelectNamedWild _ _ _ x) = Just x 225 | getNext (Callback _ _ x) = Just x 226 | 227 | -- Pulls out the next node and replaces it, if any, with `Fin`. 228 | sever :: Node -> (Node, Maybe Node) 229 | sever = (sansNext &&& getNext) . project 230 | where sansNext = \case 231 | Fin -> embed Fin 232 | Char c _ -> Char' c 233 | String n _ -> String' n 234 | Number n _ -> Number' n 235 | Date n f _ -> Date' n f 236 | Time n f _ -> Time' n f 237 | PluralRef n _ -> PluralRef' n 238 | Bool n t f _ -> Bool' n t f 239 | CardinalExact n pe _ -> CardinalExact' n pe 240 | CardinalInexact n pe pr w _ -> CardinalInexact' n pe pr w 241 | Ordinal n pe pr w _ -> Ordinal' n pe pr w 242 | SelectNamed n c _ -> SelectNamed' n c 243 | SelectWild n w _ -> SelectWild' n w 244 | SelectNamedWild n c w _ -> SelectNamedWild' n c w 245 | Callback n c _ -> Callback' n c 246 | 247 | -- A series of `Node` constructor aliases which partially apply the sibling as 248 | -- `Fin`. Particularly useful when writing out a large `Node` by hand, for 249 | -- example in tests. 250 | -- 251 | -- It looks like pattern constructors can't make use of some abstractions, hence 252 | -- the direct use of the `Fix` constructor. 253 | pattern Char' :: Char -> Node 254 | pattern Char' c = Fix (Char c (Fix Fin)) 255 | 256 | pattern String' :: Arg -> Node 257 | pattern String' n = Fix (String n (Fix Fin)) 258 | 259 | pattern Number' :: Arg -> Node 260 | pattern Number' n = Fix (Number n (Fix Fin)) 261 | 262 | pattern Date' :: Arg -> DateTimeFmt -> Node 263 | pattern Date' n f = Fix (Date n f (Fix Fin)) 264 | 265 | pattern Time' :: Arg -> DateTimeFmt -> Node 266 | pattern Time' n f = Fix (Time n f (Fix Fin)) 267 | 268 | pattern Bool' :: Arg -> Node -> Node -> Node 269 | pattern Bool' n t f = Fix (Bool n t f (Fix Fin)) 270 | 271 | pattern CardinalExact' :: Arg -> NonEmpty (PluralCase PluralExact) -> Node 272 | pattern CardinalExact' n pe = Fix (CardinalExact n pe (Fix Fin)) 273 | 274 | pattern CardinalInexact' :: Arg -> [PluralCase PluralExact] -> [PluralCase PluralRule] -> Node -> Node 275 | pattern CardinalInexact' n pe pr w = Fix (CardinalInexact n pe pr w (Fix Fin)) 276 | 277 | pattern Ordinal' :: Arg -> [PluralCase PluralExact] -> [PluralCase PluralRule] -> Node -> Node 278 | pattern Ordinal' n pe pr w = Fix (Ordinal n pe pr w (Fix Fin)) 279 | 280 | pattern PluralRef' :: Arg -> Node 281 | pattern PluralRef' n = Fix (PluralRef n (Fix Fin)) 282 | 283 | pattern SelectNamed' :: Arg -> NonEmpty SelectCase -> Node 284 | pattern SelectNamed' n c = Fix (SelectNamed n c (Fix Fin)) 285 | 286 | pattern SelectWild' :: Arg -> Node -> Node 287 | pattern SelectWild' n w = Fix (SelectWild n w (Fix Fin)) 288 | 289 | pattern SelectNamedWild' :: Arg -> NonEmpty SelectCase -> Node -> Node 290 | pattern SelectNamedWild' n c w = Fix (SelectNamedWild n c w (Fix Fin)) 291 | 292 | pattern Callback' :: Arg -> Node -> Node 293 | pattern Callback' n w = Fix (Callback n w (Fix Fin)) 294 | -------------------------------------------------------------------------------- /lib/Intlc/Linter.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Linter where 2 | 3 | import qualified Data.Text as T 4 | 5 | import Control.Comonad (extract) 6 | import Control.Comonad.Trans.Cofree (CofreeF ((:<)), tailF) 7 | import Data.Char (isAscii) 8 | import Data.Functor.Foldable (cata, para) 9 | import Intlc.Backend.ICU.Compiler (pluralExact, pluralRule) 10 | import Intlc.Core 11 | import Intlc.Error (WithAnn) 12 | import qualified Intlc.Error as Err 13 | import Intlc.ICU 14 | import Prelude 15 | import Text.Megaparsec.Error 16 | import Utils (bunBy) 17 | 18 | data LintRuleset 19 | = AllLints 20 | | ExternalLintsOnly 21 | 22 | type AnnLint = WithAnn Lint 23 | 24 | data Lint 25 | = RedundantSelect Arg 26 | | RedundantPlural Arg 27 | | DuplicateSelectCase Arg Text 28 | | DuplicatePluralCase Arg Text 29 | | TooManyInterpolations (NonEmpty Arg) 30 | | InvalidNonAsciiCharacter Char 31 | deriving (Eq,Show, Ord) 32 | 33 | data Status a 34 | = Success 35 | | Failure (NonEmpty a) 36 | deriving (Eq, Show, Functor) 37 | 38 | statusToMaybe :: Status a -> Maybe (NonEmpty a) 39 | statusToMaybe Success = Nothing 40 | statusToMaybe (Failure xs) = Just xs 41 | 42 | maybeToStatus :: Maybe (NonEmpty a) -> Status a 43 | maybeToStatus Nothing = Success 44 | maybeToStatus (Just xs) = Failure xs 45 | 46 | type Rule a = AnnNode -> Maybe (NonEmpty a) 47 | 48 | lintWith :: [Rule a] -> Message AnnNode -> Status a 49 | lintWith rules (Message ast) = maybeToStatus . catNEMaybes . flap rules $ ast 50 | where catNEMaybes :: [Maybe (NonEmpty a)] -> Maybe (NonEmpty a) 51 | catNEMaybes = nonEmpty . foldMap (foldMap toList) 52 | 53 | externalLints :: [Rule AnnLint] 54 | externalLints = 55 | [ redundantSelectRule 56 | , redundantPluralRule 57 | , duplicateSelectCasesRule 58 | , duplicatePluralCasesRule 59 | ] 60 | 61 | internalLints :: [Rule AnnLint] 62 | internalLints = 63 | [ interpolationsRule 64 | , unsupportedUnicodeRule 65 | ] 66 | 67 | lintDataset :: LintRuleset -> FilePath -> Text -> Dataset (Translation (Message AnnNode)) -> Maybe Text 68 | lintDataset lr path content = fmap (Err.fmt path content) . foldMap (statusToMaybe . lint . message) 69 | where lint = lintWith $ case lr of 70 | AllLints -> externalLints <> internalLints 71 | ExternalLintsOnly -> externalLints 72 | 73 | wikify :: Text -> Text -> Text 74 | wikify name content = name <> ": " <> content <> "\n\nLearn more: " <> link 75 | where link = "https://github.com/unsplash/intlc/wiki/Lint-rules-reference#" <> name 76 | 77 | instance ShowErrorComponent Lint where 78 | showErrorComponent = T.unpack . uncurry wikify . (wikiName &&& msg) where 79 | msg = \case 80 | RedundantSelect x -> "Select named `" <> unArg x <> "` is redundant as it only contains a wildcard." 81 | RedundantPlural x -> "Plural named `" <> unArg x <> "` is redundant as it only contains a wildcard." 82 | DuplicateSelectCase x y -> "Select named `" <> unArg x <> "` contains a duplicate case named `" <> y <> "`." 83 | DuplicatePluralCase x y -> "Plural named `" <> unArg x <> "` contains a duplicate `" <> y <> "` case." 84 | TooManyInterpolations xs -> "Multiple \"complex\" non-plural interpolations in the same message are disallowed. Found names: " <> interps 85 | where interps = T.intercalate ", " (fmap (qts . unArg) . toList $ xs) 86 | qts x = "`" <> x <> "`" 87 | InvalidNonAsciiCharacter x -> "Non-ASCII character `" <> T.singleton x <> "` is disallowed." 88 | 89 | wikiName = \case 90 | RedundantSelect {} -> "redundant-select" 91 | RedundantPlural {} -> "redundant-plural" 92 | DuplicateSelectCase {} -> "duplicate-select-case" 93 | DuplicatePluralCase {} -> "duplicate-plural-case" 94 | TooManyInterpolations {} -> "too-many-interpolations" 95 | InvalidNonAsciiCharacter {} -> "invalid-non-ascii-char" 96 | 97 | errorComponentLen = \case 98 | RedundantSelect x -> T.length (unArg x) 99 | RedundantPlural x -> T.length (unArg x) 100 | DuplicateSelectCase _ x -> T.length x 101 | DuplicatePluralCase _ x -> T.length x 102 | TooManyInterpolations {} -> 1 103 | InvalidNonAsciiCharacter {} -> 1 104 | 105 | -- Select interpolations with only wildcards are redundant: they could be 106 | -- replaced with plain string interpolations. 107 | redundantSelectRule :: Rule AnnLint 108 | redundantSelectRule = nonEmpty . idents where 109 | idents = cata $ (maybeToList . mident) <> fold 110 | mident = \case 111 | i :< SelectWild n _ _ -> pure (i + 1, RedundantSelect n) 112 | _ -> empty 113 | 114 | -- Plural interpolations with only wildcards are redundant: they could be 115 | -- replaced with plain number interpolations. 116 | redundantPluralRule :: Rule AnnLint 117 | redundantPluralRule = nonEmpty . idents where 118 | idents = cata $ (maybeToList . mident) <> fold 119 | mident = \case 120 | i :< CardinalInexact n [] [] _ _ -> pure $ f i n 121 | i :< Ordinal n [] [] _ _ -> pure $ f i n 122 | _ -> empty 123 | f i n = (i + 1, RedundantPlural n) 124 | 125 | -- Duplicate case names in select interpolations are redundant. 126 | duplicateSelectCasesRule :: Rule AnnLint 127 | duplicateSelectCasesRule = nonEmpty . cases where 128 | cases = para $ (hereCases . tailF) <> foldMap snd 129 | hereCases = \case 130 | SelectNamed n xs _ -> here n xs 131 | SelectNamedWild n xs _ _ -> here n xs 132 | _ -> mempty 133 | here n = fmap (uncurry (f n) . (caseOffset &&& caseName)) . bunBy ((==) `on` caseName) 134 | where caseName = fst 135 | caseOffset = uncurry calcCaseNameOffset . caseHead 136 | caseHead = second (extract . fst) 137 | f n i x = (i, DuplicateSelectCase n x) 138 | 139 | -- Duplicate cases in plural interpolations are redundant. 140 | duplicatePluralCasesRule :: Rule AnnLint 141 | duplicatePluralCasesRule = nonEmpty . cases where 142 | cases = para $ (hereCases . tailF) <> foldMap snd 143 | hereCases = \case 144 | CardinalExact n ys _ -> here pluralExact n ys 145 | CardinalInexact n ys zs _ _ -> here pluralExact n ys <> here pluralRule n zs 146 | Ordinal n ys zs _ _ -> here pluralExact n ys <> here pluralRule n zs 147 | _ -> mempty 148 | here via n = fmap (uncurry (f n) . (caseOffset &&& (via . caseKey))) . bunBy ((==) `on` caseKey) 149 | where caseKey = fst 150 | caseOffset = uncurry calcCaseNameOffset . first via . caseHead 151 | caseHead = second (extract . fst) 152 | f n i x = (i, DuplicatePluralCase n x) 153 | 154 | -- Our translation vendor has poor support for ICU syntax, and their parser 155 | -- particularly struggles with interpolations. This rule limits the use of a 156 | -- subset of interpolations to one per message. 157 | -- 158 | -- Callbacks and plurals are allowed an unlimited number of times. The former 159 | -- because the vendor's tool has no issues parsing its syntax and the latter 160 | -- because it's a special case that we can't rewrite. 161 | interpolationsRule :: Rule AnnLint 162 | interpolationsRule ast = fmap (pure . (start,)) . count . idents $ ast where 163 | count (x:y:zs) = Just . TooManyInterpolations $ x :| (y:zs) 164 | count _ = Nothing 165 | idents = cata $ (maybeToList . mident . tailF) <> fold 166 | mident = \case 167 | Bool n _ _ _ -> pure n 168 | SelectNamed n _ _ -> pure n 169 | SelectWild n _ _ -> pure n 170 | SelectNamedWild n _ _ _ -> pure n 171 | _ -> empty 172 | start = extract ast 173 | 174 | -- Allows any ASCII character as well as a handful of Unicode characters that 175 | -- we've established are safe for use with our vendor's tool. 176 | isAcceptedChar :: Char -> Bool 177 | isAcceptedChar c = isAscii c || c `elem` acceptedChars 178 | where acceptedChars = ['’','…','é','—','ƒ','“','”','–','✓'] 179 | 180 | unsupportedUnicodeRule :: Rule AnnLint 181 | unsupportedUnicodeRule = nonEmpty . nonAscii where 182 | nonAscii = cata $ (maybeToList . mchar) <> fold 183 | mchar = \case 184 | i :< Char c _ -> (i,) . InvalidNonAsciiCharacter <$> guarded (not . isAcceptedChar) c 185 | _ -> empty 186 | 187 | -- If we have access to the offset of the head node of an interpolation case, we 188 | -- we can deduce the offset of the start of the case name. 189 | calcCaseNameOffset :: Text -> Int -> Int 190 | calcCaseNameOffset n i = i - 2 - T.length n 191 | -------------------------------------------------------------------------------- /lib/Intlc/Parser.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Parser where 2 | 3 | import qualified Data.Text as T 4 | import Intlc.Core 5 | import qualified Intlc.ICU as ICU 6 | import Intlc.Parser.Error (ParseFailure) 7 | import Intlc.Parser.ICU (annMsg') 8 | import Intlc.Parser.JSON (ParserState (ParserState), dataset) 9 | import Prelude 10 | import Text.Megaparsec (runParser) 11 | import Text.Megaparsec.Error 12 | 13 | parseDataset :: FilePath -> Text -> Either ParseFailure (Dataset (Translation (ICU.Message ICU.AnnNode))) 14 | parseDataset = runParser (evalStateT dataset (ParserState mempty)) 15 | 16 | parseMessage :: Text -> Text -> Either ParseFailure (ICU.Message ICU.AnnNode) 17 | parseMessage src = runParser annMsg' (T.unpack src) 18 | 19 | printErr :: ParseFailure -> String 20 | printErr = errorBundlePretty 21 | -------------------------------------------------------------------------------- /lib/Intlc/Parser/Error.hs: -------------------------------------------------------------------------------- 1 | -- Our parsers are unavoidably tied together, and it's easiest if dependent 2 | -- parsers share the same error type, but we also need to avoid cyclic 3 | -- dependencies - so it all lives here. 4 | 5 | module Intlc.Parser.Error where 6 | 7 | import qualified Data.Text as T 8 | import Intlc.ICU (Arg, unArg) 9 | import Prelude 10 | import Text.Megaparsec (MonadParsec (parseError)) 11 | import Text.Megaparsec.Error 12 | import Text.Megaparsec.Error.Builder 13 | 14 | type ParseFailure = ParseErrorBundle Text ParseErr 15 | 16 | data ParseErr 17 | = FailedJSONParse JSONParseErr 18 | | FailedMsgParse MessageParseErr 19 | deriving (Show, Eq, Ord) 20 | 21 | data JSONParseErr 22 | = DuplicateKey Text 23 | deriving (Show, Eq, Ord) 24 | 25 | data MessageParseErr 26 | = NoClosingCallbackTag Arg 27 | | BadClosingCallbackTag Arg Arg 28 | | NoOpeningCallbackTag Arg 29 | deriving (Show, Eq, Ord) 30 | 31 | instance ShowErrorComponent ParseErr where 32 | showErrorComponent (FailedJSONParse e) = showErrorComponent e 33 | showErrorComponent (FailedMsgParse e) = showErrorComponent e 34 | 35 | instance ShowErrorComponent JSONParseErr where 36 | showErrorComponent (DuplicateKey k) = "Duplicate key: \"" <> T.unpack k <> "\"" 37 | 38 | instance ShowErrorComponent MessageParseErr where 39 | showErrorComponent (NoClosingCallbackTag x) = "Callback tag <" <> T.unpack (unArg x) <> "> not closed" 40 | showErrorComponent (BadClosingCallbackTag x y) = "Callback tag <" <> T.unpack (unArg x) <> "> not closed, instead found T.unpack (unArg y) <> ">" 41 | showErrorComponent (NoOpeningCallbackTag x) = "Callback tag T.unpack (unArg x) <> "> not opened" 42 | 43 | failingWith :: MonadParsec e s m => Int -> e -> m a 44 | pos `failingWith` e = parseError . errFancy pos . fancy . ErrorCustom $ e 45 | -------------------------------------------------------------------------------- /lib/Intlc/Parser/ICU.hs: -------------------------------------------------------------------------------- 1 | -- Parse an ICU message with annotations/source offsets. These annotations can 2 | -- be stripped later externally if unwanted. 3 | -- 4 | -- Most parsers parse for functions. This might seem counterintuitive, but it's 5 | -- to match the shape of our AST in which, like a singly-linked list, each node 6 | -- points to its next sibling. Equivalently a `Parser (a -> NodeF a)` is 7 | -- typically a parser which has parsed all but the following sibling. A simple 8 | -- example of this would be `pure (Char 'a')`. 9 | -- 10 | -- This module follows the following whitespace rules: 11 | -- * Consume all whitespace after nodes where possible. 12 | -- * Therefore, assume no whitespace before nodes. 13 | 14 | module Intlc.Parser.ICU where 15 | 16 | import qualified Control.Applicative.Combinators.NonEmpty as NE 17 | import Control.Comonad.Cofree (Cofree ((:<)), 18 | unwrap) 19 | import qualified Data.Text as T 20 | import Data.Void () 21 | import Intlc.ICU hiding (arg, char, 22 | selectCases, 23 | wildcard) 24 | import Intlc.Parser.Error (MessageParseErr (..), 25 | ParseErr (FailedMsgParse), 26 | failingWith) 27 | import Prelude 28 | import Text.Megaparsec hiding (State, Stream, 29 | many, some) 30 | import Text.Megaparsec.Char 31 | import qualified Text.Megaparsec.Char.Lexer as L 32 | 33 | failingWith' :: MonadParsec ParseErr s m => Int -> MessageParseErr -> m a 34 | i `failingWith'` e = i `failingWith` FailedMsgParse e 35 | 36 | data ParserState = ParserState 37 | -- Expected to be supplied internally. 38 | { pluralCtxName :: Maybe Arg 39 | -- Expected to be potentially supplied externally. 40 | , endOfInput :: Parser () 41 | } 42 | 43 | emptyState :: ParserState 44 | emptyState = ParserState 45 | { pluralCtxName = Nothing 46 | , endOfInput = pure () 47 | } 48 | 49 | type Parser = ReaderT ParserState (Parsec ParseErr Text) 50 | 51 | -- | Lifts the contents of the parser to contain annotations at this layer of 52 | -- the `Cofree`. 53 | withAnn :: Parser (AnnNode -> NodeF AnnNode) -> Parser (AnnNode -> AnnNode) 54 | withAnn p = (\i f z -> i :< f z) <$> getOffset <*> p 55 | 56 | ident :: Parser Text 57 | ident = label "alphabetic identifier" $ T.pack <$> some letterChar 58 | 59 | arg :: Parser Arg 60 | arg = Arg <$> ident 61 | 62 | -- | Parse a message with annotations until end of input. 63 | -- 64 | -- To instead parse a message as part of a broader data structure, instead look 65 | -- at `msg` and its `endOfInput` state property. 66 | annMsg' :: Parsec ParseErr Text (Message AnnNode) 67 | annMsg' = runReaderT annMsg cfg where 68 | cfg = emptyState { endOfInput = eof } 69 | 70 | -- Parse a message with annotations until the end of input parser matches. 71 | annMsg :: Parser (Message AnnNode) 72 | annMsg = annMsgTill =<< asks endOfInput 73 | 74 | -- Parse a message with annotations until the provided parser matches. 75 | annMsgTill :: Parser a -> Parser (Message AnnNode) 76 | annMsgTill = fmap Message . nodesTill 77 | 78 | nodesTill :: Parser a -> Parser AnnNode 79 | nodesTill end = go where 80 | go = fin <|> (withAnn node <*> go) 81 | fin = (:< Fin) <$> (getOffset <* end) 82 | 83 | -- The core parser of this module. Parse as many of these as you'd like until 84 | -- reaching an anticipated delimiter, such as a double quote in the surrounding 85 | -- JSON string or end of input in a REPL. 86 | node :: Parser (AnnNode -> NodeF AnnNode) 87 | node = choice 88 | [ interp 89 | , callback 90 | -- Plural cases support interpolating the number/argument in context with 91 | -- `#`. When there's no such context, fail the parse in effect treating it 92 | -- as plaintext. 93 | , asks pluralCtxName >>= \case 94 | Just n -> PluralRef n <$ string "#" 95 | Nothing -> empty 96 | , plaintext 97 | ] 98 | 99 | -- Parse a character or a potentially larger escape sequence. 100 | plaintext :: Parser (AnnNode -> NodeF AnnNode) 101 | plaintext = choice 102 | [ try escaped 103 | , Char <$> L.charLiteral 104 | ] 105 | 106 | -- Follows ICU 4.8+ spec, see: 107 | -- https://unicode-org.github.io/icu/userguide/format_parse/messages/#quotingescaping 108 | escaped :: Parser (AnnNode -> NodeF AnnNode) 109 | escaped = apos *> choice 110 | -- Double escape two apostrophes as one, regardless of surrounding 111 | -- syntax: "''" -> "'" 112 | [ Char <$> apos 113 | -- Escape everything until another apostrophe, being careful of internal 114 | -- double escapes: "'{a''}'" -> "{a'}". Must ensure it doesn't surpass the 115 | -- bounds of the surrounding parser as per `endOfInput`. 116 | , try $ do 117 | eom <- asks endOfInput 118 | head' <- withAnn (Char <$> synOpen) 119 | -- Try and parse until end of input or a lone apostrophe. If end of input 120 | -- comes first then fail the parse. 121 | (tail', wasEom) <- someTill_ (withAnn plaintext) $ choice 122 | [ True <$ eom 123 | , try $ False <$ apos <* notFollowedBy apos 124 | ] 125 | guard (not wasEom) 126 | pure $ unwrap . foldr (.) id (head' : tail') 127 | -- Escape the next syntax character as plaintext: "'{" -> "{" 128 | , Char <$> synAll 129 | ] 130 | where apos = char '\'' 131 | synAll = synLone <|> synOpen <|> synClose 132 | synLone = char '#' 133 | synOpen = char '{' <|> char '<' 134 | synClose = char '}' <|> char '>' 135 | 136 | callback :: Parser (AnnNode -> NodeF AnnNode) 137 | callback = do 138 | (openPos, isClosing, oname) <- (,,) <$> (string "<" *> getOffset) <*> closing <*> arg <* string ">" 139 | when isClosing $ (openPos + 1) `failingWith'` NoOpeningCallbackTag oname 140 | mrest <- observing ((,,) <$> children oname <* string " getOffset <*> arg <* string ">") 141 | case mrest of 142 | Left _ -> openPos `failingWith'` NoClosingCallbackTag oname 143 | Right (ch, closePos, cname) -> if oname == cname 144 | then pure ch 145 | else closePos `failingWith'` BadClosingCallbackTag oname cname 146 | where children n = do 147 | eom <- asks endOfInput 148 | nodes <- nodesTill (lookAhead $ void (string " eom) 149 | pure . Callback n $ nodes 150 | closing = fmap isJust . hidden . optional . char $ '/' 151 | 152 | interp :: Parser (AnnNode -> NodeF AnnNode) 153 | interp = between (char '{') (char '}') $ do 154 | n <- arg 155 | option (String n) (sep *> body n) 156 | where sep = string "," <* hspace1 157 | body n = choice 158 | [ uncurry (Bool n) <$> (string "boolean" *> sep *> boolCases) 159 | , Number n <$ string "number" 160 | , Date n <$> (string "date" *> sep *> dateTimeFmt) 161 | , Time n <$> (string "time" *> sep *> dateTimeFmt) 162 | , withPluralCtx n $ choice 163 | [ string "plural" *> sep *> cardinalCases n 164 | , string "selectordinal" *> sep *> ordinalCases n 165 | ] 166 | , string "select" *> sep *> selectCases n 167 | ] 168 | withPluralCtx n = withReaderT (\x -> x { pluralCtxName = Just n }) 169 | 170 | dateTimeFmt :: Parser DateTimeFmt 171 | dateTimeFmt = choice 172 | [ Short <$ string "short" 173 | , Medium <$ string "medium" 174 | , Long <$ string "long" 175 | , Full <$ string "full" 176 | ] 177 | 178 | caseBody :: Parser AnnNode 179 | caseBody = string "{" *> nodesTill (string "}") 180 | 181 | boolCases :: Parser (AnnNode, AnnNode) 182 | boolCases = (,) 183 | <$> (string "true" *> hspace1 *> caseBody) 184 | <* hspace1 185 | <*> (string "false" *> hspace1 *> caseBody) 186 | 187 | selectCases :: Arg -> Parser (AnnNode -> NodeF AnnNode) 188 | selectCases n = choice 189 | [ reconcile <$> cases <*> optional wildcard 190 | , SelectWild n <$> wildcard 191 | ] 192 | where cases = NE.sepEndBy1 ((,) <$> (name <* hspace1) <*> caseBody) hspace1 193 | wildcard = string wildcardName *> hspace1 *> caseBody 194 | reconcile cs (Just w) = SelectNamedWild n cs w 195 | reconcile cs Nothing = SelectNamed n cs 196 | name = try $ mfilter (/= wildcardName) ident 197 | wildcardName = "other" 198 | 199 | cardinalCases :: Arg -> Parser (AnnNode -> NodeF AnnNode) 200 | cardinalCases n = try (cardinalInexactCases n) <|> cardinalExactCases n 201 | 202 | cardinalExactCases :: Arg -> Parser (AnnNode -> NodeF AnnNode) 203 | cardinalExactCases n = CardinalExact n <$> NE.sepEndBy1 pluralExactCase hspace1 204 | 205 | cardinalInexactCases :: Arg -> Parser (AnnNode -> NodeF AnnNode) 206 | cardinalInexactCases n = uncurry (CardinalInexact n) <$> mixedPluralCases <*> pluralWildcard 207 | 208 | ordinalCases :: Arg -> Parser (AnnNode -> NodeF AnnNode) 209 | ordinalCases n = uncurry (Ordinal n) <$> mixedPluralCases <*> pluralWildcard 210 | 211 | mixedPluralCases :: Parser ([PluralCaseF PluralExact AnnNode], [PluralCaseF PluralRule AnnNode]) 212 | mixedPluralCases = partitionEithers <$> sepEndBy (eitherP pluralExactCase pluralRuleCase) hspace1 213 | 214 | pluralExactCase :: Parser (PluralCaseF PluralExact AnnNode) 215 | pluralExactCase = (,) <$> pluralExact <* hspace1 <*> caseBody 216 | where pluralExact = PluralExact . T.pack <$> (string "=" *> some numberChar) 217 | 218 | pluralRuleCase :: Parser (PluralCaseF PluralRule AnnNode) 219 | pluralRuleCase = (,) <$> pluralRule <* hspace1 <*> caseBody 220 | 221 | pluralRule :: Parser PluralRule 222 | pluralRule = choice 223 | [ Zero <$ string "zero" 224 | , One <$ string "one" 225 | , Two <$ string "two" 226 | , Few <$ string "few" 227 | , Many <$ string "many" 228 | ] 229 | 230 | pluralWildcard :: Parser AnnNode 231 | pluralWildcard = string "other" *> hspace1 *> caseBody 232 | -------------------------------------------------------------------------------- /lib/Intlc/Parser/JSON.hs: -------------------------------------------------------------------------------- 1 | -- An in-house JSON parser specialised to our needs, piggybacking off of the 2 | -- sibling ICU parser. Allows interop with our ICU parser and bypasses some 3 | -- Aeson limitations. 4 | -- 5 | -- This module follows the following whitespace rules: 6 | -- * Consume all whitespace after nodes where possible. 7 | -- * Therefore, assume no whitespace before nodes. 8 | 9 | module Intlc.Parser.JSON where 10 | 11 | import Control.Applicative.Permutations 12 | import qualified Data.Map as M 13 | import qualified Data.Set as Set 14 | import qualified Data.Text as T 15 | import Data.Void () 16 | import Intlc.Core 17 | import qualified Intlc.ICU as ICU 18 | import Intlc.Parser.Error (JSONParseErr (..), 19 | ParseErr (FailedJSONParse), 20 | failingWith) 21 | import qualified Intlc.Parser.ICU as ICUP 22 | import Prelude hiding (null) 23 | import Text.Megaparsec hiding (State, Stream, many, 24 | some) 25 | import Text.Megaparsec.Char 26 | import qualified Text.Megaparsec.Char.Lexer as L 27 | import Text.Megaparsec.Error.Builder (errFancy, fancy) 28 | 29 | type Parser = StateT ParserState (Parsec ParseErr Text) 30 | 31 | data ParserState = ParserState 32 | { keys :: Set Text 33 | } 34 | 35 | failingWith' :: MonadParsec ParseErr s m => Int -> JSONParseErr -> m a 36 | i `failingWith'` e = i `failingWith` FailedJSONParse e 37 | 38 | dataset :: Parser (Dataset (Translation (ICU.Message ICU.AnnNode))) 39 | dataset = space *> objMap translation <* space <* eof 40 | 41 | -- It's important to use `toPermutationWithDefault` as opposed to standard 42 | -- parser combinators like `optional` so that `intercalateEffect` can do its 43 | -- magic. 44 | -- 45 | -- Additionally, the consistent application of whitespace is extremely 46 | -- important, and the permutation appears to operate over the first parser, so 47 | -- be careful around any abstractions around the key double quotes. 48 | translation :: Parser (Translation (ICU.Message ICU.AnnNode)) 49 | translation = obj $ intercalateEffect objSep $ Translation 50 | <$> toPermutation (objPair' "message" msg) 51 | <*> toPermutationWithDefault TypeScript (objPair' "backend" (backendp <|> TypeScript <$ null)) 52 | <*> toPermutationWithDefault Nothing (objPair' "description" (Just <$> strLit <|> Nothing <$ null)) 53 | 54 | msg :: Parser (ICU.Message ICU.AnnNode) 55 | msg = lift $ withRecovery recover p 56 | where p = runReaderT (char '"' *> ICUP.annMsg) icupState 57 | icupState = ICUP.emptyState { ICUP.endOfInput = void $ char '"' } 58 | recover e = error "absurd" <$ consume <* registerParseError e 59 | -- Once we've recovered we need to consume the rest of the message 60 | -- string so that parsing can continue beyond it. 61 | consume = void $ manyTill L.charLiteral (char '"') 62 | 63 | backendp :: Parser Backend 64 | backendp = choice 65 | [ TypeScript <$ string (dblqts "ts") 66 | , TypeScriptReact <$ string (dblqts "tsx") 67 | ] 68 | 69 | null :: Parser () 70 | null = void $ string "null" 71 | 72 | strLit :: Parser Text 73 | strLit = (T.pack <$>) $ char '"' *> manyTill L.charLiteral (char '"') 74 | 75 | dblqtsp :: Parser a -> Parser a 76 | dblqtsp = between (char '"') (char '"') 77 | 78 | dblqts :: Text -> Text 79 | dblqts x = "\"" <> x <> "\"" 80 | 81 | -- Parse a homogeneous object of arbitrary keys, failing with recovery upon the 82 | -- presence of duplicate keys. 83 | objMap :: Parser a -> Parser (Map Text a) 84 | objMap v = fmap M.fromList . obj $ sepEndBy (objPair newKey v) objSep 85 | where newKey = do 86 | i <- getOffset 87 | k <- strLit 88 | prev <- gets keys 89 | if Set.member k prev 90 | then registerParseError . errFancy i . fancy . ErrorCustom . FailedJSONParse . DuplicateKey $ k 91 | else modify (\x -> x { keys = Set.insert k prev }) 92 | pure k 93 | 94 | obj :: Parser a -> Parser a 95 | obj p = string "{" *> space *> p <* space <* string "}" 96 | 97 | objPair :: Parser Text -> Parser a -> Parser (Text, a) 98 | objPair k v = (,) <$> k <*> (space *> char ':' *> space *> v) 99 | 100 | objPair' :: Text -> Parser a -> Parser a 101 | objPair' k v = snd <$> objPair (string (dblqts k)) v 102 | 103 | objSep :: Parser () 104 | objSep = void $ char ',' <* space 105 | -------------------------------------------------------------------------------- /lib/Intlc/Prettify.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Prettify (prettify) where 2 | 3 | import Intlc.Backend.ICU.Compiler (Formatting (..), compileMsg) 4 | import qualified Intlc.ICU as ICU 5 | import Intlc.Printer (IndentStyle) 6 | import Prelude 7 | 8 | prettify :: IndentStyle -> ICU.Message ICU.Node -> Text 9 | prettify = compileMsg . MultiLine 10 | -------------------------------------------------------------------------------- /lib/Intlc/Printer.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Printer where 2 | 3 | import qualified Data.Text as T 4 | import Prelude 5 | 6 | data IndentStyle 7 | = Tabs 8 | | Spaces Nat 9 | 10 | -- The default indent style unless otherwise specified by the user. 11 | def :: IndentStyle 12 | def = Tabs 13 | 14 | indenter :: IndentStyle -> Nat -> Text 15 | indenter Tabs = flip T.replicate "\t" . fromEnum 16 | indenter (Spaces n) = flip T.replicate " " . fromEnum . (* n) 17 | -------------------------------------------------------------------------------- /lib/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import Data.List (nubBy, (\\)) 4 | import Prelude 5 | 6 | -- Borrowed from: https://hackage.haskell.org/package/intro-0.9.0.0/docs/Intro.html#v:-60--62--94- 7 | -- | Semigroup concat lifted to an applicative context. 8 | (<>^) :: (Applicative f, Semigroup a) => f a -> f a -> f a 9 | (<>^) = liftA2 (<>) 10 | infixr 6 <>^ 11 | {-# INLINE (<>^) #-} 12 | 13 | apply2 :: a -> b -> (a -> b -> c) -> c 14 | apply2 x y f = f x y 15 | 16 | -- | Filters out the first instance of each found value as per the predicate. 17 | -- The dual of `nubBy`. 18 | bunBy :: (Foldable f, Eq a) => (a -> a -> Bool) -> f a -> [a] 19 | bunBy f xs = let ys = toList xs in ys \\ nubBy f ys 20 | 21 | -- | Filters out the first instance of each found value as per its `Eq` 22 | -- instance. The dual of `nub`. 23 | bun :: (Foldable f, Eq a) => f a -> [a] 24 | bun = bunBy (==) 25 | -------------------------------------------------------------------------------- /test/Intlc/Backend/TypeScriptSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Backend.TypeScriptSpec (spec) where 2 | 3 | import Data.Functor.Foldable (embed) 4 | import qualified Data.Text as T 5 | import Intlc.Backend.JavaScript.Compiler (InterpStrat (..)) 6 | import Intlc.Backend.TypeScript.Compiler (compileNamedExport, 7 | compileTypeof) 8 | import qualified Intlc.Backend.TypeScript.Language as TS 9 | import Intlc.Core (Locale (Locale)) 10 | import qualified Intlc.ICU as ICU 11 | import Prelude 12 | import System.FilePath ((<.>), ()) 13 | import Test.Hspec 14 | import Test.Hspec.Golden (Golden (..), defaultGolden) 15 | 16 | golden :: InterpStrat -> (ICU.Message ICU.Node -> Text) -> String -> ICU.Message ICU.Node -> Golden String 17 | golden strat compiler name msg = baseCfg 18 | { goldenFile = goldenFile baseCfg <.> fileExt 19 | , actualFile = actualFile baseCfg <&> (<.> fileExt) 20 | } 21 | where baseCfg = defaultGolden fileName out 22 | fileName = "ts" name 23 | fileExt = 24 | case strat of 25 | TemplateLit -> "ts" 26 | JSX -> "tsx" 27 | out = T.unpack . compiler $ msg 28 | 29 | spec :: Spec 30 | spec = describe "TypeScript compiler" $ do 31 | describe "golden" $ do 32 | let msg = ICU.Message . mconcat $ 33 | [ "Hello " 34 | , ICU.Callback' "bold" ( 35 | ICU.String' "name" 36 | ) 37 | , "! You are " 38 | , ICU.CardinalInexact' 39 | "age" 40 | (pure (ICU.PluralExact "42", "very cool")) 41 | (pure (ICU.Zero, "new around here")) 42 | "not all that interesting" 43 | , ". Regardless, the magic number is most certainly " 44 | , ICU.Number' "magicNumber" 45 | , "! The date is " 46 | , ICU.Date' "todayDate" ICU.Short 47 | , ", and the time is " 48 | , ICU.Time' "currTime" ICU.Full 49 | , ". And just to recap, your name is " 50 | , ICU.SelectNamed' "name" . fromList $ 51 | [ ("Sam", "undoubtedly excellent") 52 | , ("Ashley", "fairly good") 53 | ] 54 | , ". Finally, you are " 55 | , embed $ ICU.Bool 56 | { ICU.arg = "isDev" 57 | , ICU.trueCase = "a software engineer" 58 | , ICU.falseCase = "something less fun" 59 | , ICU.next = mempty 60 | } 61 | , ". Bonus: Some characters that might need escaping! ` ``" 62 | ] 63 | 64 | describe "with template literal strategy" $ do 65 | it "compiles correct type definitions" $ do 66 | -- Prefix output so it's a valid statement. 67 | let golden' = golden TemplateLit (("export type Test = " <>) . compileTypeof TemplateLit) 68 | 69 | golden' "typedef" msg 70 | 71 | it "compiles correct named exports" $ do 72 | -- Use dummy locale that can't realistically have been mistakenly 73 | -- hardcoded anywhere. 74 | let golden' = golden TemplateLit (compileNamedExport TemplateLit (Locale "te-ST") "test") 75 | 76 | golden' "named-export" msg 77 | 78 | describe "with JSX strategy" $ do 79 | it "compiles correct type definitions" $ do 80 | -- Prefix output so it's a valid statement. 81 | let golden' = golden JSX (("export type Test = " <>) . compileTypeof JSX) 82 | 83 | golden' "typedef" msg 84 | 85 | it "compiles correct named exports" $ do 86 | -- Use dummy locale that can't realistically have been mistakenly 87 | -- hardcoded anywhere. 88 | let golden' = golden JSX (compileNamedExport JSX (Locale "te-ST") "test") 89 | 90 | golden' "named-export" msg 91 | 92 | -- Typechecking happens externally. 93 | it "typechecks nested selects" $ golden TemplateLit (compileNamedExport TemplateLit (Locale "te-ST") "test") "nested-select" $ 94 | ICU.Message (ICU.SelectNamed' "x" $ fromList 95 | [ ("a", mempty) 96 | , ("b", ICU.SelectNamed' "x" $ fromList 97 | [ ("a", mempty) -- <-- without a workaround, TypeScript will have narrowed and reject this case 98 | , ("b", mempty) 99 | ] 100 | )]) 101 | 102 | describe "collects nested arguments" $ do 103 | let args (TS.Lambda xs _) = xs 104 | let fromNode = args . TS.fromMsg TS.TFragment . ICU.Message 105 | let fromArgs = fromList 106 | 107 | it "in select" $ do 108 | let x = ICU.SelectNamed' "x" . pure $ ("foo", ICU.String' "y") 109 | let ys = 110 | [ ("x", pure (TS.TStrLitUnion (pure "foo"))) 111 | , ("y", pure TS.TStr) 112 | ] 113 | fromNode x `shouldBe` fromArgs ys 114 | 115 | it "in cardinal plural" $ do 116 | let x = ICU.CardinalExact' "x" . pure $ 117 | (ICU.PluralExact "42", ICU.String' "y") 118 | let ys = 119 | [ ("x", pure (TS.TNumLitUnion (pure "42"))) 120 | , ("y", pure TS.TStr) 121 | ] 122 | fromNode x `shouldBe` fromArgs ys 123 | 124 | it "in ordinal plural" $ do 125 | let x = ICU.Ordinal' "x" 126 | [(ICU.PluralExact "42", ICU.Date' "foo" ICU.Short)] 127 | (pure (ICU.Few, ICU.String' "bar")) 128 | (ICU.Number' "baz") 129 | let ys = 130 | [ ("x", pure TS.TNum) 131 | , ("foo", pure TS.TDate) 132 | , ("bar", pure TS.TStr) 133 | , ("baz", pure TS.TNum) 134 | ] 135 | fromNode x `shouldBe` fromArgs ys 136 | 137 | it "in boolean" $ do 138 | let x = ICU.Bool' "x" 139 | (ICU.String' "y") 140 | (ICU.Number' "z") 141 | let ys = 142 | [ ("x", pure TS.TBool) 143 | , ("y", pure TS.TStr) 144 | , ("z", pure TS.TNum) 145 | ] 146 | fromNode x `shouldBe` fromArgs ys 147 | -------------------------------------------------------------------------------- /test/Intlc/CompilerSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.CompilerSpec (spec) where 2 | 3 | import qualified Data.Text as T 4 | import qualified Intlc.Backend.JSON.Compiler as JSON 5 | import Intlc.Compiler (compileDataset, compileToJSON, 6 | expandRules, flatten) 7 | import Intlc.Core (Backend (..), Locale (Locale), 8 | Translation (Translation)) 9 | import Intlc.ICU 10 | import Intlc.Printer (IndentStyle (..)) 11 | import Prelude hiding (one) 12 | import Test.Hspec 13 | import Text.RawString.QQ (r) 14 | 15 | spec :: Spec 16 | spec = describe "compiler" $ do 17 | describe "compile" $ do 18 | let f = compileDataset (Locale "any") . fromList . fmap (, Translation (Message "any") TypeScript Nothing) 19 | 20 | it "validates keys don't contain invalid chars" $ do 21 | f ["goodKey"] `shouldSatisfy` isRight 22 | f ["bad key"] `shouldSatisfy` isLeft 23 | 24 | it "validates keys aren't reserved words" $ do 25 | f ["delete"] `shouldSatisfy` isLeft 26 | 27 | it "validates keys aren't empty" $ do 28 | f [""] `shouldSatisfy` isLeft 29 | 30 | describe "compile flattened dataset" $ do 31 | let f = compileToJSON flatten 32 | 33 | describe "flattens messages and outputs JSON" $ do 34 | let xs = fromList 35 | [ ("x", Translation (Message "xfoo") TypeScript Nothing) 36 | , ("z", Translation (Message "zfoo") TypeScriptReact (Just "zbar")) 37 | , ("y", Translation (Message $ mconcat ["yfoo ", String' "ybar"]) TypeScript Nothing) 38 | ] 39 | 40 | it "minified" $ do 41 | f JSON.Minified xs `shouldBe` 42 | [r|{"x":{"message":"xfoo","backend":"ts","description":null},"y":{"message":"yfoo {ybar}","backend":"ts","description":null},"z":{"message":"zfoo","backend":"tsx","description":"zbar"}}|] 43 | 44 | it "prettified" $ do 45 | let toTabs = T.replace " " "\t" 46 | let toFourSpaces = T.replace " " " " 47 | let xsOut = [r|{ 48 | "x": { 49 | "message": "xfoo", 50 | "backend": "ts", 51 | "description": null 52 | }, 53 | "y": { 54 | "message": "yfoo {ybar}", 55 | "backend": "ts", 56 | "description": null 57 | }, 58 | "z": { 59 | "message": "zfoo", 60 | "backend": "tsx", 61 | "description": "zbar" 62 | } 63 | }|] 64 | 65 | f (JSON.Pretty Tabs) mempty `shouldBe` [r|{ 66 | }|] 67 | 68 | f (JSON.Pretty Tabs) xs `shouldBe` toTabs xsOut 69 | f (JSON.Pretty (Spaces 2)) xs `shouldBe` xsOut 70 | f (JSON.Pretty (Spaces 4)) xs `shouldBe` toFourSpaces xsOut 71 | 72 | it "escapes double quotes in JSON" $ do 73 | f JSON.Minified (fromList [("x\"y", Translation (Message "\"z\"") TypeScript Nothing)]) 74 | `shouldBe` [r|{"x\"y":{"message":"\"z\"","backend":"ts","description":null}}|] 75 | 76 | describe "flatten message" $ do 77 | it "no-ops static" $ do 78 | flatten "xyz" `shouldBe` "xyz" 79 | 80 | describe "flattens shallow select" $ do 81 | let foo = ("foo", "a dog") 82 | let foof = ("foo", "I have a dog") 83 | 84 | it "with a wildcard" $ do 85 | let other = "many dogs" 86 | let otherf = "I have many dogs" 87 | 88 | flatten (mconcat ["I have ", SelectNamedWild' "thing" (pure foo) other]) `shouldBe` 89 | SelectNamedWild' "thing" (pure foof) otherf 90 | 91 | it "without a wildcard" $ do 92 | flatten (mconcat ["I have ", SelectNamed' "thing" (pure foo)]) `shouldBe` 93 | SelectNamed' "thing" (pure foof) 94 | 95 | it "flattens shallow plural" $ do 96 | let other = PluralRef' "count" <> " dogs" 97 | let otherf = "I have " <> PluralRef' "count" <> " dogs" 98 | let one = (One, "a dog") 99 | let onef = (One, "I have a dog") 100 | 101 | flatten (mconcat ["I have ", CardinalInexact' "count" [] (pure one) other]) `shouldBe` 102 | CardinalInexact' "count" [] (pure onef) otherf 103 | 104 | it "flattens deep interpolations" $ do 105 | let x = mconcat 106 | [ "I have " 107 | , CardinalInexact' "count" 108 | [] 109 | (pure (One, "a dog")) 110 | (mconcat [ Number' "count" 111 | , " dogs, the newest of which is " 112 | , SelectNamedWild' "name" 113 | (pure ("hodor", "Hodor")) 114 | "unknown" 115 | ]) 116 | , "!" 117 | ] 118 | let y = CardinalInexact' "count" 119 | [] 120 | (pure (One, "I have a dog!")) 121 | (mconcat [ SelectNamedWild' "name" 122 | (pure ("hodor", 123 | mconcat [ "I have " 124 | , Number' "count" 125 | , " dogs, the newest of which is Hodor!" 126 | ] 127 | )) 128 | (mconcat [ "I have " 129 | , Number' "count" 130 | , " dogs, the newest of which is unknown!" 131 | ]) 132 | ]) 133 | 134 | flatten x `shouldBe` y 135 | 136 | it "flattens callbacks" $ do 137 | let x = mconcat 138 | [ "Today is " 139 | , Callback' "bold" (mconcat 140 | [ ">" 141 | , SelectNamedWild' 142 | "day" 143 | (fromList 144 | [ ("Saturday", "the weekend") 145 | , ("Sunday", "the weekend, barely") 146 | ] 147 | ) 148 | "a weekday" 149 | , "<" 150 | ] 151 | ) 152 | , "." 153 | ] 154 | 155 | let y = 156 | SelectNamedWild' 157 | "day" 158 | (fromList 159 | [ ("Saturday", mconcat 160 | [ "Today is " 161 | , Callback' "bold" (mconcat 162 | [ ">the weekend<" 163 | ] 164 | ) 165 | , "." 166 | ] 167 | ) 168 | , ("Sunday", mconcat 169 | [ "Today is " 170 | , Callback' "bold" (mconcat 171 | [ ">the weekend, barely<" 172 | ] 173 | ) 174 | , "." 175 | ] 176 | ) 177 | ] 178 | ) 179 | (mconcat 180 | [ "Today is " 181 | , Callback' "bold" (mconcat 182 | [ ">a weekday<" 183 | ] 184 | ) 185 | , "." 186 | ] 187 | ) 188 | 189 | flatten x `shouldBe` y 190 | 191 | describe "expanding rules" $ do 192 | let f = expandRules 193 | 194 | it "always contains every rule in the output" $ do 195 | let c = (,) 196 | let w = mempty 197 | let rule (x, _) = x 198 | let g xs = sort (toList $ rule <$> f xs w) 199 | 200 | g [] `shouldBe` universe 201 | g [c Zero mempty] `shouldBe` universe 202 | g [c Many mempty, c Zero mempty] `shouldBe` universe 203 | 204 | it "copies the wildcard node to new rules" $ do 205 | let xs = "foo" 206 | let c = (,) 207 | let w = id 208 | let g ys = toList (f ys (w xs)) 209 | 210 | g [] `shouldBe` (flip c xs <$> (universe :: [PluralRule])) 211 | 212 | g [c Many "bar", c Zero mempty] `shouldBe` 213 | [c Many "bar", c Zero mempty, c One xs, c Two xs, c Few xs] 214 | 215 | it "returns full list of rules unmodified (as non-empty)" $ do 216 | let c = (,) 217 | let xs = [c Two "foo", c Many "", c Zero "bar", c One "baz", c Few ""] 218 | 219 | f xs "any" `shouldBe` fromList xs 220 | -------------------------------------------------------------------------------- /test/Intlc/EndToEndSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.EndToEndSpec (spec) where 2 | 3 | import qualified Data.Text as T 4 | import Intlc.Backend.ICU.Compiler (Formatting (SingleLine), 5 | compileMsg) 6 | import Intlc.Compiler (compileDataset, expandPlurals) 7 | import Intlc.Core (Locale (Locale), datasetSansAnn) 8 | import Intlc.ICU (sansAnn) 9 | import Intlc.Parser (parseDataset) 10 | import Intlc.Parser.Error (ParseFailure) 11 | import Intlc.Parser.ICU (ParserState (endOfInput), annMsg, 12 | emptyState) 13 | import Prelude 14 | import System.FilePath ((<.>), ()) 15 | import Test.Hspec 16 | import Test.Hspec.Golden (Golden (..), defaultGolden) 17 | import Text.Megaparsec (eof, runParser) 18 | import Text.RawString.QQ (r) 19 | 20 | parseAndCompileDataset :: Text -> Either (NonEmpty Text) Text 21 | parseAndCompileDataset = compileDataset (Locale "en-US") . datasetSansAnn <=< first (pure . show) . parseDataset "test" 22 | 23 | parseAndExpandMsg :: Text -> Either ParseFailure Text 24 | parseAndExpandMsg = fmap (compileMsg SingleLine . fmap (expandPlurals . sansAnn)) . parseMsg 25 | where parseMsg = runParser (runReaderT annMsg (emptyState { endOfInput = eof })) "test" 26 | 27 | golden :: String -> Text -> Golden String 28 | golden name in' = baseCfg 29 | { goldenFile = goldenFile baseCfg <.> "ts" 30 | , actualFile = actualFile baseCfg <&> (<.> "ts") 31 | } 32 | where baseCfg = defaultGolden fileName out 33 | fileName = "e2e" name 34 | out = T.unpack . fromErrs . parseAndCompileDataset $ in' 35 | fromErrs (Right x) = x 36 | fromErrs (Left es) = T.intercalate "\n" . toList $ es 37 | 38 | spec :: Spec 39 | spec = describe "end-to-end" $ do 40 | describe "compilation" $ do 41 | let x =*= y = parseAndCompileDataset x `shouldBe` Right y 42 | let withReactImport = ("import type { ReactElement } from 'react'\n" <>) 43 | 44 | it "compiles to golden output" $ do 45 | golden "example" [r|{ "title": { "message": "Unsplash" }, "greeting": { "message": "Hello {name}, {age, number}!", "backend": "ts" } }|] 46 | 47 | it "compiles valid JS module format given empty input" $ do 48 | [r|{}|] 49 | =*= "export {}" 50 | 51 | it "parses and discards descriptions" $ do 52 | [r|{ "brand": { "message": "Unsplash", "description": "The company name" } }|] 53 | =*= "export const brand: () => string = () => `Unsplash`" 54 | 55 | it "outputs in alphabetical order" $ do 56 | [r|{ "x": { "message": "" }, "A": { "message": "" }, "z": { "message": "" } }|] 57 | =*= "export const A: () => string = () => ``\nexport const x: () => string = () => ``\nexport const z: () => string = () => ``" 58 | 59 | it "compiles bools" $ do 60 | [r|{ "f": { "message": "{x, boolean, true {y} false {z}}" } }|] 61 | =*= "export const f: (x: { x: boolean }) => string = x => `${(() => { switch (x.x as typeof x.x) { case true: return `y`; case false: return `z`; } })()}`" 62 | 63 | it "compiles plurals" $ do 64 | [r|{ "prop": { "message": "Age: {age, plural, =0 {newborn called {name}} =42 {magical} other {boring #}}", "backend": "ts" } }|] 65 | =*= "export const prop: (x: { age: number; name: string }) => string = x => `Age: ${(() => { switch (x.age as typeof x.age) { case 0: return `newborn called ${x.name}`; case 42: return `magical`; default: return `boring ${new Intl.NumberFormat('en-US').format(x.age)}`; } })()}`" 66 | [r|{ "prop": { "message": "Age: {age, plural, =0 {newborn called {name}} =42 {magical} other {boring #}}", "backend": "tsx" } }|] 67 | =*= withReactImport "export const prop: (x: { age: number; name: string }) => ReactElement = x => <>Age: {(() => { switch (x.age as typeof x.age) { case 0: return <>newborn called {x.name}; case 42: return <>magical; default: return <>boring {new Intl.NumberFormat('en-US').format(x.age)}; } })()}" 68 | [r|{ "f": { "message": "{n, plural, =0 {x} =42 {y}}", "backend": "ts" } }|] 69 | =*= "export const f: (x: { n: 0 | 42 }) => string = x => `${(() => { switch (x.n as typeof x.n) { case 0: return `x`; case 42: return `y`; } })()}`" 70 | [r|{ "f": { "message": "{n, plural, =0 {zero} many {many} other {#}}", "backend": "ts" } }|] 71 | =*= "export const f: (x: { n: number }) => string = x => `${(() => { switch (x.n as typeof x.n) { case 0: return `zero`; default: { switch (new Intl.PluralRules('en-US').select(x.n)) { case 'many': return `many`; default: return `${new Intl.NumberFormat('en-US').format(x.n)}`; } } } })()}`" 72 | [r|{ "f": { "message": "{n, plural, many {many} other {#}}", "backend": "ts" } }|] 73 | =*= "export const f: (x: { n: number }) => string = x => `${(() => { switch (new Intl.PluralRules('en-US').select(x.n)) { case 'many': return `many`; default: return `${new Intl.NumberFormat('en-US').format(x.n)}`; } })()}`" 74 | [r|{ "f": { "message": "{n, plural, =42 {#}}" } }|] 75 | =*= "export const f: (x: { n: 42 }) => string = x => `${(() => { switch (x.n as typeof x.n) { case 42: return `${new Intl.NumberFormat('en-US').format(x.n)}`; } })()}`" 76 | 77 | it "compiles select" $ do 78 | [r|{ "f": { "message": "{x, select, a {hi} b {yo}}", "backend": "ts" } }|] 79 | =*= "export const f: (x: { x: 'a' | 'b' }) => string = x => `${(() => { switch (x.x as typeof x.x) { case 'a': return `hi`; case 'b': return `yo`; } })()}`" 80 | [r|{ "f": { "message": "{x, select, a {hi} b {yo} other {ciao}}", "backend": "ts" } }|] 81 | =*= "export const f: (x: { x: string }) => string = x => `${(() => { switch (x.x as typeof x.x) { case 'a': return `hi`; case 'b': return `yo`; default: return `ciao`; } })()}`" 82 | 83 | it "compiles selectordinal" $ do 84 | [r|{ "f": { "message": "{x, selectordinal, one {foo} other {bar}}", "backend": "ts" } }|] 85 | =*= "export const f: (x: { x: number }) => string = x => `${(() => { switch (new Intl.PluralRules('en-US', { type: 'ordinal' }).select(x.x)) { case 'one': return `foo`; default: return `bar`; } })()}`" 86 | [r|{ "f": { "message": "{x, selectordinal, one {foo} =2 {bar} other {baz}}", "backend": "ts" } }|] 87 | =*= "export const f: (x: { x: number }) => string = x => `${(() => { switch (x.x as typeof x.x) { case 2: return `bar`; default: { switch (new Intl.PluralRules('en-US', { type: 'ordinal' }).select(x.x)) { case 'one': return `foo`; default: return `baz`; } } } })()}`" 88 | 89 | it "TypeScript backend" $ do 90 | [r|{ "f": { "message": "{x} {y, number} {y, number}", "backend": "ts" } }|] 91 | =*= "export const f: (x: { x: string; y: number; z: (x: string) => string }) => string = x => `${x.x} ${x.z(`${new Intl.NumberFormat('en-US').format(x.y)}`)} ${new Intl.NumberFormat('en-US').format(x.y)}`" 92 | 93 | it "TypeScriptReact backend" $ do 94 | [r|{ "f": { "message": "{x} {y, number}", "backend": "tsx" } }|] 95 | =*= withReactImport "export const f: (x: { x: string; y: number; z: (x: ReactElement) => ReactElement }) => ReactElement = x => <>{x.x} {x.z(<>{new Intl.NumberFormat('en-US').format(x.y)})}" 96 | 97 | describe "plural expansion" $ do 98 | let x =*= y = parseAndExpandMsg x `shouldBe` Right y 99 | 100 | -- For the utmost confidence this was written by hand. Have run reading it! 101 | it "expands nested rule plurals" $ do 102 | "a {na, plural, zero {b} other {{nb, plural, two {c} many {d} other {e}}}} {f, number} {nc, plural, one {g} other {{h}}} i {nd, plural, =1 {j} one {k} other {l}}" 103 | =*= "a {na, plural, zero {b} one {{nb, plural, two {c} many {d} zero {e} one {e} few {e} other {e}}} two {{nb, plural, two {c} many {d} zero {e} one {e} few {e} other {e}}} few {{nb, plural, two {c} many {d} zero {e} one {e} few {e} other {e}}} many {{nb, plural, two {c} many {d} zero {e} one {e} few {e} other {e}}} other {{nb, plural, two {c} many {d} zero {e} one {e} few {e} other {e}}}} {f, number} {nc, plural, one {g} zero {{h}} two {{h}} few {{h}} many {{h}} other {{h}}} i {nd, plural, =1 {j} one {k} zero {l} two {l} few {l} many {l} other {l}}" 104 | -------------------------------------------------------------------------------- /test/Intlc/ICUSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 2 | {-# HLINT ignore "Monoid law, left identity" #-} 3 | {-# HLINT ignore "Monoid law, right identity" #-} 4 | 5 | module Intlc.ICUSpec where 6 | 7 | import Intlc.ICU 8 | import Prelude 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "ICU AST" $ do 13 | let a = Char' 'a' 14 | let b = Char' 'b' 15 | let c = Char' 'c' 16 | 17 | describe "semigroup" $ do 18 | describe "is lawful with respect to" $ do 19 | it "associativity" $ do 20 | (a <> b) <> c `shouldBe` a <> (b <> c) 21 | 22 | describe "monoid" $ do 23 | describe "is lawful with respect to" $ do 24 | it "left identity" $ do 25 | a <> mempty `shouldBe` a 26 | 27 | it "right identity" $ do 28 | mempty <> a `shouldBe` a 29 | -------------------------------------------------------------------------------- /test/Intlc/LinterSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.LinterSpec where 2 | 3 | import Control.Comonad.Cofree (Cofree ((:<))) 4 | import Data.Functor.Foldable (cata) 5 | import Intlc.Error (WithAnn) 6 | import Intlc.ICU 7 | import Intlc.Linter 8 | import Prelude 9 | import Test.Hspec 10 | 11 | -- | Annotate an AST with nonsense. We won't test the annotations. 12 | withAnn :: Message Node -> Message AnnNode 13 | withAnn = fmap (cata (0 :<)) 14 | 15 | lintWith' :: Rule (WithAnn a) -> Message Node -> Status a 16 | lintWith' r = statusSansAnn . lintWith (pure r) . withAnn where 17 | statusSansAnn Success = Success 18 | statusSansAnn (Failure xs) = Failure (snd <$> xs) 19 | 20 | spec :: Spec 21 | spec = describe "linter" $ do 22 | describe "external" $ do 23 | describe "redundant select" $ do 24 | let lint = lintWith' redundantSelectRule 25 | 26 | it "succeeds on select with any non-wildcard case" $ do 27 | lint (Message (SelectNamed' "x" (pure ("y", mempty)))) 28 | `shouldBe` Success 29 | lint (Message (SelectNamedWild' "x" (pure ("y", mempty)) mempty)) 30 | `shouldBe` Success 31 | 32 | it "fails on selects with only a wildcard" $ do 33 | let s = SelectWild' 34 | 35 | lint (Message $ mconcat [s "x" (s "y" mempty), s "z" mempty]) 36 | `shouldBe` Failure (RedundantSelect <$> ("x" :| ["y", "z"])) 37 | 38 | describe "redundant plural" $ do 39 | let lint = lintWith' redundantPluralRule 40 | 41 | it "succeeds on exact cardinal plural" $ do 42 | lint (Message $ CardinalExact' "x" (pure (PluralExact "42", mempty))) 43 | `shouldBe` Success 44 | 45 | it "succeeds on ordinal plural with any non-wildcard case" $ do 46 | lint (Message $ Ordinal' "x" [(PluralExact "42", mempty)] [] mempty) 47 | `shouldBe` Success 48 | lint (Message $ Ordinal' "x" [] [(Two, mempty)] mempty) 49 | `shouldBe` Success 50 | 51 | it "succeeds on inexact cardinal plural with any non-wildcard case" $ do 52 | lint (Message $ CardinalInexact' "x" [(PluralExact "42", mempty)] [] mempty) 53 | `shouldBe` Success 54 | lint (Message $ CardinalInexact' "x" [] [(Two, mempty)] mempty) 55 | `shouldBe` Success 56 | 57 | it "fails on ordinal plural with only a wildcard" $ do 58 | lint (Message $ Callback' "y" (Ordinal' "x" [] [] mempty)) 59 | `shouldBe` Failure (pure $ RedundantPlural "x") 60 | 61 | it "fails on inexact cardinal plural with only a wildcard" $ do 62 | lint (Message $ Callback' "y" (CardinalInexact' "x" [] [] mempty)) 63 | `shouldBe` Failure (pure $ RedundantPlural "x") 64 | 65 | describe "duplicate select case" $ do 66 | let lint = lintWith' duplicateSelectCasesRule 67 | 68 | it "reports each duplicate after the first" $ do 69 | let x = Message $ mconcat 70 | [ SelectNamed' "a" (fromList 71 | [ ("a1", mempty) 72 | , ("a2", mempty) 73 | , ("a1", mempty) 74 | , ("a1", mempty) 75 | , ("a3", SelectNamedWild' "aa" (fromList 76 | [ ("aa1", mempty) 77 | , ("aa1", mempty) 78 | ]) 79 | mempty) 80 | , ("a2", mempty) 81 | , ("a1", mempty) 82 | ]) 83 | , SelectNamedWild' "b" (fromList 84 | [ ("b1", mempty) 85 | , ("b2", mempty) 86 | , ("b3", mempty) 87 | , ("b2", SelectNamed' "bb" (fromList 88 | [ ("bb1", mempty) 89 | ])) 90 | ]) 91 | mempty 92 | ] 93 | lint x `shouldBe` Failure (fromList 94 | [ DuplicateSelectCase "a" "a1" 95 | , DuplicateSelectCase "a" "a1" 96 | , DuplicateSelectCase "a" "a2" 97 | , DuplicateSelectCase "a" "a1" 98 | , DuplicateSelectCase "aa" "aa1" 99 | , DuplicateSelectCase "b" "b2" 100 | ]) 101 | 102 | describe "duplicate plural case" $ do 103 | let lint = lintWith' duplicatePluralCasesRule 104 | 105 | it "reports each duplicate after the first" $ do 106 | let x = Message $ mconcat 107 | [ CardinalExact' "a" (fromList 108 | [ ("a1", mempty) 109 | , ("a2", mempty) 110 | , ("a1", mempty) 111 | , ("a1", mempty) 112 | , ("a3", Ordinal' "aa" 113 | [ ("aa1", mempty) 114 | , ("aa1", mempty) 115 | ] 116 | [ (One, mempty) 117 | , (Many, mempty) 118 | , (One, mempty) 119 | ] 120 | mempty) 121 | , ("a2", mempty) 122 | , ("a1", mempty) 123 | ]) 124 | , CardinalInexact' "b" 125 | [ ("b1", mempty) 126 | , ("b2", mempty) 127 | , ("b3", mempty) 128 | , ("b2", mempty) 129 | ] 130 | [ (One, mempty) 131 | , (Two, mempty) 132 | , (Zero, mempty) 133 | , (Two, mempty) 134 | ] 135 | mempty 136 | ] 137 | lint x `shouldBe` Failure (fromList 138 | [ DuplicatePluralCase "a" "=a1" 139 | , DuplicatePluralCase "a" "=a1" 140 | , DuplicatePluralCase "a" "=a2" 141 | , DuplicatePluralCase "a" "=a1" 142 | , DuplicatePluralCase "aa" "=aa1" 143 | , DuplicatePluralCase "aa" "one" 144 | , DuplicatePluralCase "b" "=b2" 145 | , DuplicatePluralCase "b" "two" 146 | ]) 147 | 148 | describe "internal" $ do 149 | describe "unicode" $ do 150 | let lint = lintWith' unsupportedUnicodeRule 151 | 152 | it "does not lint text with emoji" $ do 153 | lint (Message "Message with an emoji ❤️ 🥺") 154 | `shouldBe` Failure (InvalidNonAsciiCharacter <$> fromList "❤️🥺") 155 | 156 | it "does not lint text that is deeply nested with emoji" $ do 157 | lint (Message $ mconcat [Callback' "Hello" mempty, Bool' "Hello" "Message with an emoji 🥺" mempty]) 158 | `shouldBe` Failure (InvalidNonAsciiCharacter <$> fromList "🥺") 159 | 160 | it "lints AST without emoji" $ do 161 | lint (Message "Text without emoji") `shouldBe` Success 162 | 163 | describe "interpolations" $ do 164 | let lint = lintWith' interpolationsRule 165 | -- An example interpolation that's affected by this lint rule. 166 | let f = SelectWild' 167 | 168 | it "lints AST with no interpolations" $ do 169 | lint (Message "hello world") `shouldBe` Success 170 | 171 | it "lints AST with 1 simple interpolation" $ do 172 | lint (Message (String' "Hello")) `shouldBe` Success 173 | 174 | it "lints AST with 1 complex interpolation" $ do 175 | lint (Message (f "Hello" mempty)) `shouldBe` Success 176 | 177 | it "lints AST with 1 complex interpolation and 1 simple interpolation" $ do 178 | lint (Message $ mconcat [f "Hello" mempty, "hello"]) `shouldBe` Success 179 | 180 | it "lints plurals and callbacks" $ do 181 | let cb = flip Callback' mempty 182 | lint (Message $ mconcat [cb "x", cb "y"]) `shouldBe` Success 183 | 184 | let p n = Ordinal' n [] (pure (Zero, mempty)) mempty 185 | lint (Message $ mconcat [p "x", p "y"]) `shouldBe` Success 186 | 187 | it "does not lint AST with 2 or more complex interpolations" $ do 188 | lint (Message $ mconcat [f "x" mempty, f "y" mempty]) 189 | `shouldBe` Failure (pure $ TooManyInterpolations ("x" :| ["y"])) 190 | lint (Message $ mconcat [f "x" mempty, f "y" mempty, f "z" mempty]) 191 | `shouldBe` Failure (pure $ TooManyInterpolations ("x" :| ["y", "z"])) 192 | 193 | it "does not lint AST with nested interpolations" $ do 194 | lint (Message $ mconcat [f "outer" (f "inner" mempty)]) 195 | `shouldBe` Failure (pure $ TooManyInterpolations ("outer" :| ["inner"])) 196 | -------------------------------------------------------------------------------- /test/Intlc/Parser/ICUSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Parser.ICUSpec (spec) where 2 | 3 | import Control.Comonad.Cofree (Cofree ((:<))) 4 | import Intlc.ICU hiding (selectCases) 5 | import Intlc.Parser.Error (MessageParseErr (..), 6 | ParseErr (FailedMsgParse), 7 | ParseFailure) 8 | import Intlc.Parser.ICU 9 | import Prelude 10 | import Test.Hspec 11 | import Test.Hspec.Megaparsec 12 | import Text.Megaparsec (eof, runParser) 13 | import Text.Megaparsec.Error (ErrorFancy (ErrorCustom)) 14 | 15 | -- | Offset parsing won't generally be tested in this module as it just adds 16 | -- noise. 17 | -- 18 | -- Most of our parsers return functions awaiting their next sibling. This ties 19 | -- that knot with a nonsense offset. 20 | nonsenseAnn :: NodeF AnnNode -> AnnNode 21 | nonsenseAnn = (-1 :<) 22 | 23 | sansAnn' :: NodeF AnnNode -> Node 24 | sansAnn' = sansAnn . nonsenseAnn 25 | 26 | fin :: AnnNode 27 | fin = nonsenseAnn Fin 28 | 29 | runParserWith :: ParserState -> Parser a -> Text -> Either ParseFailure a 30 | runParserWith s p = runParser (runReaderT p s) "test" 31 | 32 | parseWith :: ParserState -> Parser (NodeF AnnNode) -> Text -> Either ParseFailure Node 33 | parseWith s p = runParserWith s (sansAnn' <$> p) 34 | 35 | parse :: Parser a -> Text -> Either ParseFailure a 36 | parse = runParserWith $ emptyState { endOfInput = eof } 37 | 38 | parseF :: Parser (AnnNode -> NodeF AnnNode) -> Text -> Either ParseFailure Node 39 | -- The most satisfying line of code I've ever written: 40 | parseF = parse . fmap sansAnn' . flip flap fin 41 | 42 | -- | Message parser sans annotations. 43 | msg :: Parser (Message Node) 44 | msg = fmap sansAnn <$> annMsg 45 | 46 | spec :: Spec 47 | spec = describe "ICU parser" $ do 48 | describe "message" $ do 49 | it "does not tolerate unclosed braces" $ do 50 | parse msg `shouldFailOn` "a { b" 51 | 52 | it "does not tolerate interpolations with a bad type" $ do 53 | parse msg `shouldFailOn` "a {n, badtype} b" 54 | 55 | it "does not tolerate empty braces" $ do 56 | parse msg `shouldFailOn` "a {} b" 57 | 58 | it "does not tolerate empty tags" $ do 59 | parse msg `shouldFailOn` "a <> b" 60 | 61 | describe "plural hash" $ do 62 | it "parses as plaintext outside of plurals" $ do 63 | parse msg "#" `shouldParse` Message "#" 64 | parse msg "{x, select, y {#}}" `shouldParse` 65 | Message (SelectNamed' "x" (pure ("y", "#"))) 66 | 67 | it "parses as arg inside shallow plural" $ do 68 | let n = PluralRef' "n" 69 | parse msg "{n, plural, one {#} other {#}}" `shouldParse` 70 | Message (CardinalInexact' "n" [] (pure (One, n)) n) 71 | 72 | it "parses as nearest arg inside deep plural" $ do 73 | let n = PluralRef' "n" 74 | let i = PluralRef' "i" 75 | parse msg "{n, plural, one {{i, plural, one {#} other {#}}} other {#}}" `shouldParse` 76 | Message (CardinalInexact' "n" [] (pure (One, CardinalInexact' "i" [] (pure (One, i)) i)) n) 77 | 78 | it "parses as arg nested inside other interpolation" $ do 79 | let n = PluralRef' "n" 80 | parse msg "{n, plural, one {#} other {#}}" `shouldParse` 81 | Message (CardinalInexact' "n" [] (pure (One, Callback' "f" n)) n) 82 | 83 | describe "escaping" $ do 84 | it "escapes non-empty contents between single quotes" $ do 85 | parse msg "These are not interpolations: '{word1} {word2}'" `shouldParse` 86 | Message "These are not interpolations: {word1} {word2}" 87 | parse msg "'hello'" `shouldParse` 88 | Message "hello" 89 | parse msg "a {b} '{c}' {d} e" `shouldParse` 90 | Message (mconcat ["a ", String' "b", " {c} ", String' "d", " e"]) 91 | parse msg "''" `shouldParse` Message "" 92 | parse msg "'x'" `shouldParse` Message "x" 93 | parse msg "'x'" `shouldParse` Message "x" 94 | 95 | it "escapes next syntax character following one unclosed single quote" $ do 96 | parse msg "This is not an interpolation: '{word}" `shouldParse` 97 | Message "This is not an interpolation: {word}" 98 | parse msg "'" `shouldParse` Message "" 99 | parse msg "a {b} '{c} {d} e" `shouldParse` 100 | Message (mconcat ["a ", String' "b", " {c} ", String' "d", " e"]) 101 | parse msg "a {b} 'c {d} e" `shouldParse` 102 | Message (mconcat ["a ", String' "b", " 'c ", String' "d", " e"]) 103 | parse msg "{n, plural, =42 {# '#}}" `shouldParse` 104 | let xs = mconcat [PluralRef' "n", " #"] 105 | in Message $ mconcat [CardinalExact' "n" (pure (PluralExact "42", xs))] 106 | 107 | it "escapes two single quotes as one single quote" $ do 108 | parse msg "This '{isn''t}' obvious." `shouldParse` Message "This {isn't} obvious." 109 | parse msg "a {b} ''{c}'' {d} e" `shouldParse` 110 | Message (mconcat ["a ", String' "b", " '", String' "c", "' ", String' "d", " e"]) 111 | 112 | it "ignores one single quote not immediately preceding a syntax character" $ do 113 | parse msg "'" `shouldParse` Message "'" 114 | parse msg "' '" `shouldParse` Message "' '" 115 | parse msg "x'y" `shouldParse` Message "x'y" 116 | 117 | -- As you can see this isn't fun to write out by hand for tests. This one 118 | -- test can suffice for ensuring we're parsing annotations correctly. 119 | it "parses with annotations" $ do 120 | parse annMsg "Hello' {n, plural, one {{name}} other {}}!" `shouldParse` Message 121 | ( 0 :< Char 'H' ( 122 | 1 :< Char 'e' ( 123 | 2 :< Char 'l' ( 124 | 3 :< Char 'l' ( 125 | 4 :< Char 'o' ( 126 | 5 :< Char '\'' ( 127 | 6 :< Char ' ' ( 128 | 7 :< CardinalInexact "n" 129 | mempty 130 | (pure (One, 24 :< String "name" (30 :< Fin))) 131 | (39 :< Fin) ( 132 | 41 :< Char '!' ( 133 | 42 :< Fin 134 | )))))))))) 135 | 136 | describe "interpolation" $ do 137 | it "interpolates appropriately" $ do 138 | parseF interp "{x}" `shouldParse` String' "x" 139 | 140 | it "only accepts alphanumeric identifiers" $ do 141 | parseF interp "{XyZ}" `shouldParse` String' "XyZ" 142 | parseF interp `shouldFailOn` "{x y}" 143 | 144 | it "disallows bad types" $ do 145 | parse msg `shouldFailOn` "{n, enum}" 146 | parse msg `shouldFailOn` "{n, int, one {x} other {y}}" 147 | 148 | describe "bool" $ do 149 | it "requires both bool cases" $ do 150 | parseF interp "{x, boolean, true {y} false {z}}" `shouldParse` Bool' "x" "y" "z" 151 | parseF interp `shouldFailOn` "{x, boolean, true {y}}" 152 | parseF interp `shouldFailOn` "{x, boolean, false {y}}" 153 | 154 | it "enforces case order" $ do 155 | parseF interp `shouldFailOn` "{x, boolean, false {y} true {z}}" 156 | 157 | it "disallows arbitrary cases" $ do 158 | parseF interp `shouldFailOn` "{x, boolean, true {y} nottrue {z}}" 159 | 160 | describe "date" $ do 161 | it "disallows bad formats" $ do 162 | parseF interp "{x, date, short}" `shouldParse` Date' "x" Short 163 | parseF interp `shouldFailOn` "{x, date, miniature}" 164 | 165 | describe "time" $ do 166 | it "disallows bad formats" $ do 167 | parseF interp "{x, time, short}" `shouldParse` Time' "x" Short 168 | parseF interp `shouldFailOn` "{x, time, miniature}" 169 | 170 | describe "callback" $ do 171 | let e i = errFancy i . fancy . ErrorCustom . FailedMsgParse 172 | 173 | it "parses nested" $ do 174 | parseF callback "x{y}z" `shouldParse` 175 | Callback' "f" (Callback' "g" (mconcat ["x", String' "y", "z"])) 176 | 177 | it "requires closing tag" $ do 178 | parseF callback " there" `shouldFailWith` e 1 (NoClosingCallbackTag "hello") 179 | 180 | it "requires opening tag" $ do 181 | parseF callback " " `shouldFailWith` e 2 (NoOpeningCallbackTag "hello") 182 | 183 | it "validates closing tag name" $ do 184 | parseF callback "" `shouldParse` Callback' "hello" mempty 185 | parseF callback "" `shouldFailWith` e 9 (BadClosingCallbackTag "hello" "there") 186 | 187 | it "only accepts alphanumeric identifiers" $ do 188 | parseF callback "" `shouldParse` Callback' "XyZ" mempty 189 | parseF callback `shouldFailOn` "" 190 | 191 | describe "plural" $ do 192 | let cardinalCases' = cardinalCases "arg" <* eof 193 | 194 | it "disallows wildcard not at the end" $ do 195 | parseF cardinalCases' `shouldSucceedOn` "=1 {foo} other {bar}" 196 | parseF cardinalCases' `shouldFailOn` "other {bar} =1 {foo}" 197 | 198 | it "tolerates empty cases" $ do 199 | parseF cardinalCases' `shouldSucceedOn` "=1 {} other {}" 200 | 201 | it "tolerates no non-wildcard cases" $ do 202 | parseF cardinalCases' `shouldSucceedOn` "other {foo}" 203 | 204 | it "requires a wildcard if there are any rule cases" $ do 205 | parseF cardinalCases' `shouldFailOn` "=0 {foo} one {bar}" 206 | parseF cardinalCases' `shouldSucceedOn` "=0 {foo} one {bar} other {baz}" 207 | parseF cardinalCases' `shouldSucceedOn` "=0 {foo} =1 {bar}" 208 | 209 | it "parses literal and plural cases, wildcard, and interpolation node" $ do 210 | parseWith (emptyState { pluralCtxName = Just "xyz" }) (cardinalCases' ?? fin) "=0 {foo} few {bar} other {baz #}" `shouldParse` 211 | CardinalInexact' "arg" (pure (PluralExact "0", "foo")) (pure (Few, "bar")) (mconcat ["baz ", PluralRef' "xyz"]) 212 | 213 | describe "selectordinal" $ do 214 | let ordinalCases' = ordinalCases "arg" <* eof 215 | 216 | it "disallows wildcard not at the end" $ do 217 | parseF ordinalCases' `shouldSucceedOn` "one {foo} other {bar}" 218 | parseF ordinalCases' `shouldFailOn` "other {bar} one {foo}" 219 | 220 | it "tolerates empty cases" $ do 221 | parseF ordinalCases' `shouldSucceedOn` "one {} other {}" 222 | 223 | it "tolerates no non-wildcard cases" $ do 224 | parseF ordinalCases' `shouldSucceedOn` "other {foo}" 225 | 226 | it "requires a wildcard" $ do 227 | parseF ordinalCases' `shouldFailOn` "=0 {foo} one {bar}" 228 | parseF ordinalCases' `shouldSucceedOn` "=0 {foo} one {bar} other {baz}" 229 | 230 | it "parses literal and plural cases, wildcard, and interpolation node" $ do 231 | parseWith (emptyState { pluralCtxName = Just "xyz" }) (ordinalCases' ?? fin) "=0 {foo} few {bar} other {baz #}" `shouldParse` 232 | Ordinal' "arg" (pure (PluralExact "0", "foo")) (pure (Few, "bar")) (mconcat ["baz ", PluralRef' "xyz"]) 233 | 234 | describe "select" $ do 235 | let selectCases' = selectCases "arg" <* eof 236 | 237 | it "disallows wildcard not at the end" $ do 238 | parseF selectCases' "foo {bar} other {baz}" `shouldParse` 239 | SelectNamedWild' "arg" (pure ("foo", "bar")) "baz" 240 | parseF selectCases' `shouldFailOn` "other {bar} foo {baz}" 241 | 242 | it "tolerates empty cases" $ do 243 | parseF selectCases' "x {} other {}" `shouldParse` SelectNamedWild' "arg" (pure ("x", mempty)) mempty 244 | 245 | it "allows no non-wildcard case" $ do 246 | parseF selectCases' "foo {bar}" `shouldParse` SelectNamed' "arg" (pure ("foo", "bar")) 247 | parseF selectCases' "foo {bar} other {baz}" `shouldParse` 248 | SelectNamedWild' "arg" (pure ("foo", "bar")) "baz" 249 | parseF selectCases' "other {foo}" `shouldParse` SelectWild' "arg" "foo" 250 | -------------------------------------------------------------------------------- /test/Intlc/Parser/JSONSpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.Parser.JSONSpec (spec) where 2 | 3 | import Intlc.Core 4 | import qualified Intlc.ICU as ICU 5 | import Intlc.Parser (parseDataset) 6 | import Intlc.Parser.Error (JSONParseErr (..), MessageParseErr (..), 7 | ParseErr (..), ParseFailure) 8 | import Prelude 9 | import Test.Hspec 10 | import Test.Hspec.Megaparsec 11 | import Text.Megaparsec (ErrorFancy (ErrorCustom), ParseError) 12 | import Text.RawString.QQ (r) 13 | 14 | parse :: Text -> Either ParseFailure (Dataset (Translation (ICU.Message ICU.Node))) 15 | parse = fmap datasetSansAnn . parseDataset "test" 16 | 17 | succeedsOn :: Text -> Expectation 18 | succeedsOn = shouldSucceedOn parse 19 | 20 | e :: Int -> ParseErr -> ParseError s ParseErr 21 | e i = errFancy i . fancy . ErrorCustom 22 | 23 | spec :: Spec 24 | spec = describe "JSON parser" $ do 25 | it "parses multiple translations" $ do 26 | succeedsOn [r|{ "f": { "message": "{foo}" }, "g": { "message": "{bar}" } }|] 27 | 28 | it "parses translation data keys in any order" $ do 29 | succeedsOn [r|{ "f": { "message": "{foo}", "backend": "ts", "description": "bar" } }|] 30 | succeedsOn [r|{ "f": { "message": "{foo}", "backend": "ts" } }|] 31 | succeedsOn [r|{ "f": { "message": "{foo}", "description": "bar", "backend": "ts" } }|] 32 | succeedsOn [r|{ "f": { "message": "{foo}", "description": "bar" } }|] 33 | succeedsOn [r|{ "f": { "backend": "ts", "message": "{foo}", "description": "bar" } }|] 34 | succeedsOn [r|{ "f": { "backend": "ts", "message": "{foo}" } }|] 35 | succeedsOn [r|{ "f": { "backend": "ts", "description": "bar", "message": "{foo}" } }|] 36 | succeedsOn [r|{ "f": { "description": "bar", "message": "{foo}", "backend": "ts" } }|] 37 | succeedsOn [r|{ "f": { "description": "bar", "message": "{foo}" } }|] 38 | succeedsOn [r|{ "f": { "description": "bar", "backend": "ts", "message": "{foo}" } }|] 39 | 40 | it "accepts null or absence for optional keys" $ do 41 | succeedsOn [r|{ "f": { "message": "{foo}", "backend": null, "description": null } }|] 42 | succeedsOn [r|{ "f": { "message": "{foo}" } }|] 43 | 44 | it "accepts trailing commas" $ do 45 | succeedsOn [r|{ "f": { "message": "{foo}", }, }|] 46 | 47 | it "rejects duplicate keys" $ do 48 | parse [r|{ 49 | "a": { "message": "{foo}" }, 50 | "b": { "message": "{foo}" }, 51 | "c": { "message": "{foo}" }, 52 | "b": { "message": "{foo}" }, 53 | "b": { "message": "{foo}" }, 54 | "d": { "message": "{foo}" }, 55 | "e": { "message": "{foo}" }, 56 | "e": { "message": "{foo}" } 57 | }|] `shouldFailWithM` 58 | [ e 113 (FailedJSONParse $ DuplicateKey "b") 59 | , e 148 (FailedJSONParse $ DuplicateKey "b") 60 | , e 253 (FailedJSONParse $ DuplicateKey "e") 61 | ] 62 | 63 | it "reports all custom error types simultaneously" $ do 64 | parse [r|{ 65 | "dupeKey": { 66 | "message": "" 67 | }, 68 | "noClosing": { 69 | "message": "bar" 70 | }, 71 | "wrongClosing": { 72 | "message": "" 73 | }, 74 | "dupeKey": { 75 | "message": "" 76 | }, 77 | "ok": { 78 | "message": "{n, number}" 79 | } 80 | }|] `shouldFailWithM` 81 | [ e 94 (FailedMsgParse $ NoClosingCallbackTag "foo") 82 | , e 163 (FailedMsgParse $ BadClosingCallbackTag "foo" "bar") 83 | , e 184 (FailedJSONParse $ DuplicateKey "dupeKey") 84 | ] 85 | 86 | it "doesn't parse interpolation escapes across message boundaries" $ do 87 | let msg x = Translation { message = ICU.Message x, backend = TypeScript, mdesc = Nothing } 88 | 89 | parse [r|{ 90 | "x": { "message": "a'" }, 91 | "y": { "message": "'b" } 92 | }|] `shouldParse` fromList 93 | [ ("x", msg "a'") 94 | , ("y", msg "'b") 95 | ] 96 | 97 | parse [r|{ 98 | "x": { "message": "a'{b" }, 99 | "y": { "message": "c}'d" } 100 | }|] `shouldParse` fromList 101 | [ ("x", msg "a{b") 102 | , ("y", msg "c}'d") 103 | ] 104 | -------------------------------------------------------------------------------- /test/Intlc/PrettifySpec.hs: -------------------------------------------------------------------------------- 1 | module Intlc.PrettifySpec where 2 | 3 | import qualified Data.Text as T 4 | import Intlc.ICU 5 | import Intlc.Prettify (prettify) 6 | import Intlc.Printer (IndentStyle (..)) 7 | import Prelude 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = describe "prettify" $ do 12 | let f x = prettify x . Message 13 | 14 | it "compiles to ICU with multiline formatting" $ do 15 | let ast = mconcat 16 | [ Bool' "hasTags" 17 | (SelectNamed' "type" 18 | (fromList 19 | [ ("overLimit", mconcat [Number' "upperLimit", "+ best free ", String' "formattedListOfTags", " photos on Unsplash"]) 20 | , ("belowLimit", mconcat [Number' "photoTotal", " best free ", String' "formattedListOfTags", " photos on Unsplash"]) 21 | ] 22 | ) 23 | ) 24 | (SelectNamed' "type" 25 | (fromList 26 | [ ("overLimit", mconcat [Number' "upperLimit", "+ best free photos on Unsplash"]) 27 | , ("belowLimit", mconcat [Number' "photoTotal", " best free photos on Unsplash"]) 28 | ] 29 | ) 30 | ) 31 | , " " 32 | , SelectNamed' "sibling" 33 | (fromList 34 | [ ("a", String' "foo") 35 | , ("b", "bar") 36 | ] 37 | ) 38 | ] 39 | let toTabs = T.replace " " "\t" 40 | -- Can't use QuasiQuotes as stylish-haskell removes the trailing whitespace 41 | -- which exists in the current implementation. 42 | let expected = T.intercalate "\n" 43 | [ "{hasTags, boolean, " 44 | , " true {{type, select, " 45 | , " overLimit {{upperLimit, number}+ best free {formattedListOfTags} photos on Unsplash}" 46 | , " belowLimit {{photoTotal, number} best free {formattedListOfTags} photos on Unsplash}" 47 | , " }}" 48 | , " false {{type, select, " 49 | , " overLimit {{upperLimit, number}+ best free photos on Unsplash}" 50 | , " belowLimit {{photoTotal, number} best free photos on Unsplash}" 51 | , " }}" 52 | , "} {sibling, select, " 53 | , " a {{foo}}" 54 | , " b {bar}" 55 | , "}" 56 | ] 57 | -- Some trailing spaces are expected with the current implementation. 58 | f Tabs ast `shouldBe` toTabs expected 59 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/UtilsSpec.hs: -------------------------------------------------------------------------------- 1 | module UtilsSpec where 2 | 3 | import Prelude 4 | import Test.Hspec 5 | import Utils (bun, bunBy) 6 | 7 | spec :: Spec 8 | spec = describe "Utils" $ do 9 | describe "bunBy" $ do 10 | it "returns duplicates from the left as per the predicate" $ do 11 | let xs = [("a" :: Text, 1 :: Int), ("b", 2), ("a", 3), ("c", 4), ("b", 5), ("a", 6)] 12 | let ys = [("a", 3), ("b", 5), ("a", 6)] 13 | 14 | bunBy ((==) `on` fst) xs `shouldBe` ys 15 | 16 | it "behaves equivalently for any foldable structure" $ do 17 | let xs = fromList [("a", 1), ("b", 2), ("a", 3), ("c", 4), ("b", 5), ("a", 6)] :: NonEmpty (Text, Int) 18 | let ys = [("a", 3), ("b", 5), ("a", 6)] 19 | 20 | bunBy ((==) `on` fst) xs `shouldBe` ys 21 | 22 | describe "bun" $ do 23 | it "returns duplicates from the left as per the Eq instance" $ do 24 | bun ["a" :: Text, "b", "a", "c", "b", "a"] `shouldBe` 25 | ["a", "b", "a"] 26 | 27 | it "behaves equivalently for any foldable structure" $ do 28 | bun (fromList ["a", "b", "a", "c", "b", "a"] :: NonEmpty Text) `shouldBe` 29 | ["a", "b", "a"] 30 | --------------------------------------------------------------------------------