├── .ghci ├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── backend ├── Api.hs └── Main.hs ├── elm-street.cabal ├── frontend ├── .gitignore ├── elm.json ├── elmapp.config.js ├── public │ ├── index.html │ └── manifest.json ├── src │ ├── Api.elm │ ├── Core │ │ ├── Decoder.elm │ │ ├── ElmStreet.elm │ │ ├── Encoder.elm │ │ └── Types.elm │ ├── Main.elm │ ├── index.js │ ├── main.css │ └── registerServiceWorker.js └── tests │ ├── Tests.elm │ └── Tests │ └── Golden.elm ├── generate-elm └── Main.hs ├── src ├── Elm.hs ├── Elm │ ├── Aeson.hs │ ├── Ast.hs │ ├── Generate.hs │ ├── Generic.hs │ ├── Print.hs │ └── Print │ │ ├── Common.hs │ │ ├── Decoder.hs │ │ ├── Encoder.hs │ │ └── Types.hs └── Internal │ └── Prettyprinter │ └── Compat.hs ├── stack.yaml ├── test ├── Spec.hs ├── Test │ └── Golden.hs └── golden │ └── oneType.json └── types └── Types.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -XTypeApplications 2 | :set -XDerivingStrategies 3 | :set -XDeriveAnyClass 4 | :set -XDataKinds 5 | import Data.Proxy 6 | import GHC.Generics 7 | import Data.List.NonEmpty (NonEmpty (..)) 8 | import qualified Data.Text as T 9 | import qualified Data.Text.IO as T 10 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [master] 7 | 8 | jobs: 9 | cabal: 10 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | os: [ubuntu-latest] 15 | cabal: ["3.12.1.0"] 16 | ghc: 17 | - 9.0.2 18 | - 9.2.8 19 | - 9.4.8 20 | - 9.6.6 21 | - 9.8.4 22 | - 9.10.1 23 | include: 24 | # Test only with latest GHC on windows and macOS 25 | - os: macOS-latest 26 | ghc: 9.10.1 27 | - os: windows-latest 28 | ghc: 9.10.1 29 | 30 | steps: 31 | - uses: actions/checkout@v4 32 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 33 | 34 | - uses: haskell-actions/setup@v2 35 | id: setup-haskell-cabal 36 | name: Setup Haskell 37 | with: 38 | ghc-version: ${{ matrix.ghc }} 39 | cabal-version: ${{ matrix.cabal }} 40 | 41 | - name: Configure 42 | run: cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 43 | 44 | - name: Freeze 45 | run: cabal freeze 46 | 47 | - uses: actions/cache@v4 48 | name: Cache ~/.cabal/store 49 | with: 50 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 51 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 52 | 53 | - name: Install dependencies 54 | run: cabal build all --only-dependencies 55 | 56 | - name: Build 57 | run: cabal build all 58 | 59 | - name: Test 60 | run: cabal test all 61 | 62 | stack: 63 | name: stack / ghc ${{ matrix.ghc }} 64 | runs-on: ubuntu-latest 65 | strategy: 66 | matrix: 67 | stack: [3.1.1] 68 | ghc: [9.6.6] 69 | 70 | steps: 71 | - uses: actions/checkout@v4 72 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 73 | 74 | - uses: haskell-actions/setup@v2 75 | name: Setup Haskell Stack 76 | with: 77 | ghc-version: ${{ matrix.ghc }} 78 | stack-version: ${{ matrix.stack }} 79 | 80 | - uses: actions/cache@v3 81 | name: Cache ~/.stack 82 | with: 83 | path: ~/.stack 84 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 85 | 86 | - name: Install dependencies 87 | run: stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies 88 | 89 | - name: Build 90 | run: stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 91 | 92 | - name: Test 93 | run: stack test --system-ghc 94 | 95 | frontend: 96 | name: frontend 97 | runs-on: ubuntu-latest 98 | steps: 99 | - uses: actions/checkout@v4 100 | 101 | - name: Setup Node.js environment 102 | uses: actions/setup-node@v4 103 | with: 104 | node-version: 16 105 | 106 | - name: Build and test 107 | working-directory: frontend 108 | run: | 109 | npm install -g create-elm-app@5.22.0 110 | elm-app build 111 | elm-app test 112 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | stack.yaml.lock 27 | 28 | ### IDE/support 29 | # Vim 30 | [._]*.s[a-v][a-z] 31 | [._]*.sw[a-p] 32 | [._]s[a-v][a-z] 33 | [._]sw[a-p] 34 | *~ 35 | tags 36 | 37 | # IntellijIDEA 38 | .idea/ 39 | .ideaHaskellLib/ 40 | *.iml 41 | 42 | # Atom 43 | .haskell-ghc-mod.json 44 | 45 | # VS 46 | .vscode/ 47 | 48 | # Emacs 49 | *# 50 | .dir-locals.el 51 | TAGS 52 | 53 | # other 54 | .DS_Store 55 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | # Import cleanup 8 | - imports: 9 | align: none 10 | list_align: after_alias 11 | pad_module_names: false 12 | long_list_align: inline 13 | empty_list_align: inherit 14 | list_padding: 4 15 | separate_lists: true 16 | space_surround: false 17 | 18 | - language_pragmas: 19 | style: vertical 20 | remove_redundant: true 21 | 22 | # Remove trailing whitespace 23 | - trailing_whitespace: {} 24 | 25 | columns: 100 26 | 27 | newline: native 28 | 29 | language_extensions: 30 | - BangPatterns 31 | - ConstraintKinds 32 | - DataKinds 33 | - DefaultSignatures 34 | - DeriveAnyClass 35 | - DeriveDataTypeable 36 | - DeriveGeneric 37 | - DerivingStrategies 38 | - FlexibleContexts 39 | - FlexibleInstances 40 | - FunctionalDependencies 41 | - GADTs 42 | - GeneralizedNewtypeDeriving 43 | - InstanceSigs 44 | - KindSignatures 45 | - LambdaCase 46 | - MultiParamTypeClasses 47 | - MultiWayIf 48 | - NamedFieldPuns 49 | - NoImplicitPrelude 50 | - OverloadedStrings 51 | - QuasiQuotes 52 | - RecordWildCards 53 | - ScopedTypeVariables 54 | - StandaloneDeriving 55 | - TemplateHaskell 56 | - TupleSections 57 | - TypeApplications 58 | - TypeFamilies 59 | - ViewPatterns 60 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | `elm-street` uses [PVP Versioning][1]. 4 | The changelog is available [on GitHub][2]. 5 | 6 | ## 0.2.2.1 - May 16, 2024 7 | 8 | * Relax version bounds of warp, text and filepath 9 | 10 | ## 0.2.2.0 - Jan 4, 2024 11 | 12 | * Version bumps to allow building with GHC 9.8.1 13 | * Remove GHC 8.10.7 from CI 14 | 15 | ## 0.2.1.1 - Aug 3, 2023 16 | 17 | * Add missing extra-source-files: test/golden/oneType.json to cabal 18 | 19 | ## 0.2.1.0 - Aug 3, 2023 20 | 21 | * Add GHC 9.4.5 and 9.6.2 to CI / tested-with 22 | * Introduce CodeGenOptions to allow customizing record field names. 23 | 24 | ## 0.2.0.0 - Mar 29, 2022 25 | 26 | * Remove GHC 8.4.4 and 8.6.5 from CI / tested-with 27 | * Add GHC 8.10.7, 9.0.2 and 9.2.2 to CI / tested-with 28 | * Support Json.Decode.Value as primitive 29 | * Add primitive to represent NonEmpty lists as (a, List a) on elm side 30 | * Add overlapping instance for Elm String, to ensure that Haskell `String`s are represented as `String` on Elm side (not as `List Char`) 31 | 32 | ## 0.1.0.4 - Jan 28, 2020 33 | 34 | * Bump prettyprinter upper bound to allow building with lts-17.0 35 | 36 | ## 0.1.0.3 - Jun 29, 2020 37 | 38 | * Update to lts-16.2 39 | 40 | ## 0.1.0.2 — Sep 13, 2019 41 | 42 | * [#89](https://github.com/holmusk/elm-street/issues/89): 43 | Regulate parenthesis on complicated types in encoder, decoder and type 44 | generation. 45 | 46 | ## 0.1.0.1 — Sep 6, 2019 47 | 48 | * Fix newtype qualified import bug in `Types.elm` generated module. 49 | * Allow `pretty-printer-1.3` version. 50 | 51 | ## 0.1.0.0 — Sep 6, 2019 52 | 53 | * [#80](https://github.com/holmusk/elm-street/issues/80): 54 | **Important:** *All* encoders for constructors with fields now have `tag` due 55 | to aeson decoder on Haskell side. 56 | 57 | **Migration guide 1:** Rename fields that will have `tag` name on the Elm 58 | side. 59 | 60 | **Migration guide 2:** If you have manual `ToJSON` instances that communicate 61 | with Elm via generated decoders, you need to add `tag` field with the 62 | constructor name: 63 | 64 | ```haskell 65 | data User = User { ... } 66 | 67 | instance ToJSON User where 68 | toJSON = [ "tag" .= ("User" :: Text), ... ] 69 | ``` 70 | 71 | * [#71](https://github.com/holmusk/elm-street/issues/71): 72 | **Breaking change:** Remove **overlapping** instance for `String`. 73 | 74 | **Migration guide:** Use `Text` instead of `String`. 75 | 76 | * [#70](https://github.com/holmusk/elm-street/issues/70): 77 | Use qualified imports of generated types and function in Elm generated files. 78 | * [#74](https://github.com/holmusk/elm-street/issues/74): 79 | Fix unit type `typeRef` encoder and decoder printers. 80 | * [#72](https://github.com/holmusk/elm-street/issues/72): 81 | Use consistent encoders and decoders for unary constructors. 82 | * [#79](https://github.com/holmusk/elm-street/issues/79): 83 | Implement cross-language golden tests. 84 | * [#76](https://github.com/holmusk/elm-street/issues/76): 85 | Support GHC-8.6.5. Use common stanzas. 86 | * [#86](https://github.com/holmusk/elm-street/issues/86): 87 | Refactor `Elm.Print` module and split into multiple smaller modules. 88 | * [#73](https://github.com/holmusk/elm-street/issues/73): 89 | Clarify the restriction with reserved words in documentation. 90 | * [#90](https://github.com/Holmusk/elm-street/issues/90) 91 | Support converting 3-tuples. 92 | * [#6](https://github.com/holmusk/elm-street/issues/6): 93 | Test generated Elm code on CI. 94 | 95 | ## 0.0.1 — Mar 29, 2019 96 | 97 | * [#64](https://github.com/holmusk/elm-street/issues/64): 98 | Fix indentation for the generated enums. 99 | * [#66](https://github.com/holmusk/elm-street/issues/66): 100 | Patch JSON encoders and decoders for sum types with a single field. 101 | 102 | ## 0.0.0 103 | 104 | * Initially created. 105 | 106 | [1]: https://pvp.haskell.org 107 | [2]: https://github.com/Holmusk/elm-street/releases 108 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. 374 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elm-street 2 | 3 | ![logo](https://holmusk.dev/images/projects/elm_street.png) 4 | 5 | [![Hackage](https://img.shields.io/hackage/v/elm-street.svg)](https://hackage.haskell.org/package/elm-street) 6 | [![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](LICENSE) 7 | 8 | Crossing the road between Haskell and Elm. 9 | 10 | ## What is this library about? 11 | 12 | `elm-street` allows you to automatically generate definitions of Elm data types and compatible JSON encoders and decoders 13 | from Haskell types. This helps to avoid writing and maintaining huge chunk of boilerplate code when developing full-stack 14 | applications. 15 | 16 | ## Getting started 17 | 18 | In order to use `elm-street` features, you need to perform the following steps: 19 | 20 | 1. Add `elm-street` to the dependencies of your Haskell package. 21 | 2. Derive the `Elm` typeclass for relevant data types. You also need to derive 22 | JSON instances according to `elm-street` naming scheme. 23 | This can be done like this: 24 | ```haskell 25 | import Elm (Elm, elmStreetParseJson, elmStreetToJson) 26 | 27 | data User = User 28 | { userName :: Text 29 | , userAge :: Int 30 | } deriving (Generic) 31 | deriving anyclass (Elm) 32 | 33 | instance ToJSON User where toJSON = elmStreetToJson 34 | instance FromJSON User where parseJSON = elmStreetParseJson 35 | ``` 36 | > **NOTE:** This requires extensions `-XDerivingStrategies`, `-XDeriveGeneric`, `-XDeriveAnyClass`. 37 | 38 | Alternatively you can use `-XDerivingVia` to remove some boilerplate (available since GHC 8.6.1): 39 | ```haskell 40 | import Elm (Elm, ElmStreet (..)) 41 | 42 | data User = User 43 | { userName :: Text 44 | , userAge :: Int 45 | } deriving (Generic) 46 | deriving (Elm, ToJSON, FromJSON) via ElmStreet User 47 | ``` 48 | 3. Create list of all types you want to expose to Elm: 49 | ```haskell 50 | type Types = 51 | '[ User 52 | , Status 53 | ] 54 | ``` 55 | > **NOTE:** This requires extension `-XDataKinds`. 56 | 4. Use `generateElm` function to output definitions to specified directory under 57 | specified module prefix. 58 | ```haskell 59 | main :: IO () 60 | main = generateElm @Types $ defaultSettings "frontend/src" ["Core", "Generated"] 61 | ``` 62 | > **NOTE:** This requires extension `-XTypeApplications`. 63 | 64 | When executed, the above program generates the following files: 65 | 66 | + `frontend/src/Core/Generated/Types.elm`: `Core.Generated.Types` module with the definitions for the types, as well as show*, read*, un*, and universe* functions as specified in [src/Elm/Print/Types.hs](./src/Elm/Print/Types.hs) 67 | + `frontend/src/Core/Generated/Encoder.elm`: `Core.Generated.Encoder` module with the JSON encoders for the types 68 | + `frontend/src/Core/Generated/Decoder.elm`: `Core.Generated.Decoder` module with the JSON decoders for the types 69 | + `frontend/src/Core/Generated/ElmStreet.elm`: `Core.Generated.ElmStreet` module with bundled helper functions 70 | 71 | ## Elm-side preparations 72 | 73 | If you want to use capabilities provided by `elm-street` in your Elm 74 | application, you need to have several Elm packages preinstalled in the project. You 75 | can install them with the following commands: 76 | 77 | ```shell 78 | elm install elm/time 79 | elm install elm/json 80 | elm install NoRedInk/elm-json-decode-pipeline 81 | elm install rtfeldman/elm-iso8601-date-strings 82 | ``` 83 | 84 | ## Library restrictions 85 | 86 | `Elm-street` is **not** trying to be as general as possible and support every 87 | use-case. The library is opinionated in some decisions and contains several 88 | limitations, specifically: 89 | 90 | 1. Record fields must be prefixed with the type name or its abbreviation. 91 | ```haskell 92 | data UserStatus = UserStatus 93 | { userStatusId :: Id 94 | , userStatusRemarks :: Text 95 | } 96 | 97 | data HealthReading = HealthReading 98 | { hrUser :: User 99 | , hrDate :: UTCTime 100 | , hrWeight :: Double 101 | } 102 | ``` 103 | 2. Data types with type variables are not supported (see [issue #45](https://github.com/Holmusk/elm-street/issues/45) for more details). 104 | Though, if type variables are phantom, you can still implement `Elm` instance which 105 | will generate valid Elm defintions. Here is how you can create `Elm` instance for 106 | `newtype`s with phantom type variables: 107 | ```haskell 108 | newtype Id a = Id { unId :: Text } 109 | 110 | instance Elm (Id a) where 111 | toElmDefinition _ = elmNewtype @Text "Id" "unId" 112 | ``` 113 | 3. Sum types with records are not supported (because it's a bad practice to have 114 | records in sum types). 115 | ```haskell 116 | -- - Not supported 117 | data Address 118 | = Post { postCode :: Text } 119 | | Full { fullStreet :: Text, fullHouse :: Int } 120 | 121 | ``` 122 | 4. Sum types with more than 8 fields in at least one constructor are not 123 | supported. 124 | ```haskell 125 | -- - Not supported 126 | data Foo 127 | = Bar Int Text 128 | | Baz Int Int Text Text Double Double Bool Bool Char 129 | ``` 130 | 5. Records with fields that reference the type itself are not supported. This 131 | limitation is due to the fact that `elm-street` generates `type alias` for 132 | record data type. So the generated Elm type for the following Haskell data 133 | type won't compile in Elm: 134 | ```haskell 135 | data User = User 136 | { userName :: Text 137 | , userFollowers :: [User] 138 | } 139 | ``` 140 | 6. Generated JSON encoders and decoders are consistent with default behavior of 141 | derived `ToJSON/FromJSON` instances from the `aeson` library except you need 142 | to strip record field prefixes. Fortunately, this also can be done 143 | generically. You can use functions from `Elm.Aeson` module to derive `JSON` 144 | instances from the `aeson` package. 145 | 7. Only `UTCTime` Haskell data type is supported and it's translated to `Posix` 146 | type in Elm. 147 | 8. Some words in Elm are considered reserved and naming a record field with one of these words (prefixed with the type name, see 1) will result in the generated Elm files to not compile. So, the following words should not be used as field names: 148 | * `if` 149 | * `then` 150 | * `else` 151 | * `case` 152 | * `of` 153 | * `let` 154 | * `in` 155 | * `type` 156 | * `module` 157 | * `where` 158 | * `import` 159 | * `exposing` 160 | * `as` 161 | * `port` 162 | * `tag` (reserved for constructor name due to `aeson` options) 163 | 9. For newtypes `FromJSON` and `ToJSON` instances should be derived using `newtype` strategy. And `Elm` should be derived using `anyclass` strategy: 164 | ```haskell 165 | newtype Newtype = Newtype Int 166 | deriving newtype (FromJSON, ToJSON) 167 | deriving anyclass (Elm) 168 | ``` 169 | 170 | ## Play with frontend example 171 | 172 | The `frontend` directory contains example of minimal Elm project that shows how 173 | generated types are used. To play with this project, do: 174 | 175 | 1. Build and execute the `generate-elm` binary: 176 | ``` 177 | cabal new-run generate-elm 178 | ``` 179 | 2. Run Haskell backend: 180 | ``` 181 | cabal new-run run-backend 182 | ``` 183 | 3. In separate terminal tab go to the `frontend` folder: 184 | ``` 185 | cd frontend 186 | ``` 187 | 4. Run the frontend: 188 | ``` 189 | elm-app start 190 | ``` 191 | 192 | ## Generated examples 193 | 194 | Below you can see some examples of how Haskell data types are converted to Elm 195 | types with JSON encoders and decoders using the `elm-street` library. 196 | 197 | ### Records 198 | 199 | **Haskell** 200 | 201 | ```haskell 202 | data User = User 203 | { userName :: Text 204 | , userAge :: Int 205 | } deriving (Generic) 206 | deriving (Elm, ToJSON, FromJSON) via ElmStreet User 207 | ``` 208 | 209 | **Elm** 210 | 211 | ```elm 212 | type alias User = 213 | { name : String 214 | , age : Int 215 | } 216 | 217 | encodeUser : User -> Value 218 | encodeUser x = E.object 219 | [ ("name", E.string x.name) 220 | , ("age", E.int x.age) 221 | ] 222 | 223 | decodeUser : Decoder User 224 | decodeUser = D.succeed User 225 | |> required "name" D.string 226 | |> required "age" D.int 227 | ``` 228 | 229 | ### Enums 230 | 231 | **Haskell** 232 | 233 | ```haskell 234 | data RequestStatus 235 | = Approved 236 | | Rejected 237 | | Reviewing 238 | deriving (Generic) 239 | deriving (Elm, ToJSON, FromJSON) via ElmStreet RequestStatus 240 | ``` 241 | 242 | **Elm** 243 | 244 | ```elm 245 | type RequestStatus 246 | = Approved 247 | | Rejected 248 | | Reviewing 249 | 250 | showRequestStatus : RequestStatus -> String 251 | showRequestStatus x = case x of 252 | Approved -> "Approved" 253 | Rejected -> "Rejected" 254 | Reviewing -> "Reviewing" 255 | 256 | readRequestStatus : String -> Maybe RequestStatus 257 | readRequestStatus x = case x of 258 | "Approved" -> Just Approved 259 | "Rejected" -> Just Rejected 260 | "Reviewing" -> Just Reviewing 261 | _ -> Nothing 262 | 263 | universeRequestStatus : List RequestStatus 264 | universeRequestStatus = [Approved, Rejected, Reviewing] 265 | 266 | encodeRequestStatus : RequestStatus -> Value 267 | encodeRequestStatus = E.string << showRequestStatus 268 | 269 | decodeRequestStatus : Decoder RequestStatus 270 | decodeRequestStatus = elmStreetDecodeEnum readRequestStatus 271 | ``` 272 | 273 | ### Newtypes 274 | 275 | **Haskell** 276 | 277 | ```haskell 278 | newtype Age = Age 279 | { unAge :: Int 280 | } deriving (Generic) 281 | deriving newtype (FromJSON, ToJSON) 282 | deriving anyclass (Elm) 283 | ``` 284 | 285 | **Elm** 286 | 287 | ```elm 288 | type alias Age = 289 | { age : Int 290 | } 291 | 292 | encodeAge : Age -> Value 293 | encodeAge x = E.int x.age 294 | 295 | decodeAge : Decoder Age 296 | decodeAge = D.map Age D.int 297 | ``` 298 | 299 | ### Newtypes with phantom types 300 | 301 | **Haskell** 302 | 303 | ```haskell 304 | newtype Id a = Id 305 | { unId :: Text 306 | } deriving (Generic) 307 | deriving newtype (FromJSON, ToJSON) 308 | 309 | instance Elm (Id a) where 310 | toElmDefinition _ = elmNewtype @Text "Id" "unId" 311 | ``` 312 | 313 | **Elm** 314 | 315 | ```elm 316 | type alias Id = 317 | { unId : String 318 | } 319 | 320 | encodeId : Id -> Value 321 | encodeId x = E.string x.unId 322 | 323 | decodeId : Decoder Id 324 | decodeId = D.map Id D.string 325 | ``` 326 | 327 | ### Sum types 328 | 329 | **Haskell** 330 | 331 | ```haskell 332 | data Guest 333 | = Regular Text Int 334 | | Visitor Text 335 | | Blocked 336 | deriving (Generic) 337 | deriving (Elm, ToJSON, FromJSON) via ElmStreet Guest 338 | ``` 339 | 340 | **Elm** 341 | 342 | ```elm 343 | type Guest 344 | = Regular String Int 345 | | Visitor String 346 | | Blocked 347 | 348 | encodeGuest : Guest -> Value 349 | encodeGuest x = E.object <| case x of 350 | Regular x1 x2 -> [("tag", E.string "Regular"), ("contents", E.list identity [E.string x1, E.int x2])] 351 | Visitor x1 -> [("tag", E.string "Visitor"), ("contents", E.string x1)] 352 | Blocked -> [("tag", E.string "Blocked"), ("contents", E.list identity [])] 353 | 354 | decodeGuest : Decoder Guest 355 | decodeGuest = 356 | let decide : String -> Decoder Guest 357 | decide x = case x of 358 | "Regular" -> D.field "contents" <| D.map2 Regular (D.index 0 D.string) (D.index 1 D.int) 359 | "Visitor" -> D.field "contents" <| D.map Visitor D.string 360 | "Blocked" -> D.succeed Blocked 361 | c -> D.fail <| "Guest doesn't have such constructor: " ++ c 362 | in D.andThen decide (D.field "tag" D.string) 363 | ``` 364 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /backend/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Api 4 | ( app 5 | ) where 6 | 7 | import Control.Monad.IO.Class (liftIO) 8 | import Data.Proxy (Proxy (..)) 9 | import Network.Wai (Application) 10 | import Servant.API ((:<|>) (..), (:>), Get, JSON, Post, ReqBody) 11 | import Servant.Server (Handler, Server, serve) 12 | 13 | import Types (OneType, defaultOneType) 14 | 15 | 16 | type TypesApi 17 | -- Get 'OneType' from the backend side 18 | = "get" :> Get '[JSON] OneType 19 | -- Receive 'OneType' from the frontend side 20 | :<|> "post" :> ReqBody '[JSON] OneType :> Post '[JSON] Bool 21 | 22 | typesApi :: Proxy TypesApi 23 | typesApi = Proxy 24 | 25 | typesServer :: Server TypesApi 26 | typesServer = getHandler :<|> postHandler 27 | 28 | getHandler :: Handler OneType 29 | getHandler = liftIO $ putStrLn "Get handler" >> pure defaultOneType 30 | 31 | postHandler :: OneType -> Handler Bool 32 | postHandler = liftIO . (putStrLn "Post handler" >>) . pure . (defaultOneType ==) 33 | 34 | app :: Application 35 | app = serve typesApi typesServer 36 | -------------------------------------------------------------------------------- /backend/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Network.Wai.Handler.Warp (run) 4 | 5 | import Api (app) 6 | 7 | 8 | main :: IO () 9 | main = run 8080 app 10 | -------------------------------------------------------------------------------- /elm-street.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: elm-street 3 | version: 0.2.2.1 4 | synopsis: Crossing the road between Haskell and Elm 5 | description: 6 | `Elm-street` allows you to generate automatically derived from Haskell types 7 | definitions of Elm data types, JSON encoders and decoders. This helps to avoid 8 | writing and maintaining huge chunk of boilerplate code when developing full-stack 9 | applications. 10 | homepage: https://github.com/Holmusk/elm-street 11 | bug-reports: https://github.com/Holmusk/elm-street/issues 12 | license: MPL-2.0 13 | license-file: LICENSE 14 | author: Veronika Romashkina, Dmitrii Kovanikov 15 | maintainer: Holmusk 16 | copyright: 2019 Holmusk 17 | category: Language, Compiler, Elm 18 | build-type: Simple 19 | extra-doc-files: README.md 20 | CHANGELOG.md 21 | extra-source-files: test/golden/oneType.json 22 | tested-with: GHC == 9.0.2 23 | GHC == 9.2.8 24 | GHC == 9.4.8 25 | GHC == 9.6.6 26 | GHC == 9.8.4 27 | GHC == 9.10.1 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/Holmusk/elm-street.git 32 | 33 | common common-options 34 | build-depends: base >= 4.11.1.0 && < 4.22 35 | 36 | ghc-options: -Wall 37 | -Wincomplete-uni-patterns 38 | -Wincomplete-record-updates 39 | -Wcompat 40 | -Widentities 41 | -Wredundant-constraints 42 | -fhide-source-paths 43 | -Wmissing-export-lists 44 | -Wpartial-fields 45 | 46 | default-language: Haskell2010 47 | default-extensions: ConstraintKinds 48 | DeriveGeneric 49 | GeneralizedNewtypeDeriving 50 | InstanceSigs 51 | KindSignatures 52 | LambdaCase 53 | OverloadedStrings 54 | RecordWildCards 55 | ScopedTypeVariables 56 | StandaloneDeriving 57 | TupleSections 58 | TypeApplications 59 | TypeOperators 60 | ViewPatterns 61 | 62 | library 63 | import: common-options 64 | hs-source-dirs: src 65 | exposed-modules: Elm 66 | Elm.Aeson 67 | Elm.Ast 68 | Elm.Generate 69 | Elm.Generic 70 | Elm.Print 71 | Elm.Print.Common 72 | Elm.Print.Decoder 73 | Elm.Print.Encoder 74 | Elm.Print.Types 75 | other-modules: Internal.Prettyprinter.Compat 76 | 77 | build-depends: aeson >= 1.3 78 | , directory ^>= 1.3 79 | , filepath >= 1.4 && < 1.6 80 | , prettyprinter >= 1.2.1 && < 1.8 81 | , text >= 1.2 && <= 3.0 82 | , time 83 | 84 | library types 85 | import: common-options 86 | hs-source-dirs: types 87 | exposed-modules: Types 88 | 89 | build-depends: aeson 90 | , elm-street 91 | , text 92 | , time 93 | 94 | executable generate-elm 95 | import: common-options 96 | hs-source-dirs: generate-elm 97 | main-is: Main.hs 98 | 99 | build-depends: elm-street 100 | , types 101 | , directory 102 | , filepath 103 | , text 104 | 105 | ghc-options: -threaded 106 | -rtsopts 107 | -with-rtsopts=-N 108 | 109 | executable run-backend 110 | import: common-options 111 | hs-source-dirs: backend 112 | main-is: Main.hs 113 | other-modules: Api 114 | 115 | build-depends: servant >= 0.14 116 | , servant-server >= 0.14 117 | , types 118 | , wai ^>= 3.2 119 | , warp < 3.5 120 | 121 | ghc-options: -threaded 122 | -rtsopts 123 | -with-rtsopts=-N 124 | 125 | test-suite elm-street-test 126 | import: common-options 127 | type: exitcode-stdio-1.0 128 | hs-source-dirs: test 129 | main-is: Spec.hs 130 | other-modules: Test.Golden 131 | 132 | build-depends: elm-street 133 | , types 134 | , aeson 135 | , bytestring >= 0.10 136 | , hspec >= 2.7.1 137 | 138 | ghc-options: -threaded 139 | -rtsopts 140 | -with-rtsopts=-N 141 | -------------------------------------------------------------------------------- /frontend/.gitignore: -------------------------------------------------------------------------------- 1 | # Distribution 2 | build/ 3 | 4 | # elm-package generated files 5 | elm-stuff 6 | 7 | # elm-repl generated files 8 | repl-temp-* 9 | 10 | # Dependency directories 11 | node_modules 12 | 13 | # Desktop Services Store on macOS 14 | .DS_Store 15 | -------------------------------------------------------------------------------- /frontend/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "NoRedInk/elm-json-decode-pipeline": "1.0.1", 10 | "elm/browser": "1.0.2", 11 | "elm/core": "1.0.5", 12 | "elm/html": "1.0.0", 13 | "elm/http": "2.0.0", 14 | "elm/json": "1.1.3", 15 | "elm/time": "1.0.0", 16 | "elm/url": "1.0.0", 17 | "rtfeldman/elm-iso8601-date-strings": "1.1.4" 18 | }, 19 | "indirect": { 20 | "elm/bytes": "1.0.8", 21 | "elm/file": "1.0.5", 22 | "elm/parser": "1.1.0", 23 | "elm/virtual-dom": "1.0.3" 24 | } 25 | }, 26 | "test-dependencies": { 27 | "direct": { 28 | "elm-explorations/test": "2.0.1" 29 | }, 30 | "indirect": { 31 | "elm/random": "1.0.0" 32 | } 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /frontend/elmapp.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | inline: true, 3 | historyApiFallback: true, 4 | proxy: 'http://localhost:8080' 5 | } 6 | -------------------------------------------------------------------------------- /frontend/public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 12 | 13 | Elm Street Example 14 | 15 | 16 | 19 |
20 | 21 | 22 | -------------------------------------------------------------------------------- /frontend/public/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "short_name": "Elm Street Example", 3 | "name": "Elm Street library Example of Work", 4 | "icons": [], 5 | "start_url": "./index.html", 6 | "display": "standalone", 7 | "theme_color": "#000000", 8 | "background_color": "#ffffff" 9 | } 10 | -------------------------------------------------------------------------------- /frontend/src/Api.elm: -------------------------------------------------------------------------------- 1 | module Api exposing 2 | ( postOneType 3 | , getOneType 4 | , ResultErr 5 | ) 6 | 7 | import Http exposing (Error) 8 | import Json.Decode as D 9 | 10 | import Core.Decoder exposing (decodeOneType) 11 | import Core.Encoder exposing (encodeOneType) 12 | import Core.Types exposing (OneType) 13 | 14 | 15 | type alias ResultErr a = Result Error a 16 | 17 | getOneType : (ResultErr OneType -> msg) -> Cmd msg 18 | getOneType f = Http.request 19 | { method = "GET" 20 | , headers = [] 21 | , url = "get" 22 | , body = Http.emptyBody 23 | , expect = Http.expectJson f decodeOneType 24 | , timeout = Nothing 25 | , tracker = Nothing 26 | } 27 | 28 | postOneType : OneType -> (ResultErr Bool -> msg) -> Cmd msg 29 | postOneType req f = Http.request 30 | { method = "POST" 31 | , headers = [] 32 | , url = "post" 33 | , body = Http.jsonBody (encodeOneType req) 34 | , timeout = Nothing 35 | , tracker = Nothing 36 | , expect = Http.expectJson f D.bool 37 | } 38 | -------------------------------------------------------------------------------- /frontend/src/Core/Decoder.elm: -------------------------------------------------------------------------------- 1 | module Core.Decoder exposing (..) 2 | 3 | import Iso8601 as Iso 4 | import Json.Decode as D exposing (..) 5 | import Json.Decode.Pipeline as D exposing (required) 6 | 7 | import Core.ElmStreet exposing (..) 8 | import Core.Types as T 9 | 10 | 11 | decodePrims : Decoder T.Prims 12 | decodePrims = D.succeed T.Prims 13 | |> D.hardcoded () 14 | |> required "bool" D.bool 15 | |> required "char" elmStreetDecodeChar 16 | |> required "int" D.int 17 | |> required "float" D.float 18 | |> required "text" D.string 19 | |> required "string" D.string 20 | |> required "time" Iso.decoder 21 | |> required "value" D.value 22 | |> required "maybe" (nullable D.int) 23 | |> required "result" (elmStreetDecodeEither D.int D.string) 24 | |> required "pair" (elmStreetDecodePair elmStreetDecodeChar D.bool) 25 | |> required "triple" (elmStreetDecodeTriple elmStreetDecodeChar D.bool (D.list D.int)) 26 | |> required "list" (D.list D.int) 27 | |> required "nonEmpty" (elmStreetDecodeNonEmpty D.int) 28 | 29 | decodeMyUnit : Decoder T.MyUnit 30 | decodeMyUnit = 31 | let decide : String -> Decoder T.MyUnit 32 | decide x = case x of 33 | "MyUnit" -> D.field "contents" <| D.map T.MyUnit (D.map (always ()) (D.list D.string)) 34 | c -> D.fail <| "MyUnit doesn't have such constructor: " ++ c 35 | in D.andThen decide (D.field "tag" D.string) 36 | 37 | decodeMyResult : Decoder T.MyResult 38 | decodeMyResult = 39 | let decide : String -> Decoder T.MyResult 40 | decide x = case x of 41 | "Ok" -> D.succeed T.Ok 42 | "Err" -> D.field "contents" <| D.map T.Err D.string 43 | c -> D.fail <| "MyResult doesn't have such constructor: " ++ c 44 | in D.andThen decide (D.field "tag" D.string) 45 | 46 | decodeId : Decoder T.Id 47 | decodeId = D.map T.Id D.string 48 | 49 | decodeAge : Decoder T.Age 50 | decodeAge = D.map T.Age D.int 51 | 52 | decodeNewtype : Decoder T.Newtype 53 | decodeNewtype = D.map T.Newtype D.int 54 | 55 | decodeNewtypeList : Decoder T.NewtypeList 56 | decodeNewtypeList = D.map T.NewtypeList (D.list D.int) 57 | 58 | decodeOneConstructor : Decoder T.OneConstructor 59 | decodeOneConstructor = elmStreetDecodeEnum T.readOneConstructor 60 | 61 | decodeRequestStatus : Decoder T.RequestStatus 62 | decodeRequestStatus = elmStreetDecodeEnum T.readRequestStatus 63 | 64 | decodeUser : Decoder T.User 65 | decodeUser = D.succeed T.User 66 | |> required "id" decodeId 67 | |> required "name" D.string 68 | |> required "age" decodeAge 69 | |> required "status" decodeRequestStatus 70 | 71 | decodeGuest : Decoder T.Guest 72 | decodeGuest = 73 | let decide : String -> Decoder T.Guest 74 | decide x = case x of 75 | "Regular" -> D.field "contents" <| D.map2 T.Regular (D.index 0 D.string) (D.index 1 D.int) 76 | "Visitor" -> D.field "contents" <| D.map T.Visitor D.string 77 | "Special" -> D.field "contents" <| D.map T.Special (nullable (D.list D.int)) 78 | "Blocked" -> D.succeed T.Blocked 79 | c -> D.fail <| "Guest doesn't have such constructor: " ++ c 80 | in D.andThen decide (D.field "tag" D.string) 81 | 82 | decodeUserRequest : Decoder T.UserRequest 83 | decodeUserRequest = D.succeed T.UserRequest 84 | |> required "ids" (D.list decodeId) 85 | |> required "limit" D.int 86 | |> required "example" (nullable (elmStreetDecodeEither decodeUser decodeGuest)) 87 | 88 | decodeOneType : Decoder T.OneType 89 | decodeOneType = D.succeed T.OneType 90 | |> required "prims" decodePrims 91 | |> required "myUnit" decodeMyUnit 92 | |> required "myResult" decodeMyResult 93 | |> required "id" decodeId 94 | |> required "age" decodeAge 95 | |> required "newtype" decodeNewtype 96 | |> required "newtypeList" decodeNewtypeList 97 | |> required "oneConstructor" decodeOneConstructor 98 | |> required "requestStatus" decodeRequestStatus 99 | |> required "user" decodeUser 100 | |> required "guests" (D.list decodeGuest) 101 | |> required "userRequest" decodeUserRequest 102 | |> required "nonEmpty" (elmStreetDecodeNonEmpty decodeMyUnit) 103 | 104 | decodeCustomCodeGen : Decoder T.CustomCodeGen 105 | decodeCustomCodeGen = D.succeed T.CustomCodeGen 106 | |> required "customFunTestString" D.string 107 | |> required "customFunTestInt" D.int 108 | -------------------------------------------------------------------------------- /frontend/src/Core/ElmStreet.elm: -------------------------------------------------------------------------------- 1 | module Core.ElmStreet exposing (..) 2 | 3 | import Json.Encode as E exposing (Value) 4 | import Json.Decode as D exposing (Decoder) 5 | import Json.Decode.Pipeline as D exposing (..) 6 | 7 | 8 | elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value 9 | elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc 10 | 11 | elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value 12 | elmStreetEncodeEither encA encB res = E.object <| case res of 13 | Err a -> [("Left", encA a)] 14 | Ok b -> [("Right", encB b)] 15 | 16 | elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value 17 | elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b] 18 | 19 | elmStreetEncodeTriple : (a -> Value) -> (b -> Value) -> (c -> Value) -> (a, b, c) -> Value 20 | elmStreetEncodeTriple encA encB encC (a, b, c) = E.list identity [encA a, encB b, encC c] 21 | 22 | elmStreetEncodeNonEmpty : (a -> Value) -> (a, List a) -> Value 23 | elmStreetEncodeNonEmpty encA (a, xs) = E.list encA <| a :: xs 24 | 25 | decodeStr : (String -> Maybe a) -> String -> Decoder a 26 | decodeStr readX x = case readX x of 27 | Just a -> D.succeed a 28 | Nothing -> D.fail "Constructor not matched" 29 | 30 | elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a 31 | elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string 32 | 33 | elmStreetDecodeChar : Decoder Char 34 | elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string 35 | 36 | elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b) 37 | elmStreetDecodeEither decA decB = D.oneOf 38 | [ D.field "Left" (D.map Err decA) 39 | , D.field "Right" (D.map Ok decB) 40 | ] 41 | 42 | elmStreetDecodePair : Decoder a -> Decoder b -> Decoder (a, b) 43 | elmStreetDecodePair decA decB = D.map2 Tuple.pair (D.index 0 decA) (D.index 1 decB) 44 | 45 | elmStreetDecodeTriple : Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c) 46 | elmStreetDecodeTriple decA decB decC = D.map3 (\a b c -> (a,b,c)) (D.index 0 decA) (D.index 1 decB) (D.index 2 decC) 47 | 48 | elmStreetDecodeNonEmpty : Decoder a -> Decoder (a, List a) 49 | elmStreetDecodeNonEmpty decA = D.list decA |> D.andThen (\xs -> case xs of 50 | h::t -> D.succeed (h, t) 51 | _ -> D.fail "Expecting non-empty array") 52 | 53 | -------------------------------------------------------------------------------- /frontend/src/Core/Encoder.elm: -------------------------------------------------------------------------------- 1 | module Core.Encoder exposing (..) 2 | 3 | import Iso8601 as Iso 4 | import Json.Encode as E exposing (..) 5 | 6 | import Core.ElmStreet exposing (..) 7 | import Core.Types as T 8 | 9 | 10 | encodePrims : T.Prims -> Value 11 | encodePrims x = E.object 12 | [ ("tag", E.string "Prims") 13 | , ("unit", (always <| E.list identity []) x.unit) 14 | , ("bool", E.bool x.bool) 15 | , ("char", (E.string << String.fromChar) x.char) 16 | , ("int", E.int x.int) 17 | , ("float", E.float x.float) 18 | , ("text", E.string x.text) 19 | , ("string", E.string x.string) 20 | , ("time", Iso.encode x.time) 21 | , ("value", Basics.identity x.value) 22 | , ("maybe", (elmStreetEncodeMaybe E.int) x.maybe) 23 | , ("result", (elmStreetEncodeEither E.int E.string) x.result) 24 | , ("pair", (elmStreetEncodePair (E.string << String.fromChar) E.bool) x.pair) 25 | , ("triple", (elmStreetEncodeTriple (E.string << String.fromChar) E.bool (E.list E.int)) x.triple) 26 | , ("list", (E.list E.int) x.list) 27 | , ("nonEmpty", (elmStreetEncodeNonEmpty E.int) x.nonEmpty) 28 | ] 29 | 30 | encodeMyUnit : T.MyUnit -> Value 31 | encodeMyUnit x = E.object <| case x of 32 | T.MyUnit x1 -> [("tag", E.string "MyUnit"), ("contents", (always <| E.list identity []) x1)] 33 | 34 | encodeMyResult : T.MyResult -> Value 35 | encodeMyResult x = E.object <| case x of 36 | T.Ok -> [("tag", E.string "Ok"), ("contents", E.list identity [])] 37 | T.Err x1 -> [("tag", E.string "Err"), ("contents", E.string x1)] 38 | 39 | encodeId : T.Id -> Value 40 | encodeId x = E.string x.unId 41 | 42 | encodeAge : T.Age -> Value 43 | encodeAge x = E.int x.age 44 | 45 | encodeNewtype : T.Newtype -> Value 46 | encodeNewtype = E.int << T.unNewtype 47 | 48 | encodeNewtypeList : T.NewtypeList -> Value 49 | encodeNewtypeList = (E.list E.int) << T.unNewtypeList 50 | 51 | encodeOneConstructor : T.OneConstructor -> Value 52 | encodeOneConstructor = E.string << T.showOneConstructor 53 | 54 | encodeRequestStatus : T.RequestStatus -> Value 55 | encodeRequestStatus = E.string << T.showRequestStatus 56 | 57 | encodeUser : T.User -> Value 58 | encodeUser x = E.object 59 | [ ("tag", E.string "User") 60 | , ("id", encodeId x.id) 61 | , ("name", E.string x.name) 62 | , ("age", encodeAge x.age) 63 | , ("status", encodeRequestStatus x.status) 64 | ] 65 | 66 | encodeGuest : T.Guest -> Value 67 | encodeGuest x = E.object <| case x of 68 | T.Regular x1 x2 -> [("tag", E.string "Regular"), ("contents", E.list identity [E.string x1, E.int x2])] 69 | T.Visitor x1 -> [("tag", E.string "Visitor"), ("contents", E.string x1)] 70 | T.Special x1 -> [("tag", E.string "Special"), ("contents", (elmStreetEncodeMaybe (E.list E.int)) x1)] 71 | T.Blocked -> [("tag", E.string "Blocked"), ("contents", E.list identity [])] 72 | 73 | encodeUserRequest : T.UserRequest -> Value 74 | encodeUserRequest x = E.object 75 | [ ("tag", E.string "UserRequest") 76 | , ("ids", (E.list encodeId) x.ids) 77 | , ("limit", E.int x.limit) 78 | , ("example", (elmStreetEncodeMaybe (elmStreetEncodeEither encodeUser encodeGuest)) x.example) 79 | ] 80 | 81 | encodeOneType : T.OneType -> Value 82 | encodeOneType x = E.object 83 | [ ("tag", E.string "OneType") 84 | , ("prims", encodePrims x.prims) 85 | , ("myUnit", encodeMyUnit x.myUnit) 86 | , ("myResult", encodeMyResult x.myResult) 87 | , ("id", encodeId x.id) 88 | , ("age", encodeAge x.age) 89 | , ("newtype", encodeNewtype x.newtype) 90 | , ("newtypeList", encodeNewtypeList x.newtypeList) 91 | , ("oneConstructor", encodeOneConstructor x.oneConstructor) 92 | , ("requestStatus", encodeRequestStatus x.requestStatus) 93 | , ("user", encodeUser x.user) 94 | , ("guests", (E.list encodeGuest) x.guests) 95 | , ("userRequest", encodeUserRequest x.userRequest) 96 | , ("nonEmpty", (elmStreetEncodeNonEmpty encodeMyUnit) x.nonEmpty) 97 | ] 98 | 99 | encodeCustomCodeGen : T.CustomCodeGen -> Value 100 | encodeCustomCodeGen x = E.object 101 | [ ("tag", E.string "CustomCodeGen") 102 | , ("customFunTestString", E.string x.customFunTestString) 103 | , ("customFunTestInt", E.int x.customFunTestInt) 104 | ] 105 | -------------------------------------------------------------------------------- /frontend/src/Core/Types.elm: -------------------------------------------------------------------------------- 1 | module Core.Types exposing (..) 2 | 3 | import Time exposing (Posix) 4 | import Json.Decode exposing (Value) 5 | 6 | 7 | type alias Prims = 8 | { unit : () 9 | , bool : Bool 10 | , char : Char 11 | , int : Int 12 | , float : Float 13 | , text : String 14 | , string : String 15 | , time : Posix 16 | , value : Value 17 | , maybe : Maybe Int 18 | , result : Result Int String 19 | , pair : (Char, Bool) 20 | , triple : (Char, Bool, List Int) 21 | , list : List Int 22 | , nonEmpty : (Int, List Int) 23 | } 24 | 25 | type MyUnit 26 | = MyUnit () 27 | 28 | type MyResult 29 | = Ok 30 | | Err String 31 | 32 | type alias Id = 33 | { unId : String 34 | } 35 | 36 | type alias Age = 37 | { age : Int 38 | } 39 | 40 | type Newtype 41 | = Newtype Int 42 | 43 | unNewtype : Newtype -> Int 44 | unNewtype (Newtype x) = x 45 | 46 | type NewtypeList 47 | = NewtypeList (List Int) 48 | 49 | unNewtypeList : NewtypeList -> List Int 50 | unNewtypeList (NewtypeList x) = x 51 | 52 | type OneConstructor 53 | = OneConstructor 54 | 55 | showOneConstructor : OneConstructor -> String 56 | showOneConstructor x = case x of 57 | OneConstructor -> "OneConstructor" 58 | 59 | readOneConstructor : String -> Maybe OneConstructor 60 | readOneConstructor x = case x of 61 | "OneConstructor" -> Just OneConstructor 62 | _ -> Nothing 63 | 64 | universeOneConstructor : List OneConstructor 65 | universeOneConstructor = [OneConstructor] 66 | 67 | type RequestStatus 68 | = Approved 69 | | Rejected 70 | | Reviewing 71 | 72 | showRequestStatus : RequestStatus -> String 73 | showRequestStatus x = case x of 74 | Approved -> "Approved" 75 | Rejected -> "Rejected" 76 | Reviewing -> "Reviewing" 77 | 78 | readRequestStatus : String -> Maybe RequestStatus 79 | readRequestStatus x = case x of 80 | "Approved" -> Just Approved 81 | "Rejected" -> Just Rejected 82 | "Reviewing" -> Just Reviewing 83 | _ -> Nothing 84 | 85 | universeRequestStatus : List RequestStatus 86 | universeRequestStatus = [Approved, Rejected, Reviewing] 87 | 88 | type alias User = 89 | { id : Id 90 | , name : String 91 | , age : Age 92 | , status : RequestStatus 93 | } 94 | 95 | type Guest 96 | = Regular String Int 97 | | Visitor String 98 | | Special (Maybe (List Int)) 99 | | Blocked 100 | 101 | type alias UserRequest = 102 | { ids : List Id 103 | , limit : Int 104 | , example : Maybe (Result User Guest) 105 | } 106 | 107 | type alias OneType = 108 | { prims : Prims 109 | , myUnit : MyUnit 110 | , myResult : MyResult 111 | , id : Id 112 | , age : Age 113 | , newtype : Newtype 114 | , newtypeList : NewtypeList 115 | , oneConstructor : OneConstructor 116 | , requestStatus : RequestStatus 117 | , user : User 118 | , guests : List Guest 119 | , userRequest : UserRequest 120 | , nonEmpty : (MyUnit, List MyUnit) 121 | } 122 | 123 | type alias CustomCodeGen = 124 | { customFunTestString : String 125 | , customFunTestInt : Int 126 | } 127 | -------------------------------------------------------------------------------- /frontend/src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Browser 4 | import Html exposing (Html, text, div, h1, h2, button) 5 | import Html.Attributes exposing (class, disabled) 6 | import Html.Events exposing (onClick) 7 | 8 | import Api exposing (ResultErr, getOneType, postOneType) 9 | import Core.Types exposing (OneType) 10 | 11 | ---- MODEL ---- 12 | 13 | type alias Model = 14 | { oneType : Maybe OneType 15 | , getErr : Bool 16 | , postErr : Bool 17 | , postResult : Maybe Bool 18 | } 19 | 20 | init : ( Model, Cmd Msg ) 21 | init = 22 | ( {oneType = Nothing, getErr = False, postErr = False, postResult = Nothing} 23 | , Cmd.none) 24 | 25 | ---- UPDATE ---- 26 | 27 | type Msg 28 | = NoOp 29 | | GetOneType 30 | | GetOneTypeRes (ResultErr OneType) 31 | | PostOneType (Maybe OneType) 32 | | PostOneTypeRes (ResultErr Bool) 33 | | Refresh 34 | 35 | update : Msg -> Model -> ( Model, Cmd Msg ) 36 | update msg model = case msg of 37 | NoOp -> ( model, Cmd.none ) 38 | GetOneType -> (model, getOneType GetOneTypeRes) 39 | GetOneTypeRes res -> case res of 40 | Ok oneType -> ({model| oneType = Just oneType}, Cmd.none) 41 | Err _ -> ({model| getErr = True}, Cmd.none) 42 | PostOneType (Just t) -> (model, postOneType t PostOneTypeRes) 43 | PostOneType _ -> (model, Cmd.none) 44 | PostOneTypeRes res -> case res of 45 | Ok isSame -> ({model| postResult = Just isSame}, Cmd.none) 46 | Err _ -> ({model| postErr = True}, Cmd.none) 47 | Refresh -> init 48 | 49 | ---- VIEW ---- 50 | 51 | view : Model -> Html Msg 52 | view m = div [] 53 | [ h1 [] [text "Elm Street testing application"] 54 | , h2 [] [text "Get 'OneType' endpoint"] 55 | , button [onClick GetOneType] [text "Get OneType"] 56 | , div [class "err"] (if m.getErr then [text "Get errored"] else []) 57 | , h2 [] [text "Get 'OneType' endpoint"] 58 | , button [onClick (PostOneType m.oneType), disabled (isNothing m.oneType)] [text "Post OneType"] 59 | , div [class "err"] (if m.postErr then [text "Post errored"] else []) 60 | , div [] <| case m.postResult of 61 | Just True -> [text "The 'get' and 'post' OneType is the same :)"] 62 | Just False -> [text "The 'get' and 'post' OneType are different :("] 63 | Nothing -> [] 64 | , button [onClick Refresh] [text "Refresh"] 65 | ] 66 | 67 | ---- PROGRAM ---- 68 | 69 | main : Program () Model Msg 70 | main = Browser.element 71 | { view = view 72 | , init = \_ -> init 73 | , update = update 74 | , subscriptions = always Sub.none 75 | } 76 | 77 | -- Util 78 | isNothing : Maybe a -> Bool 79 | isNothing x = case x of 80 | Nothing -> True 81 | _ -> False 82 | -------------------------------------------------------------------------------- /frontend/src/index.js: -------------------------------------------------------------------------------- 1 | import './main.css'; 2 | import { Elm } from './Main.elm'; 3 | import registerServiceWorker from './registerServiceWorker'; 4 | 5 | Elm.Main.init({ 6 | node: document.getElementById('root') 7 | }); 8 | 9 | registerServiceWorker(); 10 | -------------------------------------------------------------------------------- /frontend/src/main.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; 3 | margin: 0; 4 | text-align: center; 5 | color: #293c4b; 6 | } 7 | 8 | h1 {font-size: 30px;} 9 | 10 | img { 11 | margin: 20px 0; 12 | max-width: 200px; 13 | } 14 | -------------------------------------------------------------------------------- /frontend/src/registerServiceWorker.js: -------------------------------------------------------------------------------- 1 | // In production, we register a service worker to serve assets from local cache. 2 | 3 | // This lets the app load faster on subsequent visits in production, and gives 4 | // it offline capabilities. However, it also means that developers (and users) 5 | // will only see deployed updates on the "N+1" visit to a page, since previously 6 | // cached resources are updated in the background. 7 | 8 | // To learn more about the benefits of this model, read https://goo.gl/KwvDNy. 9 | // This link also includes instructions on opting out of this behavior. 10 | 11 | const isLocalhost = Boolean( 12 | window.location.hostname === 'localhost' || 13 | // [::1] is the IPv6 localhost address. 14 | window.location.hostname === '[::1]' || 15 | // 127.0.0.1/8 is considered localhost for IPv4. 16 | window.location.hostname.match( 17 | /^127(?:\.(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)){3}$/ 18 | ) 19 | ); 20 | 21 | export default function register() { 22 | if (process.env.NODE_ENV === 'production' && 'serviceWorker' in navigator) { 23 | // The URL constructor is available in all browsers that support SW. 24 | const publicUrl = new URL(process.env.PUBLIC_URL, window.location); 25 | if (publicUrl.origin !== window.location.origin) { 26 | // Our service worker won't work if PUBLIC_URL is on a different origin 27 | // from what our page is served on. This might happen if a CDN is used to 28 | // serve assets; see https://github.com/facebookincubator/create-react-app/issues/2374 29 | return; 30 | } 31 | 32 | window.addEventListener('load', () => { 33 | const swUrl = `${process.env.PUBLIC_URL}/service-worker.js`; 34 | 35 | if (!isLocalhost) { 36 | // Is not local host. Just register service worker 37 | registerValidSW(swUrl); 38 | } else { 39 | // This is running on localhost. Lets check if a service worker still exists or not. 40 | checkValidServiceWorker(swUrl); 41 | } 42 | }); 43 | } 44 | } 45 | 46 | function registerValidSW(swUrl) { 47 | navigator.serviceWorker 48 | .register(swUrl) 49 | .then(registration => { 50 | registration.onupdatefound = () => { 51 | const installingWorker = registration.installing; 52 | installingWorker.onstatechange = () => { 53 | if (installingWorker.state === 'installed') { 54 | if (navigator.serviceWorker.controller) { 55 | // At this point, the old content will have been purged and 56 | // the fresh content will have been added to the cache. 57 | // It's the perfect time to display a "New content is 58 | // available; please refresh." message in your web app. 59 | console.log('New content is available; please refresh.'); 60 | } else { 61 | // At this point, everything has been precached. 62 | // It's the perfect time to display a 63 | // "Content is cached for offline use." message. 64 | console.log('Content is cached for offline use.'); 65 | } 66 | } 67 | }; 68 | }; 69 | }) 70 | .catch(error => { 71 | console.error('Error during service worker registration:', error); 72 | }); 73 | } 74 | 75 | function checkValidServiceWorker(swUrl) { 76 | // Check if the service worker can be found. If it can't reload the page. 77 | fetch(swUrl) 78 | .then(response => { 79 | // Ensure service worker exists, and that we really are getting a JS file. 80 | if ( 81 | response.status === 404 || 82 | response.headers.get('content-type').indexOf('javascript') === -1 83 | ) { 84 | // No service worker found. Probably a different app. Reload the page. 85 | navigator.serviceWorker.ready.then(registration => { 86 | registration.unregister().then(() => { 87 | window.location.reload(); 88 | }); 89 | }); 90 | } else { 91 | // Service worker found. Proceed as normal. 92 | registerValidSW(swUrl); 93 | } 94 | }) 95 | .catch(() => { 96 | console.log( 97 | 'No internet connection found. App is running in offline mode.' 98 | ); 99 | }); 100 | } 101 | 102 | export function unregister() { 103 | if ('serviceWorker' in navigator) { 104 | navigator.serviceWorker.ready.then(registration => { 105 | registration.unregister(); 106 | }); 107 | } 108 | } 109 | -------------------------------------------------------------------------------- /frontend/tests/Tests.elm: -------------------------------------------------------------------------------- 1 | module Tests exposing (..) 2 | 3 | import Expect 4 | import Json.Encode as E exposing (encode) 5 | import Json.Decode exposing (decodeString) 6 | import Test exposing (..) 7 | import Time exposing (millisToPosix) 8 | import Result as R 9 | 10 | import Core.Decoder exposing (decodeOneType) 11 | import Core.Encoder exposing (encodeOneType) 12 | import Core.Types exposing (..) 13 | import Core.Types as T exposing (MyResult (..)) 14 | import Tests.Golden exposing (goldenOneTypeJson) 15 | 16 | -- Check out https://package.elm-lang.org/packages/elm-explorations/test/latest to learn more about testing in Elm! 17 | 18 | 19 | all : Test 20 | all = 21 | let oneTypeE : String 22 | oneTypeE = encode 0 <| encodeOneType defaultOneType 23 | in 24 | describe "Encode / Decode Golden Test" 25 | [ test "Elm Type -> Json -> Elm Type == default" <| \_ -> Expect.equal 26 | (decodeString decodeOneType oneTypeE) 27 | (R.Ok defaultOneType) 28 | , test "Golden Json -> Elm == default" <| \_ -> Expect.equal 29 | (decodeString decodeOneType goldenOneTypeJson) 30 | (R.Ok defaultOneType) 31 | ] 32 | 33 | defaultOneType : OneType 34 | defaultOneType = 35 | let 36 | guestRegular : Guest 37 | guestRegular = Regular "nice" 7 38 | guestVisitor : Guest 39 | guestVisitor = Visitor "new-guest" 40 | guestBlocked : Guest 41 | guestBlocked = Blocked 42 | in 43 | { prims = 44 | { unit = () 45 | , bool = True 46 | , char = 'a' 47 | , int = 42 48 | , float = 36.6 49 | , text = "heh" 50 | , string = "bye" 51 | , value = E.object 52 | [ ("nullField", E.null) 53 | , ("boolField", E.bool True) 54 | , ("numberField", E.int 1) 55 | , ("stringField", E.string "hi") 56 | , ("arrayField", E.list E.int [1,2,3]) 57 | , ("objectField", E.object []) 58 | ] 59 | , time = millisToPosix 1550793600000 -- UTCTime (fromGregorian 2019 2 22) 0 60 | , maybe = Just 12 61 | , result = R.Err 666 62 | , pair = ('o', False) 63 | , triple = ('o', False, [0]) 64 | , list = [1, 2, 3, 4, 5] 65 | , nonEmpty = (1, []) 66 | } 67 | , myUnit = MyUnit () 68 | , myResult = T.Err "clashing test" 69 | , id = Id "myId" 70 | , age = Age 18 71 | , newtype = Newtype 666 72 | , newtypeList = NewtypeList [123] 73 | , oneConstructor = OneConstructor 74 | , requestStatus = Reviewing 75 | , user = User (Id "1") "not-me" (Age 100) Approved 76 | , guests = [guestRegular, guestVisitor, guestBlocked] 77 | , userRequest = 78 | { ids = [Id "1", Id "2"] 79 | , limit = 123 80 | , example = Just (R.Ok Blocked) 81 | } 82 | , nonEmpty = (MyUnit (), [MyUnit ()]) 83 | } 84 | -------------------------------------------------------------------------------- /frontend/tests/Tests/Golden.elm: -------------------------------------------------------------------------------- 1 | module Tests.Golden exposing (goldenOneTypeJson) 2 | 3 | goldenOneTypeJson : String 4 | goldenOneTypeJson = 5 | """ 6 | { 7 | "tag": "OneType", 8 | "prims": { 9 | "maybe": 12, 10 | "list": [ 11 | 1, 12 | 2, 13 | 3, 14 | 4, 15 | 5 16 | ], 17 | "tag": "Prims", 18 | "time": "2019-02-22T00:00:00Z", 19 | "text": "heh", 20 | "string": "bye", 21 | "result": { 22 | "Left": 666 23 | }, 24 | "pair": [ 25 | "o", 26 | false 27 | ], 28 | "triple": [ 29 | "o", 30 | false, 31 | [0] 32 | ], 33 | "float": 36.6, 34 | "char": "a", 35 | "int": 42, 36 | "bool": true, 37 | "unit": [], 38 | "nonEmpty": [1], 39 | "value": { 40 | "boolField": true, 41 | "numberField": 1, 42 | "stringField": "hi", 43 | "objectField": {}, 44 | "arrayField": [1,2,3], 45 | "nullField": null 46 | } 47 | }, 48 | "myUnit": { 49 | "tag": "MyUnit", 50 | "contents": [] 51 | }, 52 | "myResult": { 53 | "tag": "Err", 54 | "contents": "clashing test" 55 | }, 56 | "userRequest": { 57 | "tag": "UserRequest", 58 | "example": { 59 | "Right": { 60 | "tag": "Blocked" 61 | } 62 | }, 63 | "ids": [ 64 | "1", 65 | "2" 66 | ], 67 | "limit": 123 68 | }, 69 | "age": 18, 70 | "newtype": 666, 71 | "newtypeList": [123], 72 | "oneConstructor": "OneConstructor", 73 | "user": { 74 | "status": "Approved", 75 | "tag": "User", 76 | "age": 100, 77 | "name": "not-me", 78 | "id": "1" 79 | }, 80 | "id": "myId", 81 | "requestStatus": "Reviewing", 82 | "guests": [ 83 | { 84 | "tag": "Regular", 85 | "contents": [ 86 | "nice", 87 | 7 88 | ] 89 | }, 90 | { 91 | "tag": "Visitor", 92 | "contents": "new-guest" 93 | }, 94 | { 95 | "tag": "Blocked" 96 | } 97 | ], 98 | "nonEmpty": [ 99 | { 100 | "tag": "MyUnit", 101 | "contents": [] 102 | }, 103 | { 104 | "tag": "MyUnit", 105 | "contents": [] 106 | } 107 | ] 108 | } 109 | """ 110 | -------------------------------------------------------------------------------- /generate-elm/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | {- | Generates Elm types from Haskell @types@ internal library. 4 | 5 | The generated files can be found in the @elm-example/src@ folder. 6 | -} 7 | 8 | module Main (main) where 9 | 10 | import Data.Text (Text) 11 | import Elm (defaultSettings, generateElm) 12 | import System.Directory (createDirectoryIfMissing) 13 | import System.FilePath (()) 14 | import Types (Types) 15 | 16 | import qualified Data.Text as T 17 | import qualified Data.Text.IO as TIO 18 | 19 | 20 | main :: IO () 21 | main = do 22 | -- Generate Types, Encoders, Decoders 23 | generateElm @Types $ defaultSettings "frontend/src" ["Core"] 24 | 25 | -- Generate JSON string in Elm files for testing purposes 26 | golden <- TIO.readFile "test/golden/oneType.json" 27 | generateGoldenType golden 28 | 29 | {- | 30 | 1. Reads the JSON file created for testing: @test/golden/oneType.json@ 31 | 2. Creates Elm module with the function that is the string of the read content. 32 | This file can be found at @frontend/tests/Tests/Golden.elm@. 33 | -} 34 | generateGoldenType :: Text -> IO () 35 | generateGoldenType c = do 36 | let path = "frontend/tests/Tests" 37 | createDirectoryIfMissing True path 38 | TIO.writeFile (path "Golden.elm") golden 39 | where 40 | golden :: Text 41 | golden = T.unlines $ 42 | [ "module Tests.Golden exposing (goldenOneTypeJson)" 43 | , "" 44 | , "goldenOneTypeJson : String" 45 | , "goldenOneTypeJson =" 46 | ] ++ map (" " <>) 47 | ( "\"\"\"" : T.lines c ++ [ "\"\"\"" ] 48 | ) 49 | -------------------------------------------------------------------------------- /src/Elm.hs: -------------------------------------------------------------------------------- 1 | {- | Library for generic conversion of data types from Haskell to Elm. 2 | -} 3 | 4 | module Elm 5 | ( module Elm.Aeson 6 | , module Elm.Ast 7 | , module Elm.Generate 8 | , module Elm.Generic 9 | , module Elm.Print 10 | ) where 11 | 12 | import Elm.Aeson 13 | import Elm.Ast 14 | import Elm.Generate 15 | import Elm.Generic 16 | import Elm.Print 17 | -------------------------------------------------------------------------------- /src/Elm/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | {- | Options used to derive FromJSON/ToJSON instance. These options generally 6 | comply to @elm-street@ rules regarding names. 7 | -} 8 | 9 | module Elm.Aeson 10 | ( elmStreetParseJson 11 | , elmStreetParseJsonWith 12 | , elmStreetToJson 13 | , elmStreetToJsonWith 14 | , elmStreetJsonOptions 15 | 16 | , ElmStreet (..) 17 | ) where 18 | 19 | import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options (..), ToJSON (..), Value, Zero, 20 | defaultOptions, genericParseJSON, genericToJSON) 21 | import Data.Aeson.Types (Parser) 22 | import GHC.Generics (Generic, Rep) 23 | import Type.Reflection (Typeable) 24 | 25 | import Elm.Generic (Elm (..), CodeGenOptions (..), GenericElmDefinition (..), ElmStreetGenericConstraints, defaultCodeGenOptions) 26 | 27 | import qualified Data.Text as T 28 | import qualified GHC.Generics as Generic (from) 29 | 30 | 31 | {- | Allows to create 'Data.Aeson.FromJSON' instance for data types supported by 32 | @elm-street@. Strips data type name prefix from every field. 33 | 34 | __Example:__ 35 | 36 | The following @JSON@ 37 | 38 | @ 39 | { \"name\": \"John\" 40 | , \"age\": 42 41 | } 42 | @ 43 | 44 | is decoded in the following way for each of the specified types: 45 | 46 | +-------------------------------+--------------------------+ 47 | | Haskell data type | Parsed type | 48 | +===============================+==========================+ 49 | | @ | @ | 50 | | data User = User | User | 51 | | { userName :: String | { userName = \"John\" | 52 | | , userAge :: Int | , userAge = 42 | 53 | | } | } | 54 | | @ | @ | 55 | +-------------------------------+--------------------------+ 56 | | | | 57 | | @ | @ | 58 | | data LongUser = LongUser | LongUser | 59 | | { luName :: String | { luName = \"John\" | 60 | | , luAge :: Int | , luAge = 42 | 61 | | } | } | 62 | | @ | @ | 63 | +-------------------------------+--------------------------+ 64 | | @ | @ | 65 | | data SimpleUser = SimpleUser | SimpleUser | 66 | | { name :: String | { name = \"John\" | 67 | | , age :: Int | , age = 42 | 68 | | } | } | 69 | | @ | @ | 70 | +-------------------------------+--------------------------+ 71 | 72 | >>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show) 73 | >>> instance FromJSON User where parseJSON = elmStreetParseJson 74 | >>> decode @User "{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}" 75 | Just (User {userName = "John", userAge = 42}) 76 | 77 | 78 | >>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show) 79 | >>> instance FromJSON VeryLongType where parseJSON = elmStreetParseJson 80 | >>> decode @VeryLongType "{\"age\":42,\"name\":\"John\",\"tag\":\"VeryLongType\"}" 81 | Just (VeryLongType {vltName = "John", vltAge = 42}) 82 | 83 | -} 84 | elmStreetParseJson 85 | :: forall a . 86 | (Typeable a, Generic a, GFromJSON Zero (Rep a)) 87 | => Value 88 | -> Parser a 89 | elmStreetParseJson = elmStreetParseJsonWith (defaultCodeGenOptions @a) 90 | 91 | {- | Use custom 'CodeGenOptions' to customize the behavior of derived FromJSON instance. 92 | -} 93 | elmStreetParseJsonWith 94 | :: forall a . 95 | (Generic a, GFromJSON Zero (Rep a)) 96 | => CodeGenOptions 97 | -> Value 98 | -> Parser a 99 | elmStreetParseJsonWith options = genericParseJSON (elmStreetJsonOptions options) 100 | 101 | {- | Allows to create 'Data.Aeson.ToJSON' instance for types supported by @elm-street@. 102 | Strips type name prefix from every record field. 103 | 104 | >>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show) 105 | >>> instance ToJSON User where toJSON = elmStreetToJson 106 | >>> encode $ User { userName = "John", userAge = 42 } 107 | "{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}" 108 | 109 | >>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show) 110 | >>> instance ToJSON VeryLongType where toJSON = elmStreetToJson 111 | >>> encode $ VeryLongType {vltName = "John", vltAge = 42} 112 | "{\"age\":42,\"name\":\"John\",\"tag\":\"VeryLongType\"}" 113 | 114 | >>> data User = User { name :: String, age :: Int } deriving (Generic, Show) 115 | >>> instance ToJSON User where toJSON = elmStreetToJson 116 | >>> encode $ User { name = "John", age = 42 } 117 | "{\"age\":42,\"name\":\"John\",\"tag\":\"User\"}" 118 | -} 119 | elmStreetToJson 120 | :: forall a . 121 | (Typeable a, Generic a, GToJSON Zero (Rep a)) 122 | => a 123 | -> Value 124 | elmStreetToJson = elmStreetToJsonWith (defaultCodeGenOptions @a) 125 | 126 | {- | Use custom 'CodeGenOptions' to customize the behavior of derived ToJSON instance. 127 | -} 128 | elmStreetToJsonWith 129 | :: forall a . 130 | (Generic a, GToJSON Zero (Rep a)) 131 | => CodeGenOptions 132 | -> a 133 | -> Value 134 | elmStreetToJsonWith options = genericToJSON (elmStreetJsonOptions options) 135 | 136 | -- | Build @elm-street@ compatible 'Data.Aeson.Options' from 'CodeGenOptions'. 137 | elmStreetJsonOptions :: CodeGenOptions -> Options 138 | elmStreetJsonOptions options = defaultOptions 139 | { fieldLabelModifier = T.unpack . cgoFieldLabelModifier options . T.pack 140 | , tagSingleConstructors = True 141 | } 142 | 143 | {- | Newtype for reusing in @DerivingVia@. 144 | 145 | In order to use it with your type @MyType@ add the following deriving to your type: 146 | 147 | @ 148 | __deriving__ (Elm, ToJSON, FromJSON) __via__ ElmStreet MyType 149 | @ 150 | -} 151 | newtype ElmStreet a = ElmStreet 152 | { unElmStreet :: a 153 | } 154 | 155 | instance (ElmStreetGenericConstraints a, Typeable a) => Elm (ElmStreet a) where 156 | toElmDefinition _ = genericToElmDefinition (defaultCodeGenOptions @a) 157 | $ Generic.from (error "Proxy for generic elm was evaluated" :: a) 158 | 159 | instance (Typeable a, Generic a, GToJSON Zero (Rep a)) => ToJSON (ElmStreet a) where 160 | toJSON = elmStreetToJson . unElmStreet 161 | 162 | instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (ElmStreet a) where 163 | parseJSON = fmap ElmStreet . elmStreetParseJson 164 | -------------------------------------------------------------------------------- /src/Elm/Ast.hs: -------------------------------------------------------------------------------- 1 | {- | AST representing structure of Elm types. Haskell generic representation is 2 | converted to this AST which later is going to be pretty-printed. 3 | -} 4 | 5 | module Elm.Ast 6 | ( ElmDefinition (..) 7 | 8 | , ElmRecord (..) 9 | , ElmType (..) 10 | , ElmPrim (..) 11 | 12 | , ElmRecordField (..) 13 | , ElmConstructor (..) 14 | , isEnum 15 | , getConstructorNames 16 | 17 | , TypeName (..) 18 | , TypeRef (..) 19 | , definitionToRef 20 | ) where 21 | 22 | import Data.List.NonEmpty (NonEmpty, toList) 23 | import Data.Text (Text) 24 | 25 | 26 | -- | Elm data type definition. 27 | data ElmDefinition 28 | = DefRecord !ElmRecord 29 | | DefType !ElmType 30 | | DefPrim !ElmPrim 31 | deriving (Show) 32 | 33 | -- | AST for @record type alias@ in Elm. 34 | data ElmRecord = ElmRecord 35 | { elmRecordName :: !Text -- ^ Name of the record 36 | , elmRecordFields :: !(NonEmpty ElmRecordField) -- ^ List of fields 37 | , elmRecordIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ 38 | } deriving (Show) 39 | 40 | -- | Single field of @record type alias@. 41 | data ElmRecordField = ElmRecordField 42 | { elmRecordFieldType :: !TypeRef 43 | , elmRecordFieldName :: !Text 44 | } deriving (Show) 45 | 46 | -- | Wrapper for name of the type. 47 | newtype TypeName = TypeName 48 | { unTypeName :: Text 49 | } deriving (Show) 50 | 51 | -- | AST for @type@ in Elm. 52 | data ElmType = ElmType 53 | { elmTypeName :: !Text -- ^ Name of the data type 54 | , elmTypeVars :: ![Text] -- ^ List of type variables; currently only phantom variables 55 | , elmTypeIsNewtype :: !Bool -- ^ 'True' if Haskell type is a @newtype@ 56 | , elmTypeConstructors :: !(NonEmpty ElmConstructor) -- ^ List of constructors 57 | } deriving (Show) 58 | 59 | -- | Constructor of @type@. 60 | data ElmConstructor = ElmConstructor 61 | { elmConstructorName :: !Text -- ^ Name of the constructor 62 | , elmConstructorFields :: ![TypeRef] -- ^ Fields of the constructor 63 | } deriving (Show) 64 | 65 | -- | Checks if the given 'ElmType' is Enum. 66 | isEnum :: ElmType -> Bool 67 | isEnum ElmType{..} = null elmTypeVars && null (foldMap elmConstructorFields elmTypeConstructors) 68 | 69 | -- | Gets the list of the constructor names. 70 | getConstructorNames :: ElmType -> [Text] 71 | getConstructorNames ElmType{..} = map elmConstructorName $ toList elmTypeConstructors 72 | 73 | -- | Primitive elm types; hardcoded by the language. 74 | data ElmPrim 75 | = ElmUnit -- ^ @()@ type in elm 76 | | ElmNever -- ^ @Never@ type in elm, analogous to Void in Haskell 77 | | ElmBool -- ^ @Bool@ 78 | | ElmChar -- ^ @Char@ 79 | | ElmInt -- ^ @Int@ 80 | | ElmFloat -- ^ @Float@ 81 | | ElmString -- ^ @String@ 82 | | ElmTime -- ^ @Posix@ in elm, @UTCTime@ in Haskell 83 | | ElmValue -- ^ @Json.Encode.Value@ in elm, @Data.Aeson.Value@ in Haskell 84 | | ElmMaybe !TypeRef -- ^ @Maybe T@ 85 | | ElmResult !TypeRef !TypeRef -- ^ @Result A B@ in elm 86 | | ElmPair !TypeRef !TypeRef -- ^ @(A, B)@ in elm 87 | | ElmTriple !TypeRef !TypeRef !TypeRef -- ^ @(A, B, C)@ in elm 88 | | ElmList !TypeRef -- ^ @List A@ in elm 89 | | ElmNonEmptyPair !TypeRef -- ^ @NonEmpty A@ represented by @(A, List A)@ in elm 90 | deriving (Show) 91 | 92 | -- | Reference to another existing type. 93 | data TypeRef 94 | = RefPrim !ElmPrim 95 | | RefCustom !TypeName 96 | deriving (Show) 97 | 98 | -- | Extracts reference to the existing data type type from some other type elm defintion. 99 | definitionToRef :: ElmDefinition -> TypeRef 100 | definitionToRef = \case 101 | DefRecord ElmRecord{..} -> RefCustom $ TypeName elmRecordName 102 | DefType ElmType{..} -> RefCustom $ TypeName elmTypeName 103 | DefPrim elmPrim -> RefPrim elmPrim 104 | -------------------------------------------------------------------------------- /src/Elm/Generate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Elm.Generate 7 | ( Settings (..) 8 | , defaultSettings 9 | , generateElm 10 | 11 | -- * Internal helpers 12 | , RenderElm (..) 13 | ) where 14 | 15 | import Data.Kind (Type) 16 | import Data.List (intercalate) 17 | import Data.Proxy (Proxy (..)) 18 | import Data.Text (Text) 19 | import System.Directory (createDirectoryIfMissing) 20 | import System.FilePath ((<.>), ()) 21 | 22 | import Elm.Generic (Elm (..)) 23 | import Elm.Print (decodeChar, decodeEither, decodeEnum, decodePair, decodeTriple, decodeNonEmpty, encodeEither, encodeMaybe, encodeNonEmpty, 24 | encodePair, encodeTriple, prettyShowDecoder, prettyShowDefinition, prettyShowEncoder) 25 | 26 | import qualified Data.Text as T 27 | import qualified Data.Text.IO as TIO 28 | 29 | 30 | -- | Settings for outputting generated Elm code. 31 | data Settings = Settings 32 | { settingsDirectory :: !FilePath -- ^ Directory to put generated files, e.g. @frontend\/src@ 33 | , settingsModule :: ![FilePath] -- ^ List of module parts, like @["ABC", "Core"]@ 34 | , settingsTypesFile :: !FilePath -- ^ File name for module with types, e.g. @Types@ 35 | , settingsEncoderFile :: !FilePath -- ^ File name for module with JSON encoders, e.g. @Encoder@ 36 | , settingsDecoderFile :: !FilePath -- ^ File name for module with JSON decoders, e.g. @Decoder@ 37 | } 38 | 39 | {- | Default settings for generating Elm definitions. You only need to pass name 40 | of the directory and module path prefix. Other settings parameters set to: 41 | 42 | 1. 'settingsTypesFile': @Types@ 43 | 2. 'settingsEncoderFile': @Encoder@ 44 | 3. 'settingsDecoderFile': @Decoder@ 45 | -} 46 | defaultSettings :: FilePath -> [FilePath] -> Settings 47 | defaultSettings settingsDirectory settingsModule = Settings 48 | { settingsTypesFile = "Types" 49 | , settingsEncoderFile = "Encoder" 50 | , settingsDecoderFile = "Decoder" 51 | , .. 52 | } 53 | 54 | -- | Typeclass for generating elm definitions for the list of types. 55 | class RenderElm (types :: [Type]) where 56 | renderType :: [Text] 57 | renderEncoder :: [Text] 58 | renderDecoder :: [Text] 59 | 60 | instance RenderElm '[] where 61 | renderType = [] 62 | renderEncoder = [] 63 | renderDecoder = [] 64 | 65 | instance (Elm t, RenderElm ts) => RenderElm (t ': ts) where 66 | renderType = "" : toElmTypeSource @t : renderType @ts 67 | renderEncoder = "" : toElmEncoderSource @t : renderEncoder @ts 68 | renderDecoder = "" : toElmDecoderSource @t : renderDecoder @ts 69 | 70 | toElmTypeSource :: forall a . Elm a => Text 71 | toElmTypeSource = prettyShowDefinition $ toElmDefinition $ Proxy @a 72 | 73 | toElmEncoderSource :: forall a . Elm a => Text 74 | toElmEncoderSource = prettyShowEncoder $ toElmDefinition $ Proxy @a 75 | 76 | toElmDecoderSource :: forall a . Elm a => Text 77 | toElmDecoderSource = prettyShowDecoder $ toElmDefinition $ Proxy @a 78 | 79 | {- | Generate elm definitions for the list of types. This function is supposed 80 | to be called like this: 81 | 82 | @ 83 | __type__ Types = 84 | '[ User 85 | , UserStatus 86 | , Measure 87 | ] 88 | 89 | main :: IO () 90 | main = generateElm @Types $ defaultSettings "frontend\/src\/" ["ABC", "Core"] 91 | @ 92 | -} 93 | generateElm :: forall (ts :: [Type]) . RenderElm ts => Settings -> IO () 94 | generateElm Settings{..} = do 95 | createDirectoryIfMissing True fullPath 96 | 97 | writeElm settingsTypesFile $ typesHeader : renderType @ts 98 | writeElm settingsEncoderFile $ encoderHeader : renderEncoder @ts 99 | writeElm settingsDecoderFile $ decoderHeader : renderDecoder @ts 100 | 101 | writeElm "ElmStreet" elmStreetDefinitions 102 | where 103 | moduleDir, fullPath :: FilePath 104 | moduleDir = foldr () "" settingsModule 105 | fullPath = settingsDirectory moduleDir 106 | 107 | writeElm :: FilePath -> [Text] -> IO () 108 | writeElm file defs = TIO.writeFile (fullPath file <.> "elm") (T.unlines defs) 109 | 110 | joinModule :: [String] -> Text 111 | joinModule = T.pack . intercalate "." 112 | 113 | typesModule, encoderModule, decoderModule :: Text 114 | typesModule = joinModule $ settingsModule ++ [settingsTypesFile] 115 | encoderModule = joinModule $ settingsModule ++ [settingsEncoderFile] 116 | decoderModule = joinModule $ settingsModule ++ [settingsDecoderFile] 117 | streetModule = joinModule $ settingsModule ++ ["ElmStreet"] 118 | 119 | typesHeader :: Text 120 | typesHeader = T.unlines 121 | [ "module " <> typesModule <> " exposing (..)" 122 | , "" 123 | , "import Time exposing (Posix)" 124 | , "import Json.Decode exposing (Value)" 125 | ] 126 | 127 | encoderHeader :: Text 128 | encoderHeader = T.unlines 129 | [ "module " <> encoderModule <> " exposing (..)" 130 | , "" 131 | , "import Iso8601 as Iso" 132 | , "import Json.Encode as E exposing (..)" 133 | , "" 134 | , "import " <> streetModule <> " exposing (..)" 135 | , "import " <> typesModule <> " as T" 136 | ] 137 | 138 | decoderHeader :: Text 139 | decoderHeader = T.unlines 140 | [ "module " <> decoderModule <> " exposing (..)" 141 | , "" 142 | , "import Iso8601 as Iso" 143 | , "import Json.Decode as D exposing (..)" 144 | , "import Json.Decode.Pipeline as D exposing (required)" 145 | , "" 146 | , "import " <> streetModule <> " exposing (..)" 147 | , "import " <> typesModule <> " as T" 148 | ] 149 | 150 | elmStreetDefinitions :: [Text] 151 | elmStreetDefinitions = 152 | [ "module " <> streetModule <> " exposing (..)" 153 | , "" 154 | , "import Json.Encode as E exposing (Value)" 155 | , "import Json.Decode as D exposing (Decoder)" 156 | , "import Json.Decode.Pipeline as D exposing (..)" 157 | , "" 158 | , "" 159 | , encodeMaybe 160 | , encodeEither 161 | , encodePair 162 | , encodeTriple 163 | , encodeNonEmpty 164 | 165 | , decodeEnum 166 | , decodeChar 167 | , decodeEither 168 | , decodePair 169 | , decodeTriple 170 | , decodeNonEmpty 171 | ] 172 | -------------------------------------------------------------------------------- /src/Elm/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | {- | Generic conversion of Haskell data types to Elm types. 12 | -} 13 | 14 | module Elm.Generic 15 | ( -- * Main data type for the user 16 | Elm (..) 17 | , elmRef 18 | 19 | -- * Smart constructors 20 | , elmNewtype 21 | 22 | -- * Generic utilities 23 | , GenericElmDefinition (..) 24 | , GenericElmConstructors (..) 25 | , GenericElmFields (..) 26 | 27 | , GenericConstructor (..) 28 | , toElmConstructor 29 | -- * Customizing generated elm code and JSON instances 30 | , CodeGenOptions (..) 31 | , defaultCodeGenOptions 32 | 33 | -- * Type families for compile-time checks 34 | , HasNoTypeVars 35 | , TypeVarsError 36 | 37 | , HasLessThanEightUnnamedFields 38 | , FieldsError 39 | , CheckFields 40 | , Max 41 | 42 | , HasNoNamedSum 43 | , NamedSumError 44 | , CheckNamedSum 45 | , CheckConst 46 | , ElmStreetGenericConstraints 47 | 48 | -- * Internals 49 | , stripTypeNamePrefix 50 | ) where 51 | 52 | import Data.Aeson (Value) 53 | import Data.Char (isLower, toLower) 54 | import Data.Int (Int16, Int32, Int8) 55 | import Data.Kind (Constraint, Type) 56 | import Data.List.NonEmpty (NonEmpty (..)) 57 | import Data.Proxy (Proxy (..)) 58 | import Data.Text (Text) 59 | import Type.Reflection (Typeable, typeRep) 60 | import Data.Time.Clock (UTCTime) 61 | import Data.Type.Bool (If, type (||)) 62 | import Data.Void (Void) 63 | import Data.Word (Word16, Word32, Word8) 64 | import GHC.Generics (C1, Constructor (..), D1, Datatype (..), Generic (..), M1 (..), Meta (..), 65 | Rec0, S1, Selector (..), U1, (:*:), (:+:)) 66 | import GHC.TypeLits (ErrorMessage (..), Nat, TypeError) 67 | import GHC.TypeNats (type (+), type (<=?)) 68 | 69 | import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), 70 | ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), definitionToRef) 71 | 72 | import qualified Data.Text as T 73 | import qualified Data.Text.Lazy as LT (Text) 74 | import qualified GHC.Generics as Generic (from) 75 | 76 | 77 | {- | Typeclass that describes how Haskell data types are converted to Elm ones. 78 | -} 79 | class Elm a where 80 | toElmDefinition :: Proxy a -> ElmDefinition 81 | 82 | default toElmDefinition 83 | :: (ElmStreetGenericConstraints a, Typeable a) 84 | => Proxy a 85 | -> ElmDefinition 86 | toElmDefinition _ = genericToElmDefinition (defaultCodeGenOptions @a) 87 | $ Generic.from (error "Proxy for generic elm was evaluated" :: a) 88 | 89 | {- | Returns 'TypeRef' for the existing type. This function always returns the 90 | name of the type without any type variables added. 91 | -} 92 | elmRef :: forall a . Elm a => TypeRef 93 | elmRef = definitionToRef $ toElmDefinition $ Proxy @a 94 | 95 | ---------------------------------------------------------------------------- 96 | -- Primitive instances 97 | ---------------------------------------------------------------------------- 98 | 99 | instance Elm () where toElmDefinition _ = DefPrim ElmUnit 100 | instance Elm Void where toElmDefinition _ = DefPrim ElmNever 101 | instance Elm Bool where toElmDefinition _ = DefPrim ElmBool 102 | instance Elm Char where toElmDefinition _ = DefPrim ElmChar 103 | 104 | instance Elm Int where toElmDefinition _ = DefPrim ElmInt 105 | instance Elm Int8 where toElmDefinition _ = DefPrim ElmInt 106 | instance Elm Int16 where toElmDefinition _ = DefPrim ElmInt 107 | instance Elm Int32 where toElmDefinition _ = DefPrim ElmInt 108 | instance Elm Word where toElmDefinition _ = DefPrim ElmInt 109 | instance Elm Word8 where toElmDefinition _ = DefPrim ElmInt 110 | instance Elm Word16 where toElmDefinition _ = DefPrim ElmInt 111 | instance Elm Word32 where toElmDefinition _ = DefPrim ElmInt 112 | 113 | instance Elm Float where toElmDefinition _ = DefPrim ElmFloat 114 | instance Elm Double where toElmDefinition _ = DefPrim ElmFloat 115 | 116 | instance Elm Text where toElmDefinition _ = DefPrim ElmString 117 | instance Elm LT.Text where toElmDefinition _ = DefPrim ElmString 118 | 119 | instance Elm Value where toElmDefinition _ = DefPrim ElmValue 120 | 121 | -- TODO: should it be 'Bytes' from @bytes@ package? 122 | -- https://package.elm-lang.org/packages/elm/bytes/latest/Bytes 123 | -- instance Elm B.ByteString where toElmDefinition _ = DefPrim ElmString 124 | -- instance Elm LB.ByteString where toElmDefinition _ = DefPrim ElmString 125 | 126 | instance Elm UTCTime where toElmDefinition _ = DefPrim ElmTime 127 | 128 | instance Elm a => Elm (Maybe a) where 129 | toElmDefinition _ = DefPrim $ ElmMaybe $ elmRef @a 130 | 131 | instance (Elm a, Elm b) => Elm (Either a b) where 132 | toElmDefinition _ = DefPrim $ ElmResult (elmRef @a) (elmRef @b) 133 | 134 | instance (Elm a, Elm b) => Elm (a, b) where 135 | toElmDefinition _ = DefPrim $ ElmPair (elmRef @a) (elmRef @b) 136 | 137 | instance (Elm a, Elm b, Elm c) => Elm (a, b, c) where 138 | toElmDefinition _ = DefPrim $ ElmTriple (elmRef @a) (elmRef @b) (elmRef @c) 139 | 140 | instance Elm a => Elm [a] where 141 | toElmDefinition _ = DefPrim $ ElmList (elmRef @a) 142 | 143 | -- Overlapping instance to ensure that Haskell @String@ is represented as Elm @String@ 144 | -- and not as @List Char@ based based on @Elm a => Elm [a]@ instance 145 | instance {-# OVERLAPPING #-} Elm String where 146 | toElmDefinition _ = DefPrim ElmString 147 | 148 | instance Elm a => Elm (NonEmpty a) where 149 | toElmDefinition _ = DefPrim $ ElmNonEmptyPair (elmRef @a) 150 | 151 | ---------------------------------------------------------------------------- 152 | -- Smart constructors 153 | ---------------------------------------------------------------------------- 154 | 155 | {- | This function can be used to create manual 'Elm' instances easily for 156 | @newtypes@ where 'Generic' deriving doesn't work. This function can be used like 157 | this: 158 | 159 | @ 160 | __newtype__ Id a = Id { unId :: Text } 161 | 162 | __instance__ Elm (Id a) __where__ 163 | toElmDefinition _ = elmNewtype @Text "Id" "unId" 164 | @ 165 | -} 166 | elmNewtype :: forall a . Elm a => Text -> Text -> ElmDefinition 167 | elmNewtype typeName fieldName = DefRecord $ ElmRecord 168 | { elmRecordName = typeName 169 | , elmRecordFields = ElmRecordField (elmRef @a) fieldName :| [] 170 | , elmRecordIsNewtype = True 171 | } 172 | 173 | ---------------------------------------------------------------------------- 174 | -- Generic instances 175 | ---------------------------------------------------------------------------- 176 | 177 | {- | Generic typeclass to generate whole 'ElmDefinition'. It has only one 178 | instance: for the first top-level metadata that contains metainformation about 179 | data type like @data type name@. Then it collects all constructors of the data 180 | type and decides what to generate. 181 | -} 182 | class GenericElmDefinition (f :: k -> Type) where 183 | genericToElmDefinition :: CodeGenOptions -> f a -> ElmDefinition 184 | 185 | instance (Datatype d, GenericElmConstructors f) => GenericElmDefinition (D1 d f) where 186 | genericToElmDefinition options datatype = case genericToElmConstructors options (unM1 datatype) of 187 | c :| [] -> case toElmConstructor c of 188 | Left fields -> DefRecord $ ElmRecord typeName fields elmIsNewtype 189 | Right ctor -> DefType $ ElmType typeName [] elmIsNewtype (ctor :| []) 190 | c :| cs -> case traverse (rightToMaybe . toElmConstructor) (c :| cs) of 191 | -- TODO: this should be error but dunno what to do here 192 | Nothing -> DefType $ ElmType ("ERROR_" <> typeName) [] False (ElmConstructor "ERROR" [] :| []) 193 | Just ctors -> DefType $ ElmType typeName [] elmIsNewtype ctors 194 | where 195 | typeName :: Text 196 | typeName = T.pack $ datatypeName datatype 197 | 198 | elmIsNewtype :: Bool 199 | elmIsNewtype = isNewtype datatype 200 | 201 | rightToMaybe :: Either l r -> Maybe r 202 | rightToMaybe = either (const Nothing) Just 203 | 204 | {- | Intermediate data type to help with the conversion from Haskell 205 | constructors to Elm AST. In Haskell constructor fields may have names but may 206 | not have. 207 | -} 208 | data GenericConstructor = GenericConstructor 209 | { genericConstructorName :: !Text 210 | , genericConstructorFields :: ![(TypeRef, Maybe Text)] 211 | } 212 | 213 | {- | Generic constructor can be in one of the three states: 214 | 215 | 1. No fields: enum constructor. 216 | 2. All fields have names: record constructor. 217 | 3. Not all fields have names: plain constructor. 218 | -} 219 | toElmConstructor :: GenericConstructor -> Either (NonEmpty ElmRecordField) ElmConstructor 220 | toElmConstructor GenericConstructor{..} = case genericConstructorFields of 221 | [] -> Right $ ElmConstructor genericConstructorName [] 222 | f:fs -> case traverse toRecordField (f :| fs) of 223 | Nothing -> Right $ ElmConstructor genericConstructorName $ map fst genericConstructorFields 224 | Just fields -> Left fields 225 | where 226 | toRecordField :: (TypeRef, Maybe Text) -> Maybe ElmRecordField 227 | toRecordField (typeRef, maybeFieldName) = ElmRecordField typeRef <$> maybeFieldName 228 | 229 | 230 | {- | Typeclass to collect all constructors of the Haskell data type generically. -} 231 | class GenericElmConstructors (f :: k -> Type) where 232 | genericToElmConstructors 233 | :: CodeGenOptions 234 | -> f a -- ^ Generic value 235 | -> NonEmpty GenericConstructor -- ^ List of the data type constructors 236 | 237 | -- | If it's a sum type then just combine constructors 238 | instance (GenericElmConstructors f, GenericElmConstructors g) => GenericElmConstructors (f :+: g) where 239 | genericToElmConstructors options _ = 240 | genericToElmConstructors options (error "'f :+:' is evaluated" :: f p) 241 | <> genericToElmConstructors options (error "':+: g' is evaluated" :: g p) 242 | 243 | -- | Create singleton list for case of a one constructor. 244 | instance (Constructor c, GenericElmFields f) => GenericElmConstructors (C1 c f) where 245 | genericToElmConstructors options constructor = pure $ GenericConstructor 246 | (T.pack $ conName constructor) 247 | (genericToElmFields options $ unM1 constructor) 248 | 249 | -- | Collect all fields when inside constructor. 250 | class GenericElmFields (f :: k -> Type) where 251 | genericToElmFields 252 | :: CodeGenOptions 253 | -> f a -- ^ Generic value 254 | -> [(TypeRef, Maybe Text)] 255 | 256 | -- | If multiple fields then just combine all results. 257 | instance (GenericElmFields f, GenericElmFields g) => GenericElmFields (f :*: g) where 258 | genericToElmFields options _ = 259 | genericToElmFields options (error "'f :*:' is evaluated" :: f p) 260 | <> genericToElmFields options (error "':*: g' is evaluated" :: g p) 261 | 262 | -- | Constructor without fields. 263 | instance GenericElmFields U1 where 264 | genericToElmFields _ _ = [] 265 | 266 | -- | Single constructor field. 267 | instance (Selector s, Elm a) => GenericElmFields (S1 s (Rec0 a)) where 268 | genericToElmFields options selector = case selName selector of 269 | "" -> [(elmRef @a, Nothing)] 270 | name -> [(elmRef @a, Just $ cgoFieldLabelModifier options $ T.pack name)] 271 | 272 | {- | Strips name of the type name from field name prefix. 273 | 274 | >>> stripTypeNamePrefix (TypeName "User") "userName" 275 | "name" 276 | 277 | >>> stripTypeNamePrefix (TypeName "HealthReading") "healthReadingId" 278 | "id" 279 | 280 | >>> stripTypeNamePrefix (TypeName "RecordUpdate") "ruRows" 281 | "rows" 282 | 283 | >>> stripTypeNamePrefix (TypeName "Foo") "foo" 284 | "foo" 285 | 286 | >>> stripTypeNamePrefix (TypeName "Foo") "abc" 287 | "abc" 288 | -} 289 | stripTypeNamePrefix :: TypeName -> Text -> Text 290 | stripTypeNamePrefix (TypeName typeName) fieldName = 291 | case T.stripPrefix (headToLower typeName) fieldName of 292 | Just rest -> leaveIfEmpty rest 293 | Nothing -> leaveIfEmpty (T.dropWhile isLower fieldName) 294 | where 295 | headToLower :: Text -> Text 296 | headToLower t = case T.uncons t of 297 | Nothing -> error "Cannot use 'headToLower' on empty Text" 298 | Just (x, xs) -> T.cons (toLower x) xs 299 | 300 | -- if all lower case then leave field as it is 301 | leaveIfEmpty :: Text -> Text 302 | leaveIfEmpty rest = if T.null rest then fieldName else headToLower rest 303 | 304 | {- | CodeGenOptions allow for customizing some aspects of generated Elm code as well as 305 | ToJSON and FromJSON instances derived generically. 306 | 307 | They can be passed to 'elmStreetParseJsonWith', 'elmStreetToJsonWith' and 'genericToElmDefinition' 308 | to influence the behavior of FromJSON \/ ToJSON and Elm instances respectively. 309 | 310 | Note that for Generated Elm encoders \/ decoders to be compatible 311 | with ToJSON \/ FromJSON instances for given type, 312 | __the same CodeGenOptions must be used in Elm \/ ToJSON \/ FromJSON instance declarations__. 313 | 314 | Example: Say you don't like the default behavior (stripping type name prefix from all record fields) 315 | and you would like to keep all record field names unmodified instead. 316 | You can achieve that by declaring custom options: 317 | 318 | @ 319 | myCodeGenOptions :: CodeGenOptions 320 | myCodeGenOptions = CodeGenOptions { cgoFieldLabelModifier = id } 321 | @ 322 | 323 | And then pass these options when defining Elm \/ ToJSON \/ FromJSON instances. 324 | It is recommended to use DerivingVia to reduce the amount of boilerplate needed. 325 | First declare a newtype whose Elm \/ ToJSON \/ FromJSON instances use your custom CodeGenOptions: 326 | 327 | @ 328 | newtype CustomElm a = CustomElm {unCustomElm :: a} 329 | 330 | instance ElmStreetGenericConstraints a => Elm (CustomElm a) where 331 | toElmDefinition _ = genericToElmDefinition myCodeGenOptions $ 332 | GHC.Generics.from (error "Proxy for generic elm was evaluated" :: a) 333 | 334 | instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomElm a) where 335 | toJSON = elmStreetToJsonWith myCodeGenOptions . unCustomElm 336 | 337 | instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomElm a) where 338 | parseJSON = fmap CustomElm . elmStreetParseJsonWith myCodeGenOptions 339 | @ 340 | 341 | Then derive Elm \/ ToJSON \/ FromJSON instance via that newtype: 342 | 343 | @ 344 | data MyType = MyType 345 | { myTypeFieldOne :: String 346 | , myTypeFieldTwo :: Int 347 | } deriving stock (Show, Generic) 348 | deriving (Elm, ToJSON, FromJSON) via CustomElm MyType 349 | @ 350 | 351 | We can check that type name prefix is no longer stripped from record field names: 352 | 353 | >>> encode (MyType "Hello" 10) 354 | "{\"myTypeFieldOne\":\"Hello\",\"myTypeFieldTwo\":10,\"tag\":\"MyType\"}" 355 | -} 356 | newtype CodeGenOptions = CodeGenOptions 357 | { cgoFieldLabelModifier :: Text -> Text -- ^ Function that modifies record field names (e.g. by dropping type name prefix) 358 | } 359 | 360 | {- | Options to strip type name from the field names. 361 | 362 | +----------------+----------------+---------------------+ 363 | | Data type name | Field name | Stripped field name | 364 | +================+================+=====================+ 365 | | @User@ | @userName@ | @name@ | 366 | +----------------+----------------+---------------------+ 367 | | @AaaBbbCcc@ | @abcFieldName@ | @fieldName@ | 368 | +----------------+----------------+---------------------+ 369 | | @Foo@ | @field@ | @field@ | 370 | +----------------+----------------+---------------------+ 371 | | @Field@ | @field@ | @field@ | 372 | +----------------+----------------+---------------------+ 373 | 374 | -} 375 | defaultCodeGenOptions :: forall a. Typeable a => CodeGenOptions 376 | defaultCodeGenOptions = CodeGenOptions (stripTypeNamePrefix typeName) 377 | where 378 | typeName :: TypeName 379 | typeName = TypeName $ T.pack $ show $ typeRep @a 380 | 381 | ---------------------------------------------------------------------------- 382 | -- ~Magic~ 383 | ---------------------------------------------------------------------------- 384 | 385 | {- | This type family checks whether data type has type variables and throws 386 | custom compiler error if it has. Since there's no generic way to get all type 387 | variables, current implementation is limited only to 6 variables. This looks 388 | like a reasonable number. 389 | -} 390 | type family HasNoTypeVars (f :: k) :: Constraint where 391 | HasNoTypeVars (t a b c d e f) = TypeError (TypeVarsError t 6) 392 | HasNoTypeVars (t a b c d e) = TypeError (TypeVarsError t 5) 393 | HasNoTypeVars (t a b c d) = TypeError (TypeVarsError t 4) 394 | HasNoTypeVars (t a b c) = TypeError (TypeVarsError t 3) 395 | HasNoTypeVars (t a b) = TypeError (TypeVarsError t 2) 396 | HasNoTypeVars (t a) = TypeError (TypeVarsError t 1) 397 | HasNoTypeVars t = () 398 | 399 | type family TypeVarsError (t :: k) (n :: Nat) :: ErrorMessage where 400 | TypeVarsError t n = 401 | 'Text "'elm-street' currently doesn't support Generic deriving of the 'Elm' typeclass" 402 | ':$$: 'Text "for data types with type variables. But '" 403 | ':<>: 'ShowType t ':<>: 'Text "' has " ':<>: 'ShowType n ':<>: 'Text " variables." 404 | ':$$: 'Text "" 405 | ':$$: 'Text "See the following issue for more details:" 406 | ':$$: 'Text " * https://github.com/Holmusk/elm-street/issues/45" 407 | ':$$: 'Text "" 408 | 409 | {- | This type family checks whether each constructor of the sum data type has 410 | less than eight unnamed fields and throws custom compiler error if it has. 411 | -} 412 | type family HasLessThanEightUnnamedFields (f :: k) :: Constraint where 413 | HasLessThanEightUnnamedFields t = 414 | If (CheckFields (Rep t) <=? 8) 415 | (() :: Constraint) 416 | (TypeError (FieldsError t)) 417 | 418 | type family CheckFields (f :: k -> Type) :: Nat where 419 | CheckFields (D1 _ f) = CheckFields f 420 | CheckFields (f :+: g) = Max (CheckFields f) (CheckFields g) 421 | CheckFields (C1 _ f) = CheckFields f 422 | CheckFields (f :*: g) = CheckFields f + CheckFields g 423 | CheckFields (S1 ('MetaSel ('Just _ ) _ _ _) _) = 0 424 | CheckFields (S1 _ _) = 1 425 | CheckFields _ = 0 426 | 427 | type family Max (x :: Nat) (y :: Nat) :: Nat where 428 | Max x y = If (x <=? y) y x 429 | 430 | type family FieldsError (t :: k) :: ErrorMessage where 431 | FieldsError t = 432 | 'Text "'elm-street' doesn't support Constructors with more than 8 unnamed fields." 433 | ':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has more." 434 | 435 | {- | This type family checks whether each constructor of the sum data type has 436 | less than eight unnamed fields and throws custom compiler error if it has. 437 | -} 438 | type family HasNoNamedSum (f :: k) :: Constraint where 439 | HasNoNamedSum t = 440 | If (CheckNamedSum (Rep t)) 441 | (TypeError (NamedSumError t)) 442 | (() :: Constraint) 443 | 444 | -- | Is the data type id Sum type with named fields? 445 | type family CheckNamedSum (f :: k -> Type) :: Bool where 446 | CheckNamedSum (D1 _ f) = CheckNamedSum f 447 | CheckNamedSum (f :+: g) = CheckConst f || CheckConst g 448 | CheckNamedSum _ = 'False 449 | 450 | -- | Check if Sum type has named fields at least for one of the Constructors. 451 | type family CheckConst (f :: k -> Type) :: Bool where 452 | CheckConst (f :+: g) = CheckConst f || CheckConst g 453 | CheckConst (C1 _ f) = CheckConst f 454 | CheckConst (S1 ('MetaSel ('Just _ ) _ _ _) _) = 'True 455 | CheckConst (f :*: g) = CheckConst f || CheckConst g 456 | CheckConst _ = 'False 457 | 458 | type family NamedSumError (t :: k) :: ErrorMessage where 459 | NamedSumError t = 460 | 'Text "'elm-street' doesn't support Sum types with records." 461 | ':$$: 'Text "But '" ':<>: 'ShowType t ':<>: 'Text "' has records." 462 | 463 | -- | Convenience grouping of constraints that type has to satisfy 464 | -- in order to be eligible for automatic derivation of Elm instance via generics 465 | type ElmStreetGenericConstraints a = 466 | ( HasNoTypeVars a 467 | , HasLessThanEightUnnamedFields a 468 | , HasNoNamedSum a 469 | , Generic a 470 | , GenericElmDefinition (Rep a) 471 | ) 472 | -------------------------------------------------------------------------------- /src/Elm/Print.hs: -------------------------------------------------------------------------------- 1 | {- | This module defines prettyprinter for 'ElmDefinition' type. 2 | and exports the function to represent it in the convenient way. 3 | -} 4 | 5 | module Elm.Print 6 | ( module Elm.Print.Common 7 | , module Elm.Print.Decoder 8 | , module Elm.Print.Encoder 9 | , module Elm.Print.Types 10 | ) where 11 | 12 | import Elm.Print.Common 13 | import Elm.Print.Decoder 14 | import Elm.Print.Encoder 15 | import Elm.Print.Types 16 | 17 | {- 18 | import qualified Data.Text as T 19 | import Elm.Ast 20 | import Data.List.NonEmpty 21 | 22 | test :: IO () 23 | test = do 24 | putStrLn $ T.unpack $ prettyShowDefinition $ DefRecord $ ElmRecord "User" (ElmRecordField (RefPrim ElmString) "userHeh" :| [ElmRecordField (RefPrim ElmInt) "userMeh"]) False 25 | 26 | --ENUM: 27 | putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] 28 | putStrLn $ T.unpack $ prettyShowEncoder $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" []] 29 | putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False $ ElmConstructor "Approved" [RefPrim ElmString, RefPrim ElmInt] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [RefCustom $ TypeName "a"]] 30 | putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" ["a"] False $ ElmConstructor "Approved" [RefPrim ElmString, RefPrim ElmInt] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [RefCustom $ TypeName "a"]] 31 | putStrLn $ T.unpack $ prettyShowDefinition $ DefType $ ElmType "Status" [] False (ElmConstructor "Approved" [] :| [ElmConstructor "Yoyoyo" [], ElmConstructor "Wow" [], ElmConstructor "OneMore" [], ElmConstructor "AndAnother" []]) 32 | 33 | -} 34 | -------------------------------------------------------------------------------- /src/Elm/Print/Common.hs: -------------------------------------------------------------------------------- 1 | {- | This module contains some commonly used function for working 2 | with 'Doc's and pretty printing. 3 | -} 4 | 5 | module Elm.Print.Common 6 | ( showDoc 7 | , wrapParens 8 | , arrow 9 | , mkQualified 10 | , typeWithVarsDoc 11 | , qualifiedTypeWithVarsDoc 12 | ) where 13 | 14 | import Data.Text (Text) 15 | import Internal.Prettyprinter.Compat (Doc, concatWith, parens, pretty, surround, (<+>)) 16 | 17 | import qualified Data.Text as T 18 | 19 | 20 | -- | Shows pretty-printed document. 21 | showDoc :: Doc ann -> Text 22 | showDoc = T.pack . show 23 | 24 | {- | Wraps given document in parens if it contains more than single word. 25 | -} 26 | wrapParens :: Doc ann -> Doc ann 27 | wrapParens doc = case T.words $ showDoc doc of 28 | [] -> doc 29 | [_] -> doc 30 | _ -> parens doc 31 | 32 | -- | Pretty printed arrow (@->@). 33 | arrow :: Doc ann 34 | arrow = "->" 35 | 36 | {- | Add qualified prefix to the type names or functions: 37 | 38 | @ 39 | T.MyType 40 | 41 | T.showMyType 42 | @ 43 | 44 | Here we add @T.@ prefix as we only use qualified imports 45 | for @Types as T@ module. 46 | -} 47 | mkQualified :: Text -> Doc ann 48 | mkQualified = pretty . ("T." <>) 49 | 50 | {- | Creates a 'Doc' of the type with its type variables (if any). 51 | -} 52 | typeWithVarsDoc 53 | :: Bool -- ^ Is qualified 54 | -> Text -- ^ Type name 55 | -> [Text] -- ^ List of type variables 56 | -> Doc ann 57 | typeWithVarsDoc isQualified typeName = \case 58 | [] -> tName 59 | vars -> tName <+> typeVarsDoc vars 60 | where 61 | typeVarsDoc :: [Text] -> Doc ann 62 | typeVarsDoc = concatWith (surround " ") . map pretty 63 | tName :: Doc ann 64 | tName = 65 | if isQualified 66 | then mkQualified typeName 67 | else pretty typeName 68 | 69 | {- | Creates a 'Doc' of the qualified type with its type variables (if any). 70 | -} 71 | qualifiedTypeWithVarsDoc 72 | :: Text -- ^ Type name 73 | -> [Text] -- ^ List of type variables 74 | -> Doc ann 75 | qualifiedTypeWithVarsDoc = typeWithVarsDoc True 76 | -------------------------------------------------------------------------------- /src/Elm/Print/Decoder.hs: -------------------------------------------------------------------------------- 1 | {- | Pretty-printing functions for @Decoder.elm@ module. 2 | Also contains decoders for common types which go to the @ElmStreet.elm@ module. 3 | -} 4 | 5 | module Elm.Print.Decoder 6 | ( prettyShowDecoder 7 | 8 | -- * Standard missing decoders 9 | , decodeEnum 10 | , decodeChar 11 | , decodeEither 12 | , decodePair 13 | , decodeTriple 14 | , decodeNonEmpty 15 | ) where 16 | 17 | import Data.List.NonEmpty (toList) 18 | import Data.Text (Text) 19 | import Internal.Prettyprinter.Compat (Doc, colon, concatWith, dquotes, emptyDoc, equals, line, nest, 20 | parens, pretty, surround, vsep, (<+>)) 21 | 22 | import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), 23 | ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) 24 | import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) 25 | 26 | import qualified Data.List.NonEmpty as NE 27 | import qualified Data.Text as T 28 | 29 | 30 | ---------------------------------------------------------------------------- 31 | -- Decode 32 | ---------------------------------------------------------------------------- 33 | 34 | {- | 35 | 36 | __Sum Types:__ 37 | 38 | Haskell type 39 | 40 | @ 41 | type User 42 | = Foo 43 | | Bar String Int 44 | @ 45 | 46 | Encoded JSON on Haskell side 47 | 48 | @ 49 | [ { "tag" : "Foo" 50 | } 51 | , { "tag" : "Bar" 52 | , "contents" : ["asd", 42, "qwerty"] 53 | } 54 | ] 55 | @ 56 | 57 | Elm decoder 58 | 59 | @ 60 | userDecoder : Decoder User 61 | userDecoder = 62 | let decide : String -> Decoder User 63 | decide x = case x of 64 | \"Foo\" -> D.succeed Foo 65 | \"Bar\" -> D.field "contents" <| D.map2 Bar (D.index 0 D.string) (D.index 1 D.int) 66 | x -> D.fail <| "There is no constructor for User type:" ++ x 67 | in D.andThen decide (D.field "tag" D.string) 68 | @ 69 | 70 | -} 71 | prettyShowDecoder :: ElmDefinition -> Text 72 | prettyShowDecoder def = showDoc $ case def of 73 | DefRecord elmRecord -> recordDecoderDoc elmRecord 74 | DefType elmType -> typeDecoderDoc elmType 75 | DefPrim _ -> emptyDoc 76 | 77 | recordDecoderDoc :: ElmRecord -> Doc ann 78 | recordDecoderDoc ElmRecord{..} = 79 | decoderDef elmRecordName [] 80 | <> line 81 | <> if elmRecordIsNewtype 82 | then newtypeDecoder 83 | else recordDecoder 84 | where 85 | newtypeDecoder :: Doc ann 86 | newtypeDecoder = name <+> "D.map" <+> qualifiedRecordName 87 | <+> wrapParens (typeRefDecoder $ elmRecordFieldType $ NE.head elmRecordFields) 88 | 89 | recordDecoder :: Doc ann 90 | recordDecoder = nest 4 91 | $ vsep 92 | $ (name <+> "D.succeed" <+> qualifiedRecordName) 93 | : map fieldDecode (toList elmRecordFields) 94 | 95 | name :: Doc ann 96 | name = decoderName elmRecordName <+> equals 97 | 98 | qualifiedRecordName :: Doc ann 99 | qualifiedRecordName = mkQualified elmRecordName 100 | 101 | fieldDecode :: ElmRecordField -> Doc ann 102 | fieldDecode ElmRecordField{..} = case elmRecordFieldType of 103 | RefPrim ElmUnit -> "|> D.hardcoded ()" 104 | t -> "|> required" 105 | <+> dquotes (pretty elmRecordFieldName) 106 | <+> wrapParens (typeRefDecoder t) 107 | 108 | typeDecoderDoc :: ElmType -> Doc ann 109 | typeDecoderDoc t@ElmType{..} = 110 | -- function defenition: @encodeTypeName : TypeName -> Value@. 111 | decoderDef elmTypeName elmTypeVars 112 | <> line 113 | <> if isEnum t 114 | -- if this is Enum just using the read instance we wrote. 115 | then enumDecoder 116 | else if elmTypeIsNewtype 117 | -- if it newtype then wrap decoder for the field 118 | then newtypeDecoder 119 | -- If it sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ 120 | else sumDecoder 121 | where 122 | name :: Doc ann 123 | name = decoderName elmTypeName <+> equals 124 | 125 | typeName :: Doc ann 126 | typeName = pretty elmTypeName 127 | 128 | qualifiedTypeName :: Doc ann 129 | qualifiedTypeName = mkQualified elmTypeName 130 | 131 | enumDecoder :: Doc ann 132 | enumDecoder = name <+> "elmStreetDecodeEnum T.read" <> typeName 133 | 134 | newtypeDecoder :: Doc ann 135 | newtypeDecoder = name <+> "D.map" <+> qualifiedTypeName <+> fieldDecoderDoc 136 | where 137 | fieldDecoderDoc :: Doc ann 138 | fieldDecoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of 139 | [] -> "(D.fail \"Unknown field type of the newtype constructor\")" 140 | f : _ -> wrapParens $ typeRefDecoder f 141 | 142 | sumDecoder :: Doc ann 143 | sumDecoder = nest 4 $ vsep 144 | [ name 145 | , nest 4 (vsep $ ("let decide : String -> Decoder" <+> qualifiedTypeName) : 146 | [ nest 4 147 | ( vsep $ "decide x = case x of" 148 | : map cases (toList elmTypeConstructors) 149 | ++ ["c -> D.fail <|" <+> dquotes (typeName <+> "doesn't have such constructor: ") <+> "++ c"] 150 | ) 151 | ]) 152 | , "in D.andThen decide (D.field \"tag\" D.string)" 153 | ] 154 | 155 | cases :: ElmConstructor -> Doc ann 156 | cases ElmConstructor{..} = dquotes cName <+> arrow <+> 157 | case elmConstructorFields of 158 | [] -> "D.succeed" <+> qualifiedConName 159 | [f] -> "D.field \"contents\" <| D.map" <+> qualifiedConName <+> wrapParens (typeRefDecoder f) 160 | l -> "D.field \"contents\" <| D.map" <> mapNum (length l) <+> qualifiedConName <+> createIndexes 161 | where 162 | cName :: Doc ann 163 | cName = pretty elmConstructorName 164 | 165 | qualifiedConName :: Doc ann 166 | qualifiedConName = mkQualified elmConstructorName 167 | 168 | -- Use function map, map2, map3 etc. 169 | mapNum :: Int -> Doc ann 170 | mapNum 1 = emptyDoc 171 | mapNum i = pretty i 172 | 173 | createIndexes :: Doc ann 174 | createIndexes = concatWith (surround " ") $ zipWith oneField [0..] elmConstructorFields 175 | 176 | -- create @(D.index 0 D.string)@ etc. 177 | oneField :: Int -> TypeRef -> Doc ann 178 | oneField i typeRef = parens $ "D.index" 179 | <+> pretty i 180 | <+> wrapParens (typeRefDecoder typeRef) 181 | 182 | -- | Converts the reference to the existing type to the corresponding decoder. 183 | typeRefDecoder :: TypeRef -> Doc ann 184 | typeRefDecoder (RefCustom TypeName{..}) = "decode" <> pretty (T.takeWhile (/= ' ') unTypeName) 185 | typeRefDecoder (RefPrim elmPrim) = case elmPrim of 186 | ElmUnit -> "D.map (always ()) (D.list D.string)" 187 | ElmNever -> "D.fail \"Never is not possible\"" 188 | ElmBool -> "D.bool" 189 | ElmChar -> "elmStreetDecodeChar" 190 | ElmInt -> "D.int" 191 | ElmFloat -> "D.float" 192 | ElmString -> "D.string" 193 | ElmTime -> "Iso.decoder" 194 | ElmValue -> "D.value" 195 | ElmMaybe t -> "nullable" 196 | <+> wrapParens (typeRefDecoder t) 197 | ElmResult l r -> "elmStreetDecodeEither" 198 | <+> wrapParens (typeRefDecoder l) 199 | <+> wrapParens (typeRefDecoder r) 200 | ElmPair a b -> "elmStreetDecodePair" 201 | <+> wrapParens (typeRefDecoder a) 202 | <+> wrapParens (typeRefDecoder b) 203 | ElmTriple a b c -> "elmStreetDecodeTriple" 204 | <+> wrapParens (typeRefDecoder a) 205 | <+> wrapParens (typeRefDecoder b) 206 | <+> wrapParens (typeRefDecoder c) 207 | ElmList l -> "D.list" <+> wrapParens (typeRefDecoder l) 208 | ElmNonEmptyPair a -> "elmStreetDecodeNonEmpty" <+> wrapParens (typeRefDecoder a) 209 | 210 | -- | The definition of the @decodeTYPENAME@ function. 211 | decoderDef 212 | :: Text -- ^ Type name 213 | -> [Text] -- ^ List of type variables 214 | -> Doc ann 215 | decoderDef typeName vars = 216 | decoderName typeName 217 | <+> colon 218 | <+> "Decoder" 219 | <+> wrapParens (qualifiedTypeWithVarsDoc typeName vars) 220 | 221 | -- | Create the name of the decoder function. 222 | decoderName :: Text -> Doc ann 223 | decoderName typeName = "decode" <> pretty typeName 224 | 225 | -- | @JSON@ decoder Elm help function for Enum types. 226 | decodeEnum :: Text 227 | decodeEnum = T.unlines 228 | [ "decodeStr : (String -> Maybe a) -> String -> Decoder a" 229 | , "decodeStr readX x = case readX x of" 230 | , " Just a -> D.succeed a" 231 | , " Nothing -> D.fail \"Constructor not matched\"" 232 | , "" 233 | , "elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a" 234 | , "elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string" 235 | ] 236 | 237 | -- | @JSON@ decoder Elm help function for 'Char's. 238 | decodeChar :: Text 239 | decodeChar = T.unlines 240 | [ "elmStreetDecodeChar : Decoder Char" 241 | , "elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string" 242 | ] 243 | 244 | -- | @JSON@ decoder Elm help function for 'Either's. 245 | decodeEither :: Text 246 | decodeEither = T.unlines 247 | [ "elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b)" 248 | , "elmStreetDecodeEither decA decB = D.oneOf " 249 | , " [ D.field \"Left\" (D.map Err decA)" 250 | , " , D.field \"Right\" (D.map Ok decB)" 251 | , " ]" 252 | ] 253 | 254 | -- | @JSON@ decoder Elm help function for 2-tuples. 255 | decodePair :: Text 256 | decodePair = T.unlines 257 | [ "elmStreetDecodePair : Decoder a -> Decoder b -> Decoder (a, b)" 258 | , "elmStreetDecodePair decA decB = D.map2 Tuple.pair (D.index 0 decA) (D.index 1 decB)" 259 | ] 260 | 261 | -- | @JSON@ decoder Elm help function for List.NonEmpty. 262 | decodeNonEmpty :: Text 263 | decodeNonEmpty = T.unlines 264 | [ "elmStreetDecodeNonEmpty : Decoder a -> Decoder (a, List a)" 265 | , "elmStreetDecodeNonEmpty decA = D.list decA |> D.andThen (\\xs -> case xs of" 266 | , " h::t -> D.succeed (h, t)" 267 | , " _ -> D.fail \"Expecting non-empty array\")" 268 | ] 269 | 270 | -- | @JSON@ decoder Elm help function for 3-tuples. 271 | decodeTriple :: Text 272 | decodeTriple = T.unlines 273 | [ "elmStreetDecodeTriple : Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)" 274 | , "elmStreetDecodeTriple decA decB decC = D.map3 (\\a b c -> (a,b,c)) (D.index 0 decA) (D.index 1 decB) (D.index 2 decC)" 275 | ] 276 | -------------------------------------------------------------------------------- /src/Elm/Print/Encoder.hs: -------------------------------------------------------------------------------- 1 | {- | Pretty-printing functions for @Encoder.elm@ module. 2 | Also contains encoders for common types which go to the @ElmStreet.elm@ module. 3 | -} 4 | 5 | module Elm.Print.Encoder 6 | ( prettyShowEncoder 7 | 8 | -- * Standard missing encoders 9 | , encodeMaybe 10 | , encodeEither 11 | , encodePair 12 | , encodeTriple 13 | , encodeNonEmpty 14 | ) where 15 | 16 | import Data.List.NonEmpty (NonEmpty, toList) 17 | import Data.Text (Text) 18 | import Internal.Prettyprinter.Compat (Doc, brackets, colon, comma, concatWith, dquotes, emptyDoc, 19 | equals, lbracket, line, nest, parens, pretty, rbracket, surround, 20 | vsep, (<+>)) 21 | 22 | import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), 23 | ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum) 24 | import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens) 25 | 26 | import qualified Data.List.NonEmpty as NE 27 | import qualified Data.Text as T 28 | 29 | 30 | {- | Returns the encoder for the given type. 31 | 32 | 33 | TODO 34 | 35 | +-------------------+------------------+------------------+--------------------+ 36 | | Haskell Type | Eml Type | Encoder | JSON | 37 | +===================+==================+==================+====================+ 38 | | 'Int' | 'Int' | standard encoder | | 39 | +-------------------+------------------+------------------+--------------------+ 40 | 41 | -} 42 | prettyShowEncoder :: ElmDefinition -> Text 43 | prettyShowEncoder def = showDoc $ case def of 44 | DefRecord elmRecord -> recordEncoderDoc elmRecord 45 | DefType elmType -> typeEncoderDoc elmType 46 | DefPrim _ -> emptyDoc 47 | 48 | -- | Encoder for 'ElmType' (which is either enum or the Sum type). 49 | typeEncoderDoc :: ElmType -> Doc ann 50 | typeEncoderDoc t@ElmType{..} = 51 | -- function definition: @encodeTypeName : TypeName -> Value@. 52 | encoderDef elmTypeName elmTypeVars 53 | <> line 54 | <> if isEnum t 55 | -- if this is Enum just using the show instance we wrote. 56 | then enumEncoder 57 | else if elmTypeIsNewtype 58 | -- if this is type with one constructor and one field then it should just call encoder for wrapped type 59 | then newtypeEncoder 60 | -- If it's sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@ 61 | else sumEncoder 62 | where 63 | enumEncoder :: Doc ann 64 | enumEncoder = name <+> equals <+> "E.string << T.show" <> pretty elmTypeName 65 | 66 | newtypeEncoder :: Doc ann 67 | newtypeEncoder = 68 | name <+> equals <+> fieldEncoderDoc <+> "<< T.un" <> pretty elmTypeName 69 | where 70 | fieldEncoderDoc :: Doc ann 71 | fieldEncoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of 72 | [] -> "ERROR" 73 | f : _ -> wrapParens (typeRefEncoder f) 74 | 75 | sumEncoder :: Doc ann 76 | sumEncoder = nest 4 77 | $ vsep 78 | $ (name <+> "x" <+> equals <+> "E.object <| case x of") 79 | : map mkCase (toList elmTypeConstructors) 80 | 81 | -- | Encoder function name 82 | name :: Doc ann 83 | name = encoderName elmTypeName 84 | 85 | -- | Create case clause for each of the sum Constructors. 86 | mkCase :: ElmConstructor -> Doc ann 87 | mkCase ElmConstructor{..} = mkQualified elmConstructorName 88 | <+> vars 89 | <+> arrow 90 | <+> brackets (mkTag elmConstructorName <> contents) 91 | where 92 | -- | Creates variables: @x1@ to @xN@, where N is the number of the constructor fields. 93 | fields :: [Doc ann] 94 | fields = map (pretty . mkText "x") [1 .. length elmConstructorFields] 95 | 96 | contents :: Doc ann 97 | contents = "," <+> parens (dquotes "contents" <> comma <+> contentsEnc) 98 | 99 | -- JSON encoder for the "contents" key 100 | contentsEnc :: Doc ann 101 | contentsEnc = case elmConstructorFields of 102 | [_] -> fieldEncs 103 | _ -> "E.list identity" <+> brackets fieldEncs 104 | 105 | -- | @encoderA x1@ 106 | fieldEncs :: Doc ann 107 | fieldEncs = concatWith (surround ", ") $ 108 | zipWith (<+>) (map (wrapParens . typeRefEncoder) elmConstructorFields) fields 109 | 110 | -- | Makes variable like: @x11@ etc. 111 | mkText :: Text -> Int -> Text 112 | mkText x i = x <> T.pack (show i) 113 | 114 | vars :: Doc ann 115 | vars = concatWith (surround " ") fields 116 | 117 | 118 | recordEncoderDoc :: ElmRecord -> Doc ann 119 | recordEncoderDoc ElmRecord{..} = 120 | encoderDef elmRecordName [] 121 | <> line 122 | <> if elmRecordIsNewtype 123 | then newtypeEncoder 124 | else recordEncoder 125 | where 126 | newtypeEncoder :: Doc ann 127 | newtypeEncoder = leftPart <+> fieldEncoderDoc (NE.head elmRecordFields) 128 | 129 | recordEncoder :: Doc ann 130 | recordEncoder = nest 4 131 | $ vsep 132 | $ (leftPart <+> "E.object") 133 | : fieldsEncode elmRecordFields 134 | 135 | leftPart :: Doc ann 136 | leftPart = encoderName elmRecordName <+> "x" <+> equals 137 | 138 | fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann] 139 | fieldsEncode fields = 140 | lbracket <+> mkTag elmRecordName 141 | : map ((comma <+>) . recordFieldDoc) (NE.toList fields) 142 | ++ [rbracket] 143 | 144 | recordFieldDoc :: ElmRecordField -> Doc ann 145 | recordFieldDoc field@ElmRecordField{..} = parens $ 146 | dquotes (pretty elmRecordFieldName) 147 | <> comma 148 | <+> fieldEncoderDoc field 149 | 150 | fieldEncoderDoc :: ElmRecordField -> Doc ann 151 | fieldEncoderDoc ElmRecordField{..} = 152 | wrapParens (typeRefEncoder elmRecordFieldType) <+> "x." <> pretty elmRecordFieldName 153 | 154 | -- | Create pair of view: @("tag", E.string "SomeName")@. 155 | mkTag :: Text -> Doc ann 156 | mkTag txt = parens $ dquotes "tag" <> comma <+> "E.string" <+> dquotes (pretty txt) 157 | 158 | -- | The definition of the @encodeTYPENAME@ function. 159 | encoderDef 160 | :: Text -- ^ Type name 161 | -> [Text] -- ^ List of type variables 162 | -> Doc ann 163 | encoderDef typeName vars = 164 | encoderName typeName 165 | <+> colon 166 | <+> qualifiedTypeWithVarsDoc typeName vars 167 | <+> arrow 168 | <+> "Value" 169 | 170 | -- | Create the name of the encoder function. 171 | encoderName :: Text -> Doc ann 172 | encoderName typeName = "encode" <> pretty typeName 173 | 174 | -- | Converts the reference to the existing type to the corresponding encoder. 175 | typeRefEncoder :: TypeRef -> Doc ann 176 | typeRefEncoder (RefCustom TypeName{..}) = "encode" <> pretty (T.takeWhile (/= ' ') unTypeName) 177 | typeRefEncoder (RefPrim elmPrim) = case elmPrim of 178 | ElmUnit -> "always <| E.list identity []" 179 | ElmNever -> "never" 180 | ElmBool -> "E.bool" 181 | ElmChar -> "E.string << String.fromChar" 182 | ElmInt -> "E.int" 183 | ElmFloat -> "E.float" 184 | ElmString -> "E.string" 185 | ElmTime -> "Iso.encode" 186 | ElmValue -> "Basics.identity" 187 | ElmMaybe t -> "elmStreetEncodeMaybe" 188 | <+> wrapParens (typeRefEncoder t) 189 | ElmResult l r -> "elmStreetEncodeEither" 190 | <+> wrapParens (typeRefEncoder l) 191 | <+> wrapParens (typeRefEncoder r) 192 | ElmPair a b -> "elmStreetEncodePair" 193 | <+> wrapParens (typeRefEncoder a) 194 | <+> wrapParens (typeRefEncoder b) 195 | ElmTriple a b c -> "elmStreetEncodeTriple" 196 | <+> wrapParens (typeRefEncoder a) 197 | <+> wrapParens (typeRefEncoder b) 198 | <+> wrapParens (typeRefEncoder c) 199 | ElmList l -> "E.list" <+> wrapParens (typeRefEncoder l) 200 | ElmNonEmptyPair a -> "elmStreetEncodeNonEmpty" 201 | <+> wrapParens (typeRefEncoder a) 202 | 203 | -- | @JSON@ encoder Elm help function for 'Maybe's. 204 | encodeMaybe :: Text 205 | encodeMaybe = T.unlines 206 | [ "elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value" 207 | , "elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc" 208 | ] 209 | 210 | -- | @JSON@ encoder Elm help function for 'Either's. 211 | encodeEither :: Text 212 | encodeEither = T.unlines 213 | [ "elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value" 214 | , "elmStreetEncodeEither encA encB res = E.object <| case res of" 215 | , " Err a -> [(\"Left\", encA a)]" 216 | , " Ok b -> [(\"Right\", encB b)]" 217 | ] 218 | 219 | -- | @JSON@ encoder Elm help function for 2-tuples. 220 | encodePair :: Text 221 | encodePair = T.unlines 222 | [ "elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value" 223 | , "elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b]" 224 | ] 225 | 226 | -- | @JSON@ encoder Elm help function for 2-tuples. 227 | encodeNonEmpty :: Text 228 | encodeNonEmpty = T.unlines 229 | [ "elmStreetEncodeNonEmpty : (a -> Value) -> (a, List a) -> Value" 230 | , "elmStreetEncodeNonEmpty encA (a, xs) = E.list encA <| a :: xs" 231 | ] 232 | 233 | -- | @JSON@ encoder Elm help function for 3-tuples. 234 | encodeTriple :: Text 235 | encodeTriple = T.unlines 236 | [ "elmStreetEncodeTriple : (a -> Value) -> (b -> Value) -> (c -> Value) -> (a, b, c) -> Value" 237 | , "elmStreetEncodeTriple encA encB encC (a, b, c) = E.list identity [encA a, encB b, encC c]" 238 | ] 239 | -------------------------------------------------------------------------------- /src/Elm/Print/Types.hs: -------------------------------------------------------------------------------- 1 | {- | Pretty functions for `Types.elm` module. 2 | 3 | The generated module should contain: 4 | 5 | * Type definitions for all ADT 6 | * @show*@ functions for Enum types 7 | * @read*@ functions for Enum types 8 | * @universe*@ functions for Enum types 9 | * @un*@ functions for newtypes 10 | 11 | ==== __Example__ 12 | 13 | The example of Record, Newtype and Enum generated type and functions: 14 | 15 | @ 16 | type alias User = 17 | { id : Id 18 | , name : String 19 | , age : Age 20 | , status : RequestStatus 21 | } 22 | 23 | type RequestStatus 24 | = Approved 25 | | Rejected 26 | | Reviewing 27 | 28 | showRequestStatus : RequestStatus -> String 29 | showRequestStatus x = case x of 30 | Approved -> \"Approved\" 31 | Rejected -> \"Rejected\" 32 | Reviewing -> \"Reviewing\" 33 | 34 | readRequestStatus : String -> Maybe RequestStatus 35 | readRequestStatus x = case x of 36 | \"Approved\" -> Just Approved 37 | \"Rejected\" -> Just Rejected 38 | \"Reviewing\" -> Just Reviewing 39 | _ -> Nothing 40 | 41 | universeRequestStatus : List RequestStatus 42 | universeRequestStatus = [Approved, Rejected, Reviewing] 43 | 44 | type Id 45 | = Id String 46 | 47 | unId : Id -> String 48 | unId (Id x) = x 49 | @ 50 | 51 | -} 52 | 53 | module Elm.Print.Types 54 | ( prettyShowDefinition 55 | 56 | -- * Internal functions 57 | , elmRecordDoc 58 | , elmTypeDoc 59 | ) where 60 | 61 | import Data.List.NonEmpty (NonEmpty ((:|))) 62 | import Data.Text (Text) 63 | import Internal.Prettyprinter.Compat (Doc, align, colon, comma, dquotes, emptyDoc, equals, lbrace, line, 64 | lparen, nest, parens, pipe, pretty, prettyList, rbrace, rparen, 65 | sep, space, vsep, (<+>)) 66 | 67 | import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..), 68 | ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), getConstructorNames, 69 | isEnum) 70 | import Elm.Print.Common (arrow, showDoc, typeWithVarsDoc, wrapParens) 71 | 72 | import qualified Data.List.NonEmpty as NE 73 | 74 | 75 | {- | Pretty shows Elm types. 76 | 77 | * See 'elmRecordDoc' for examples of generated @record type alias@. 78 | * See 'elmTypeDoc' for examples of generated @type@. 79 | -} 80 | prettyShowDefinition :: ElmDefinition -> Text 81 | prettyShowDefinition = showDoc . elmDoc 82 | 83 | elmDoc :: ElmDefinition -> Doc ann 84 | elmDoc = \case 85 | DefRecord elmRecord -> elmRecordDoc elmRecord 86 | DefType elmType -> elmTypeDoc elmType 87 | DefPrim _ -> emptyDoc 88 | 89 | -- | Pretty printer for type reference. 90 | elmTypeRefDoc :: TypeRef -> Doc ann 91 | elmTypeRefDoc = \case 92 | RefPrim elmPrim -> elmPrimDoc elmPrim 93 | RefCustom (TypeName typeName) -> pretty typeName 94 | 95 | {- | Pretty printer for primitive Elm types. This pretty printer is used only to 96 | display types of fields. 97 | -} 98 | elmPrimDoc :: ElmPrim -> Doc ann 99 | elmPrimDoc = \case 100 | ElmUnit -> "()" 101 | ElmNever -> "Never" 102 | ElmBool -> "Bool" 103 | ElmChar -> "Char" 104 | ElmInt -> "Int" 105 | ElmFloat -> "Float" 106 | ElmString -> "String" 107 | ElmTime -> "Posix" 108 | ElmValue -> "Value" 109 | ElmMaybe t -> "Maybe" <+> elmTypeParenDoc t 110 | ElmResult l r -> "Result" <+> elmTypeParenDoc l <+> elmTypeParenDoc r 111 | ElmPair a b -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> rparen 112 | ElmTriple a b c -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> comma <+> elmTypeRefDoc c <> rparen 113 | ElmList l -> "List" <+> elmTypeParenDoc l 114 | ElmNonEmptyPair a -> lparen <> elmTypeRefDoc a <> comma <+> "List" <+> elmTypeRefDoc a <> rparen 115 | 116 | {- | Pretty-printer for types. Adds parens for both sides when needed (when type 117 | consists of multiple words). 118 | -} 119 | elmTypeParenDoc :: TypeRef -> Doc ann 120 | elmTypeParenDoc = wrapParens . elmTypeRefDoc 121 | 122 | {- | Pretty printer for Elm records: 123 | 124 | @ 125 | type alias User = 126 | { userHeh : String 127 | , userMeh : Int 128 | } 129 | @ 130 | -} 131 | elmRecordDoc :: ElmRecord -> Doc ann 132 | elmRecordDoc ElmRecord{..} = nest 4 $ 133 | vsep $ ("type alias" <+> pretty elmRecordName <+> equals) 134 | : fieldsDoc elmRecordFields 135 | where 136 | fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann] 137 | fieldsDoc (fstR :| rest) = 138 | lbrace <+> recordFieldDoc fstR 139 | : map ((comma <+>) . recordFieldDoc) rest 140 | ++ [rbrace] 141 | 142 | recordFieldDoc :: ElmRecordField -> Doc ann 143 | recordFieldDoc ElmRecordField{..} = 144 | pretty elmRecordFieldName 145 | <+> colon 146 | <+> elmTypeRefDoc elmRecordFieldType 147 | 148 | {- | Pretty printer for Elm types with one or more constructors: 149 | 150 | @ 151 | type Status a 152 | = Foo String Int 153 | | Bar a 154 | | Baz 155 | @ 156 | 157 | If the type is a newtype then additionally @unTYPENAME@ function is generated: 158 | 159 | @ 160 | type Id a 161 | = Id String 162 | 163 | unId : Id a -> String 164 | unId (Id x) = x 165 | @ 166 | 167 | If the type is Enum this function will add enum specific functions: 168 | 169 | @ 170 | type Status 171 | = Approved 172 | | Yoyoyo 173 | | Wow 174 | 175 | showStatus : Status -> String 176 | showStatus x = case x of 177 | Approved -> \"Approved\" 178 | Yoyoyo -> \"Yoyoyo\" 179 | Wow -> \"Wow\" 180 | 181 | readStatus : String -> Maybe Status 182 | readStatus x = case x of 183 | \"Approved\" -> Just Approved 184 | \"Yoyoyo\" -> Just Yoyoyo 185 | \"Wow\" -> Just Wow 186 | _ -> Nothing 187 | 188 | universeStatus : List Status 189 | universeStatus = [Approved, Yoyoyo, Wow] 190 | @ 191 | -} 192 | elmTypeDoc :: ElmType -> Doc ann 193 | elmTypeDoc t@ElmType{..} = 194 | nest 4 ( vsep $ ("type" <+> pretty elmTypeName <> sepVars) 195 | : constructorsDoc elmTypeConstructors 196 | ) 197 | <> unFunc 198 | <> enumFuncs 199 | where 200 | sepVars :: Doc ann 201 | sepVars = case elmTypeVars of 202 | [] -> emptyDoc 203 | vars -> space <> sep (map pretty vars) 204 | 205 | constructorsDoc :: NonEmpty ElmConstructor -> [Doc ann] 206 | constructorsDoc (fstC :| rest) = 207 | equals <+> constructorDoc fstC 208 | : map ((pipe <+>) . constructorDoc) rest 209 | 210 | constructorDoc :: ElmConstructor -> Doc ann 211 | constructorDoc ElmConstructor{..} = sep $ 212 | pretty elmConstructorName : map elmTypeParenDoc elmConstructorFields 213 | 214 | -- Generates 'unTYPENAME' function for newtype 215 | unFunc :: Doc ann 216 | unFunc = 217 | if elmTypeIsNewtype 218 | then line <> elmUnFuncDoc t 219 | else emptyDoc 220 | 221 | enumFuncs :: Doc ann 222 | enumFuncs = 223 | if isEnum t 224 | then vsep $ map (line <>) [elmEnumShowDoc t, elmEnumReadDoc t, elmEnumUniverse t] 225 | else emptyDoc 226 | 227 | elmUnFuncDoc :: ElmType -> Doc ann 228 | elmUnFuncDoc ElmType{..} = line <> vsep 229 | [ unName <+> colon <+> typeWithVarsDoc False elmTypeName elmTypeVars <+> arrow <+> result 230 | , unName <+> parens (ctorName <+> "x") <+> equals <+> "x" 231 | ] 232 | where 233 | unName :: Doc ann 234 | unName = "un" <> pretty elmTypeName 235 | 236 | ctor :: ElmConstructor 237 | ctor = NE.head elmTypeConstructors 238 | 239 | result :: Doc ann 240 | result = case elmConstructorFields ctor of 241 | [] -> "ERROR" 242 | fld : _ -> elmTypeRefDoc fld 243 | 244 | ctorName :: Doc ann 245 | ctorName = pretty $ elmConstructorName ctor 246 | 247 | elmEnumShowDoc :: forall ann . ElmType -> Doc ann 248 | elmEnumShowDoc t@ElmType{..} = 249 | line 250 | -- function type 251 | <> (showName <+> colon <+> pretty elmTypeName <+> arrow <+> "String") 252 | <> line 253 | -- function body 254 | <> nest 4 255 | ( vsep $ (showName <+> "x" <+> equals <+> "case x of") 256 | -- pattern matching 257 | : map patternMatch (getConstructorNames t) 258 | ) 259 | where 260 | showName :: Doc ann 261 | showName = "show" <> pretty elmTypeName 262 | 263 | patternMatch :: Text -> Doc ann 264 | patternMatch (pretty -> c) = c <+> arrow <+> dquotes c 265 | 266 | elmEnumReadDoc :: ElmType -> Doc ann 267 | elmEnumReadDoc t@ElmType{..} = 268 | -- function type 269 | (readName <+> colon <+> "String" <+> arrow <+> "Maybe" <+> pretty elmTypeName) 270 | <> line 271 | -- function body 272 | <> nest 4 273 | ( vsep $ (readName <+> "x" <+> equals <+> "case x of") 274 | -- pattern matching 275 | : map patternMatch (getConstructorNames t) 276 | ++ ["_" <+> arrow <+> "Nothing"] 277 | ) 278 | where 279 | readName :: Doc ann 280 | readName = "read" <> pretty elmTypeName 281 | 282 | patternMatch :: Text -> Doc ann 283 | patternMatch (pretty -> c) = dquotes c <+> arrow <+> "Just" <+> c 284 | 285 | elmEnumUniverse :: ElmType -> Doc ann 286 | elmEnumUniverse t@ElmType{..} = vsep 287 | -- function type 288 | [ universeName <+> colon <+> "List" <+> pretty elmTypeName 289 | , universeName <+> equals <+> align (prettyList $ getConstructorNames t) 290 | ] 291 | where 292 | universeName :: Doc ann 293 | universeName = "universe" <> pretty elmTypeName 294 | -------------------------------------------------------------------------------- /src/Internal/Prettyprinter/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Internal.Prettyprinter.Compat (module PP) where 3 | 4 | #if MIN_VERSION_prettyprinter(1,7,0) 5 | import Prettyprinter as PP 6 | #else 7 | import Data.Text.Prettyprint.Doc as PP 8 | #endif 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Hspec (hspec) 4 | 5 | import Test.Golden (goldenSpec) 6 | 7 | 8 | main :: IO () 9 | main = hspec goldenSpec 10 | -------------------------------------------------------------------------------- /test/Test/Golden.hs: -------------------------------------------------------------------------------- 1 | module Test.Golden (goldenSpec) where 2 | 3 | import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn) 4 | 5 | import Types (CustomCodeGen, OneType, defaultCustomCodeGen, defaultOneType) 6 | 7 | import qualified Data.Aeson as A 8 | import qualified Data.ByteString.Lazy as LBS 9 | 10 | goldenSpec :: Spec 11 | goldenSpec = describe "golden tests" $ do 12 | describe "Default CodeGenOptions" $ do 13 | it "Golden JSON -> Haskell == default" $ 14 | A.eitherDecode @OneType <$> LBS.readFile "test/golden/oneType.json" 15 | `shouldReturn` Right defaultOneType 16 | it "default -> JSON -> Haskell == default" $ 17 | A.eitherDecode @OneType (A.encode defaultOneType) 18 | `shouldBe` Right defaultOneType 19 | describe "Custom CodeGenOptions" $ do 20 | it "should decode type with custom CodeGenOptions" $ 21 | A.eitherDecode @CustomCodeGen "{\"customFunTestInt\": 78,\"customFunTestString\": \"Hello\",\"tag\": \"CustomCodeGen\"}" 22 | `shouldBe` Right defaultCustomCodeGen 23 | it "should encode type with custom CodeGen" $ 24 | A.eitherDecode @CustomCodeGen (A.encode defaultCustomCodeGen) 25 | `shouldBe` Right defaultCustomCodeGen 26 | -------------------------------------------------------------------------------- /test/golden/oneType.json: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "OneType", 3 | "prims": { 4 | "maybe": 12, 5 | "list": [ 6 | 1, 7 | 2, 8 | 3, 9 | 4, 10 | 5 11 | ], 12 | "tag": "Prims", 13 | "time": "2019-02-22T00:00:00Z", 14 | "text": "heh", 15 | "string": "bye", 16 | "result": { 17 | "Left": 666 18 | }, 19 | "pair": [ 20 | "o", 21 | false 22 | ], 23 | "triple": [ 24 | "o", 25 | false, 26 | [0] 27 | ], 28 | "float": 36.6, 29 | "char": "a", 30 | "int": 42, 31 | "bool": true, 32 | "unit": [], 33 | "nonEmpty": [1], 34 | "value": { 35 | "boolField": true, 36 | "numberField": 1, 37 | "stringField": "hi", 38 | "objectField": {}, 39 | "arrayField": [1,2,3], 40 | "nullField": null 41 | } 42 | }, 43 | "myUnit": { 44 | "tag": "MyUnit", 45 | "contents": [] 46 | }, 47 | "myResult": { 48 | "tag": "Err", 49 | "contents": "clashing test" 50 | }, 51 | "userRequest": { 52 | "tag": "UserRequest", 53 | "example": { 54 | "Right": { 55 | "tag": "Blocked" 56 | } 57 | }, 58 | "ids": [ 59 | "1", 60 | "2" 61 | ], 62 | "limit": 123 63 | }, 64 | "age": 18, 65 | "newtype": 666, 66 | "newtypeList": [123], 67 | "oneConstructor": "OneConstructor", 68 | "user": { 69 | "status": "Approved", 70 | "tag": "User", 71 | "age": 100, 72 | "name": "not-me", 73 | "id": "1" 74 | }, 75 | "id": "myId", 76 | "requestStatus": "Reviewing", 77 | "guests": [ 78 | { 79 | "tag": "Regular", 80 | "contents": [ 81 | "nice", 82 | 7 83 | ] 84 | }, 85 | { 86 | "tag": "Visitor", 87 | "contents": "new-guest" 88 | }, 89 | { 90 | "tag": "Blocked" 91 | } 92 | ], 93 | "nonEmpty": [ 94 | { 95 | "tag": "MyUnit", 96 | "contents": [] 97 | }, 98 | { 99 | "tag": "MyUnit", 100 | "contents": [] 101 | } 102 | ] 103 | } 104 | 105 | -------------------------------------------------------------------------------- /types/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | {- | Haskell types used for testing `elm-street` generated Elm types. 8 | -} 9 | 10 | module Types 11 | ( Types 12 | , OneType (..) 13 | , defaultOneType 14 | , defaultCustomCodeGen 15 | 16 | -- * All test types 17 | , Prims (..) 18 | , Id (..) 19 | , Age (..) 20 | , Newtype (..) 21 | , NewtypeList (..) 22 | , OneConstructor (..) 23 | , RequestStatus (..) 24 | , User (..) 25 | , Guest (..) 26 | , UserRequest (..) 27 | , CustomCodeGen (..) 28 | ) where 29 | 30 | import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), object, (.=), GFromJSON, GToJSON, Zero) 31 | import Data.List.NonEmpty (NonEmpty(..)) 32 | import Data.Text (Text) 33 | import Data.Time.Calendar (fromGregorian) 34 | import Data.Time.Clock (UTCTime (..)) 35 | import Data.Word (Word32) 36 | import Elm (Elm (..), ElmStreet (..), elmNewtype) 37 | import Elm.Generic (CodeGenOptions (..), ElmStreetGenericConstraints, GenericElmDefinition(..)) 38 | import Elm.Aeson (elmStreetParseJsonWith, elmStreetToJsonWith) 39 | import GHC.Generics (Generic, Rep) 40 | 41 | import qualified GHC.Generics as Generic (from) 42 | import qualified Data.Text as Text 43 | 44 | data Prims = Prims 45 | { primsUnit :: !() 46 | , primsBool :: !Bool 47 | , primsChar :: !Char 48 | , primsInt :: !Int 49 | , primsFloat :: !Double 50 | , primsText :: !Text 51 | , primsString :: !String 52 | , primsTime :: !UTCTime 53 | , primsValue :: !Value 54 | , primsMaybe :: !(Maybe Word) 55 | , primsResult :: !(Either Int Text) 56 | , primsPair :: !(Char, Bool) 57 | , primsTriple :: !(Char, Bool, [Int]) 58 | , primsList :: ![Int] 59 | , primsNonEmpty :: !(NonEmpty Int) 60 | } deriving (Generic, Eq, Show) 61 | deriving (Elm, ToJSON, FromJSON) via ElmStreet Prims 62 | 63 | newtype Id a = Id 64 | { unId :: Text 65 | } deriving (Show, Eq) 66 | deriving newtype (FromJSON, ToJSON) 67 | 68 | instance Elm (Id a) where 69 | toElmDefinition _ = elmNewtype @Text "Id" "unId" 70 | 71 | newtype Age = Age 72 | { unAge :: Int 73 | } deriving (Generic, Eq, Show) 74 | deriving anyclass (Elm) 75 | deriving newtype (FromJSON, ToJSON) 76 | 77 | newtype Newtype = Newtype Int 78 | deriving stock (Generic, Eq, Show) 79 | deriving newtype (FromJSON, ToJSON) 80 | deriving anyclass (Elm) 81 | 82 | newtype NewtypeList = NewtypeList [Int] 83 | deriving stock (Generic, Eq, Show) 84 | deriving newtype (FromJSON, ToJSON) 85 | deriving anyclass (Elm) 86 | 87 | data OneConstructor = OneConstructor 88 | deriving stock (Generic, Eq, Show) 89 | deriving (Elm, FromJSON, ToJSON) via ElmStreet OneConstructor 90 | 91 | data RequestStatus 92 | = Approved 93 | | Rejected 94 | | Reviewing 95 | deriving (Generic, Eq, Show) 96 | deriving (Elm, FromJSON, ToJSON) via ElmStreet RequestStatus 97 | 98 | data User = User 99 | { userId :: !(Id User) 100 | , userName :: !Text 101 | , userAge :: !Age 102 | , userStatus :: !RequestStatus 103 | } deriving (Generic, Eq, Show) 104 | deriving (Elm, FromJSON, ToJSON) via ElmStreet User 105 | 106 | data Guest 107 | = Regular Text Int 108 | | Visitor Text 109 | | Special (Maybe [Int]) 110 | | Blocked 111 | deriving (Generic, Eq, Show) 112 | deriving (Elm, FromJSON, ToJSON) via ElmStreet Guest 113 | 114 | data UserRequest = UserRequest 115 | { userRequestIds :: ![Id User] 116 | , userRequestLimit :: !Word32 117 | , userRequestExample :: !(Maybe (Either User Guest)) 118 | } deriving (Generic, Eq, Show) 119 | deriving (Elm, FromJSON, ToJSON) via ElmStreet UserRequest 120 | 121 | data MyUnit = MyUnit () 122 | deriving stock (Show, Eq, Ord, Generic) 123 | deriving (Elm, ToJSON, FromJSON) via ElmStreet MyUnit 124 | 125 | -- | For name clashes testing. 126 | data MyResult 127 | = Ok 128 | | Err Text 129 | deriving (Generic, Eq, Show) 130 | deriving (Elm, FromJSON, ToJSON) via ElmStreet MyResult 131 | 132 | -- | All test types together in one type to play with. 133 | data OneType = OneType 134 | { oneTypePrims :: !Prims 135 | , oneTypeMyUnit :: !MyUnit 136 | , oneTypeMyResult :: !MyResult 137 | , oneTypeId :: !(Id OneType) 138 | , oneTypeAge :: !Age 139 | , oneTypeNewtype :: !Newtype 140 | , oneTypeNewtypeList :: !NewtypeList 141 | , oneTypeOneConstructor :: !OneConstructor 142 | , oneTypeRequestStatus :: !RequestStatus 143 | , oneTypeUser :: !User 144 | , oneTypeGuests :: ![Guest] 145 | , oneTypeUserRequest :: !UserRequest 146 | , oneTypeNonEmpty :: !(NonEmpty MyUnit) 147 | } deriving (Generic, Eq, Show) 148 | deriving (Elm, FromJSON, ToJSON) via ElmStreet OneType 149 | 150 | data CustomCodeGen = CustomCodeGen 151 | { customCodeGenString :: String 152 | , customCodeGenInt :: Int 153 | } deriving stock (Generic, Eq, Show) 154 | deriving (Elm, FromJSON, ToJSON) via CustomElm CustomCodeGen 155 | 156 | -- Settings which do some custom modifications of record filed names 157 | customCodeGenOptions :: CodeGenOptions 158 | customCodeGenOptions = CodeGenOptions (Text.replace "CodeGen" "FunTest") 159 | 160 | -- Newtype whose Elm/ToJSON/FromJSON instance use custom CodeGenOptions 161 | newtype CustomElm a = CustomElm {unCustomElm :: a} 162 | 163 | instance ElmStreetGenericConstraints a => Elm (CustomElm a) where 164 | toElmDefinition _ = genericToElmDefinition customCodeGenOptions 165 | $ Generic.from (error "Proxy for generic elm was evaluated" :: a) 166 | 167 | instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomElm a) where 168 | toJSON = elmStreetToJsonWith customCodeGenOptions . unCustomElm 169 | 170 | instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomElm a) where 171 | parseJSON = fmap CustomElm . elmStreetParseJsonWith customCodeGenOptions 172 | 173 | -- | Type level list of all test types. 174 | type Types = 175 | '[ Prims 176 | , MyUnit 177 | , MyResult 178 | , Id () 179 | , Age 180 | , Newtype 181 | , NewtypeList 182 | , OneConstructor 183 | , RequestStatus 184 | , User 185 | , Guest 186 | , UserRequest 187 | , OneType 188 | , CustomCodeGen 189 | ] 190 | 191 | 192 | defaultOneType :: OneType 193 | defaultOneType = OneType 194 | { oneTypePrims = defaultPrims 195 | , oneTypeMyUnit = MyUnit () 196 | , oneTypeMyResult = Err "clashing test" 197 | , oneTypeId = Id "myId" 198 | , oneTypeAge = Age 18 199 | , oneTypeNewtype = Newtype 666 200 | , oneTypeNewtypeList = NewtypeList [123] 201 | , oneTypeOneConstructor = OneConstructor 202 | , oneTypeRequestStatus = Reviewing 203 | , oneTypeUser = User (Id "1") "not-me" (Age 100) Approved 204 | , oneTypeGuests = [guestRegular, guestVisitor, guestBlocked] 205 | , oneTypeUserRequest = defaultUserRequest 206 | , oneTypeNonEmpty = MyUnit () :| [ MyUnit () ] 207 | } 208 | where 209 | defaultPrims :: Prims 210 | defaultPrims = Prims 211 | { primsUnit = () 212 | , primsBool = True 213 | , primsChar = 'a' 214 | , primsInt = 42 215 | , primsFloat = 36.6 216 | , primsText = "heh" 217 | , primsString = "bye" 218 | , primsValue = object 219 | [ "nullField" .= Null 220 | , "boolField" .= True 221 | , "numberField" .= (1::Int) 222 | , "stringField" .= ("hi"::String) 223 | , "arrayField" .= [1::Int,2,3] 224 | , "objectField" .= object [] 225 | ] 226 | , primsTime = UTCTime (fromGregorian 2019 2 22) 0 227 | , primsMaybe = Just 12 228 | , primsResult = Left 666 229 | , primsPair = ('o', False) 230 | , primsTriple = ('o', False, [0]) 231 | , primsList = [1..5] 232 | , primsNonEmpty = 1 :| [] 233 | } 234 | 235 | guestRegular, guestVisitor, guestBlocked :: Guest 236 | guestRegular = Regular "nice" 7 237 | guestVisitor = Visitor "new-guest" 238 | guestBlocked = Blocked 239 | 240 | defaultUserRequest :: UserRequest 241 | defaultUserRequest = UserRequest 242 | { userRequestIds = [Id "1", Id "2"] 243 | , userRequestLimit = 123 244 | , userRequestExample = Just (Right Blocked) 245 | } 246 | 247 | defaultCustomCodeGen :: CustomCodeGen 248 | defaultCustomCodeGen = CustomCodeGen 249 | { customCodeGenString = "Hello" 250 | , customCodeGenInt = 78 251 | } 252 | --------------------------------------------------------------------------------