├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── elm-bridge.cabal ├── examples └── Example1.hs ├── src └── Elm │ ├── Derive.hs │ ├── Json.hs │ ├── Module.hs │ ├── TyRender.hs │ ├── TyRep.hs │ ├── Utils.hs │ └── Versions.hs └── test ├── Elm ├── DeriveSpec.hs ├── JsonSpec.hs ├── ModuleSpec.hs ├── TyRenderSpec.hs └── TyRepSpec.hs ├── EndToEnd.hs ├── Spec.hs └── current-end-to-end ├── .gitignore ├── elm.json └── src └── MyTests.elm /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.toptal.com/developers/gitignore/api/haskell,macos 2 | # Edit at https://www.toptal.com/developers/gitignore?templates=haskell,macos 3 | 4 | ### Haskell ### 5 | dist 6 | dist-* 7 | cabal-dev 8 | *.o 9 | *.hi 10 | *.hie 11 | *.chi 12 | *.chs.h 13 | *.dyn_o 14 | *.dyn_hi 15 | .hpc 16 | .hsenv 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | *.prof 20 | *.aux 21 | *.hp 22 | *.eventlog 23 | .stack-work/ 24 | cabal.project.local 25 | cabal.project.local~ 26 | .HTF/ 27 | .ghc.environment.* 28 | 29 | ### macOS ### 30 | # General 31 | .DS_Store 32 | .AppleDouble 33 | .LSOverride 34 | 35 | # Icon must end with two \r 36 | Icon 37 | 38 | 39 | # Thumbnails 40 | ._* 41 | 42 | # Files that might appear in the root of a volume 43 | .DocumentRevisions-V100 44 | .fseventsd 45 | .Spotlight-V100 46 | .TemporaryItems 47 | .Trashes 48 | .VolumeIcon.icns 49 | .com.apple.timemachine.donotpresent 50 | 51 | # Directories potentially created on remote AFP share 52 | .AppleDB 53 | .AppleDesktop 54 | Network Trash Folder 55 | Temporary Items 56 | .apdisk 57 | 58 | ### macOS Patch ### 59 | # iCloud generated files 60 | *.icloud 61 | 62 | # End of https://www.toptal.com/developers/gitignore/api/haskell,macos 63 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'elm-bridge.cabal' '--output' '.travis.yml' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.13.20210806 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: bionic 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-9.0.1 37 | addons: {"apt":{"packages":["ghc-9.0.1","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} 38 | os: linux 39 | before_install: 40 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 41 | - WITHCOMPILER="-w $HC" 42 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 43 | - HCPKG="$HC-pkg" 44 | - unset CC 45 | - CABAL=/opt/ghc/bin/cabal 46 | - CABALHOME=$HOME/.cabal 47 | - export PATH="$CABALHOME/bin:$PATH" 48 | - TOP=$(pwd) 49 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 50 | - echo $HCNUMVER 51 | - CABAL="$CABAL -vnormal+nowrap" 52 | - set -o pipefail 53 | - TEST=--enable-tests 54 | - BENCH=--enable-benchmarks 55 | - HEADHACKAGE=false 56 | - rm -f $CABALHOME/config 57 | - | 58 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 59 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 60 | echo "write-ghc-environment-files: never" >> $CABALHOME/config 61 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 62 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 63 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 64 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 65 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 66 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 67 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 68 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 69 | echo "install-dirs user" >> $CABALHOME/config 70 | echo " prefix: $CABALHOME" >> $CABALHOME/config 71 | echo "repository hackage.haskell.org" >> $CABALHOME/config 72 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 73 | install: 74 | - ${CABAL} --version 75 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 76 | - | 77 | echo "program-default-options" >> $CABALHOME/config 78 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 79 | - cat $CABALHOME/config 80 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 81 | - travis_retry ${CABAL} v2-update -v 82 | # Generate cabal.project 83 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 84 | - touch cabal.project 85 | - | 86 | echo "packages: ." >> cabal.project 87 | - echo 'package elm-bridge' >> cabal.project 88 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 89 | - "" 90 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(elm-bridge)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 91 | - cat cabal.project || true 92 | - cat cabal.project.local || true 93 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 94 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 95 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 96 | - rm cabal.project.freeze 97 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 98 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 99 | script: 100 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 101 | # Packaging... 102 | - ${CABAL} v2-sdist all 103 | # Unpacking... 104 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 105 | - cd ${DISTDIR} || false 106 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 107 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 108 | - PKGDIR_elm_bridge="$(find . -maxdepth 1 -type d -regex '.*/elm-bridge-[0-9.]*')" 109 | # Generate cabal.project 110 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 111 | - touch cabal.project 112 | - | 113 | echo "packages: ${PKGDIR_elm_bridge}" >> cabal.project 114 | - echo 'package elm-bridge' >> cabal.project 115 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 116 | - "" 117 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(elm-bridge)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 118 | - cat cabal.project || true 119 | - cat cabal.project.local || true 120 | # Building... 121 | # this builds all libraries and executables (without tests/benchmarks) 122 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 123 | # Building with tests and benchmarks... 124 | # build & run tests, build benchmarks 125 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all --write-ghc-environment-files=always 126 | # Testing... 127 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all --test-show-details=direct 128 | # cabal check... 129 | - (cd ${PKGDIR_elm_bridge} && ${CABAL} -vnormal check) 130 | # haddock... 131 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 132 | # Building without installed constraints for packages in global-db... 133 | - rm -f cabal.project.local 134 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 135 | 136 | # REGENDATA ("0.13.20210806",["elm-bridge.cabal","--output",".travis.yml"]) 137 | # EOF 138 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # v0.8.3 2 | 3 | * Support Int32 and Int64, from domenkozar 4 | 5 | # v0.8.0 6 | 7 | * Directly support integer keys in dictionnaries, thanks to odanoboru 8 | 9 | # v0.7.0 10 | 11 | * Support for GHC 9 12 | 13 | # v0.6.0 14 | 15 | * Support for Elm 0.19 16 | 17 | # v0.5.2 18 | 19 | * Fix a bug about tuples. 20 | 21 | # v0.5.0 22 | 23 | * Large change for sum types that used `constructorTagModifier`. The generated types are now unaffected! This is a breaking change for those who used this feature. 24 | 25 | # v0.4.2 26 | 27 | Drop support for `aeson < 1.` 28 | Add support for `aeson == 1.2.*` 29 | 30 | # v0.4.1 31 | 32 | ## Bugfixes 33 | * Fixed support for Elm 0.18 (see issue #17) 34 | 35 | # v0.4.0 36 | ## New features 37 | * Support for Elm 0.18 38 | * Dropped support for Elm 0.17 and Elm 0.16 39 | 40 | # v0.3.0 41 | ## New features 42 | * Support for Elm 0.17 43 | 44 | # v0.2.2 45 | 46 | ## New features 47 | * The Elm JSON encoders and decoders now match `aeson` more closely. In partlicular, single constructor sum types are now encoded without 48 | the constructor. Also, the `aeson` 0.11 option `unwrapUnaryRecords` is now supported. 49 | 50 | ## Bugfixes 51 | * Fixed Elm type error in encoders for types like `[Map String v]` (0.2.1.2). 52 | 53 | # v0.2.1 54 | 55 | ## New features 56 | 57 | * The template Haskell derivation functions now take `aeson` `Option` type instead of a custom type. 58 | This change makes it easier to synchronize the Haskell and Elm code. 59 | * The generated Elm code can be personalized. Helpers functions assist in converting type names, and defining which type will be newtyped. 60 | 61 | ## Notes 62 | 63 | * The generated Elm code depends on the [bartavelle/json-helpers](http://package.elm-lang.org/packages/bartavelle/json-helpers/1.1.0/) package. 64 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 - 2016 Alexander Thiemann and contributors 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Thiemann or agrafix nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Elm Bridge 2 | ===== 3 | 4 | [![Build Status](https://travis-ci.org/agrafix/elm-bridge.svg)](https://travis-ci.org/agrafix/elm-bridge) 5 | 6 | [![Hackage Deps](https://img.shields.io/hackage-deps/v/elm-bridge.svg)](http://packdeps.haskellers.com/reverse/elm-bridge) 7 | 8 | ## Intro 9 | 10 | Hackage: [elm-bridge](http://hackage.haskell.org/package/elm-bridge) 11 | 12 | Building the bridge from [Haskell](http://haskell.org) to [Elm](http://elm-lang.org) and back. Define types once, use on both sides and enjoy easy (de)serialisation. Cheers! 13 | 14 | This version of the package only supports Elm 0.19. Version 0.5.2 supports Elm 0.18, and Version 0.3.0.2 supports Elm 0.16 and Elm 0.17. 15 | 16 | Note that the [bartavelle/json-helpers](http://package.elm-lang.org/packages/bartavelle/json-helpers/latest/) package, with version >= 1.2.0, is expected by the generated Elm modules. 17 | 18 | ## Usage 19 | 20 | ```haskell 21 | {-# LANGUAGE TemplateHaskell #-} 22 | import Elm.Derive 23 | import Elm.Module 24 | 25 | import Data.Proxy 26 | 27 | data Foo 28 | = Foo 29 | { f_name :: String 30 | , f_blablub :: Int 31 | } deriving (Show, Eq) 32 | 33 | deriveBoth defaultOptions ''Foo 34 | 35 | main :: IO () 36 | main = 37 | putStrLn $ makeElmModule "Foo" 38 | [ DefineElm (Proxy :: Proxy Foo) 39 | ] 40 | 41 | ``` 42 | 43 | Output will be: 44 | 45 | ```elm 46 | module Foo where 47 | 48 | import Json.Decode 49 | import Json.Decode exposing ((:=)) 50 | import Json.Encode 51 | import Json.Helpers exposing (..) 52 | 53 | 54 | type alias Foo = 55 | { f_name: String 56 | , f_blablub: Int 57 | } 58 | 59 | jsonDecFoo : Json.Decode.Decoder ( Foo ) 60 | jsonDecFoo = 61 | ("f_name" := Json.Decode.string) `Json.Decode.andThen` \pf_name -> 62 | ("f_blablub" := Json.Decode.int) `Json.Decode.andThen` \pf_blablub -> 63 | Json.Decode.succeed {f_name = pf_name, f_blablub = pf_blablub} 64 | 65 | jsonEncFoo : Foo -> Value 66 | jsonEncFoo val = 67 | Json.Encode.object 68 | [ ("f_name", Json.Encode.string val.f_name) 69 | , ("f_blablub", Json.Encode.int val.f_blablub) 70 | ] 71 | ``` 72 | 73 | Also, there are functions `Elm.Json.stringSerForSimpleAdt` and `Elm.Json.stringParserForSimpleAdt` to generate functions for your non-JSON ADT types. 74 | 75 | For more usage examples check the tests or the examples dir. 76 | 77 | ## Install 78 | 79 | ### Haskell 80 | 81 | * Using cabal: `cabal install elm-bridge` 82 | * From Source: `git clone https://github.com/agrafix/elm-bridge.git && cd elm-bridge && cabal install` 83 | 84 | ### Elm 85 | 86 | * `elm package install bartavelle/json-helpers` 87 | 88 | or, for Elm 0.19: 89 | 90 | * `elm install bartavelle/json-helpers` 91 | 92 | ## Contribute 93 | 94 | Pull requests are welcome! Please consider creating an issue beforehand, so we can discuss what you would like to do. Code should be written in a consistent style throughout the project. Avoid whitespace that is sensible to conflicts. (E.g. alignment of `=` signs in functions definitions) Note that by sending a pull request you agree that your contribution can be released under the BSD3 License as part of the `elm-bridge` package or related packages. 95 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /elm-bridge.cabal: -------------------------------------------------------------------------------- 1 | name: elm-bridge 2 | version: 0.8.4 3 | synopsis: Derive Elm types and Json code from Haskell types, using aeson's options 4 | description: Building the bridge from Haskell to Elm and back. Define types once, 5 | and derive the aeson and elm functions at the same time, using any aeson 6 | option you like. Cheers! 7 | homepage: https://github.com/agrafix/elm-bridge 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alexander Thiemann , Simon Marechal 11 | maintainer: Alexander Thiemann 12 | copyright: (c) 2015 - 2016 Alexander Thiemann and contributors 13 | category: Web, Compiler, Language 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | tested-with: GHC==9.0.1 17 | 18 | extra-source-files: 19 | README.md 20 | CHANGELOG.md 21 | examples/*.hs 22 | 23 | 24 | library 25 | hs-source-dirs: src 26 | ghc-options: -Wall 27 | exposed-modules: 28 | Elm.Derive 29 | Elm.Json 30 | Elm.Module 31 | Elm.TyRender 32 | Elm.TyRep 33 | Elm.Versions 34 | other-modules: Elm.Utils 35 | build-depends: base >= 4.15 && < 5, 36 | template-haskell, 37 | aeson >= 1 38 | default-language: Haskell2010 39 | 40 | test-suite end-to-end-tests 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: EndToEnd.hs 44 | build-depends: base, 45 | elm-bridge, 46 | aeson, 47 | containers, 48 | QuickCheck, 49 | text 50 | ghc-options: -O0 51 | default-language: Haskell2010 52 | 53 | test-suite derive-elm-tests 54 | type: exitcode-stdio-1.0 55 | hs-source-dirs: test 56 | main-is: Spec.hs 57 | other-modules: 58 | Elm.DeriveSpec 59 | Elm.TyRenderSpec 60 | Elm.JsonSpec 61 | Elm.ModuleSpec 62 | Elm.TyRepSpec 63 | build-depends: 64 | base, 65 | hspec >= 2.0, 66 | elm-bridge, 67 | aeson, 68 | containers 69 | default-language: Haskell2010 70 | 71 | source-repository head 72 | type: git 73 | location: https://github.com/agrafix/elm-bridge 74 | -------------------------------------------------------------------------------- /examples/Example1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | import "elm-bridge" Elm.Derive 4 | import "elm-bridge" Elm.Module 5 | 6 | import Data.Proxy 7 | 8 | data Foo 9 | = Foo 10 | { f_name :: String 11 | , f_blablub :: Int 12 | } deriving (Show, Eq) 13 | 14 | deriveBoth defaultOptions ''Foo 15 | 16 | main :: IO () 17 | main = 18 | putStrLn $ makeElmModule "Foo" 19 | [ DefineElm (Proxy :: Proxy Foo) 20 | ] 21 | -------------------------------------------------------------------------------- /src/Elm/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-| This module should be used to derive the Elm instance alongside the 5 | JSON ones. The prefered usage is to convert statements such as : 6 | 7 | > $(deriveJSON defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D) 8 | 9 | into: 10 | 11 | > $(deriveBoth defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D) 12 | 13 | Which will derive both the @aeson@ and @elm-bridge@ instances at the same 14 | time. 15 | -} 16 | 17 | module Elm.Derive 18 | ( -- * Options 19 | A.Options(..) 20 | , A.SumEncoding(..) 21 | , defaultOptions 22 | , defaultOptionsDropLower 23 | -- * Template haskell functions 24 | , deriveElmDef 25 | , deriveBoth 26 | ) 27 | where 28 | 29 | import Elm.TyRep 30 | 31 | import Control.Applicative 32 | import Control.Monad 33 | import Data.Aeson.TH (SumEncoding (..), deriveJSON, tagSingleConstructors) 34 | import qualified Data.Aeson.TH as A 35 | import Data.Char (toLower) 36 | import Language.Haskell.TH 37 | import Language.Haskell.TH.Syntax 38 | import Prelude 39 | 40 | -- | Note that This default set of options is distinct from that in 41 | -- the @aeson@ package. 42 | defaultOptions :: A.Options 43 | defaultOptions 44 | = A.defaultOptions 45 | { A.sumEncoding = A.ObjectWithSingleField 46 | , A.fieldLabelModifier = id 47 | , A.constructorTagModifier = id 48 | , A.allNullaryToStringTag = True 49 | , A.omitNothingFields = False 50 | , A.unwrapUnaryRecords = True 51 | } 52 | 53 | unwrapUnaryRecords :: A.Options -> Bool 54 | unwrapUnaryRecords = A.unwrapUnaryRecords 55 | 56 | {-| This generates a default set of options. The parameter represents the 57 | number of characters that must be dropped from the Haskell field names. 58 | The first letter of the field is then converted to lowercase, ie: 59 | 60 | > data Foo = Foo { _fooBarQux :: Int } 61 | > $(deriveBoth (defaultOptionsDropLower 4) ''Foo) 62 | 63 | Will be encoded as: 64 | 65 | > {"barQux"=12} 66 | -} 67 | defaultOptionsDropLower :: Int -> A.Options 68 | defaultOptionsDropLower n = defaultOptions { A.fieldLabelModifier = lower . drop n } 69 | where 70 | lower "" = "" 71 | lower (x:xs) = toLower x : xs 72 | 73 | compileType :: Type -> Q Exp 74 | compileType ty = 75 | case ty of 76 | ListT -> [|ETyCon (ETCon "List")|] 77 | TupleT i -> [|ETyTuple i|] 78 | VarT name -> 79 | let n = nameBase name 80 | in [|ETyVar (ETVar n)|] 81 | SigT ty' _ -> 82 | compileType ty' 83 | AppT a b -> [|ETyApp $(compileType a) $(compileType b)|] 84 | ConT name -> 85 | let n = nameBase name 86 | in [|ETyCon (ETCon n)|] 87 | _ -> fail $ "Unsupported type: " ++ show ty 88 | 89 | optSumType :: SumEncoding -> Q Exp 90 | optSumType se = 91 | case se of 92 | TwoElemArray -> [|SumEncoding' TwoElemArray|] 93 | ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|] 94 | TaggedObject tn cn -> [|SumEncoding' (TaggedObject tn cn)|] 95 | UntaggedValue -> [|SumEncoding' UntaggedValue|] 96 | 97 | runDerive :: Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec] 98 | runDerive name vars mkBody = 99 | liftM (:[]) elmDefInst 100 | where 101 | elmDefInst = 102 | instanceD (cxt []) 103 | (classType `appT` instanceType) 104 | [ funD 'compileElmDef 105 | [ clause [ return WildP ] (normalB body) [] 106 | ] 107 | ] 108 | 109 | classType = conT ''IsElmDefinition 110 | instanceType = foldl appT (conT name) $ map varT argNames 111 | 112 | body = mkBody [|ETypeName { et_name = nameStr, et_args = $args }|] 113 | 114 | nameStr = nameBase name 115 | args = 116 | listE $ map mkTVar argNames 117 | mkTVar :: Name -> Q Exp 118 | mkTVar n = 119 | let str = nameBase n 120 | in [|ETVar str|] 121 | 122 | argNames = 123 | flip map vars $ \v -> 124 | case v of 125 | PlainTV tv _ -> tv 126 | KindedTV tv _ _ -> tv 127 | 128 | deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec] 129 | deriveAlias isNewtype opts name vars conFields = 130 | runDerive name vars $ \typeName -> 131 | [|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype 132 | where 133 | unwrapUnary = unwrapUnaryRecords opts 134 | fields = listE $ map mkField conFields 135 | omitNothing = A.omitNothingFields opts 136 | mkField :: VarStrictType -> Q Exp 137 | mkField (fname, _, ftype) = 138 | [|(fldName, $fldType)|] 139 | where 140 | fldName = A.fieldLabelModifier opts $ nameBase fname 141 | fldType = compileType ftype 142 | 143 | deriveSum :: A.Options -> Name -> [TyVarBndr a] -> [Con] -> Q [Dec] 144 | deriveSum opts name vars constrs = 145 | runDerive name vars $ \typeName -> 146 | [|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|] 147 | where 148 | allNullary = A.allNullaryToStringTag opts 149 | sumEncOpts = optSumType (A.sumEncoding opts) 150 | omitNothing = A.omitNothingFields opts 151 | sumOpts = listE $ map mkOpt constrs 152 | mkOpt :: Con -> Q Exp 153 | mkOpt c = 154 | let modifyName n = (nameBase n, A.constructorTagModifier opts (nameBase n)) 155 | in case c of 156 | NormalC name' args -> 157 | let (b, n) = modifyName name' 158 | tyArgs = listE $ map (\(_, ty) -> compileType ty) args 159 | in [|STC b n (Anonymous $tyArgs)|] 160 | RecC name' args -> 161 | let (b, n) = modifyName name' 162 | tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm 163 | in [|(nm', $(compileType ty))|]) args 164 | in [|STC b n (Named $tyArgs)|] 165 | _ -> fail ("Can't derive this sum: " ++ show c) 166 | 167 | deriveSynonym :: A.Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec] 168 | deriveSynonym _ name vars otherT = 169 | runDerive name vars $ \typeName -> 170 | [|ETypePrimAlias (EPrimAlias $typeName $otherType)|] 171 | where 172 | otherType = compileType otherT 173 | 174 | -- | Equivalent to running both 'deriveJSON' and 'deriveElmDef' with the 175 | -- same options, so as to ensure the code on the Haskell and Elm size is 176 | -- synchronized. 177 | deriveBoth :: A.Options -> Name -> Q [Dec] 178 | deriveBoth o n = (++) <$> deriveElmDef o n <*> deriveJSON o n 179 | 180 | -- | Just derive the @elm-bridge@ definitions for generating the 181 | -- serialization/deserialization code. It must be kept synchronized with 182 | -- the Haskell code manually. 183 | deriveElmDef :: A.Options -> Name -> Q [Dec] 184 | deriveElmDef opts name = 185 | do TyConI tyCon <- reify name 186 | case tyCon of 187 | DataD _ _ tyVars _ constrs _ -> 188 | case constrs of 189 | [] -> fail "Can not derive empty data decls" 190 | [RecC _ conFields] | not (tagSingleConstructors opts) -> deriveAlias False opts name tyVars conFields 191 | _ -> deriveSum opts name tyVars constrs 192 | NewtypeD [] _ [] Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> 193 | deriveSynonym opts name [] otherTy 194 | NewtypeD [] _ [] Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> 195 | if A.unwrapUnaryRecords opts 196 | then deriveSynonym opts name [] otherTy 197 | else deriveAlias True opts name [] conFields 198 | TySynD _ vars otherTy -> 199 | deriveSynonym opts name vars otherTy 200 | NewtypeD _ _ tyvars Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> 201 | deriveSynonym opts name tyvars otherTy 202 | NewtypeD _ _ tyvars Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> 203 | if A.unwrapUnaryRecords opts 204 | then deriveSynonym opts name tyvars otherTy 205 | else deriveAlias True opts name tyvars conFields 206 | _ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon) 207 | -------------------------------------------------------------------------------- /src/Elm/Json.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | This module implements a generator for JSON serialisers and parsers of arbitrary elm types. 3 | 4 | It is highly recommended to either only use the functions of "Elm.Module", or to use the functions in this module 5 | after having modified the 'ETypeDef' arguments with functions such as 'defaultAlterations'. 6 | 7 | The reason is that Elm types might have an equivalent on the Haskell side and should be converted (ie. 'Text' -> 'String', 'Vector' -> 'List'). 8 | -} 9 | module Elm.Json 10 | ( jsonParserForDef 11 | , jsonSerForDef 12 | , jsonParserForType 13 | , jsonSerForType 14 | , stringSerForSimpleAdt 15 | , stringParserForSimpleAdt 16 | ) 17 | where 18 | 19 | import Data.Aeson.Types (SumEncoding (..)) 20 | import Data.List 21 | import Elm.TyRep 22 | import Elm.Utils 23 | 24 | data MaybeHandling = Root | Leaf 25 | deriving Eq 26 | 27 | -- | Compile a JSON parser for an Elm type 28 | jsonParserForType :: EType -> String 29 | jsonParserForType = jsonParserForType' Leaf 30 | 31 | isOption :: EType -> Bool 32 | isOption (ETyApp (ETyCon (ETCon "Maybe")) _) = True 33 | isOption _ = False 34 | 35 | jsonParserForType' :: MaybeHandling -> EType -> String 36 | jsonParserForType' mh ty = 37 | case ty of 38 | ETyVar (ETVar v) -> "localDecoder_" ++ v 39 | ETyCon (ETCon "Int") -> "Json.Decode.int" 40 | ETyCon (ETCon "Float") -> "Json.Decode.float" 41 | ETyCon (ETCon "String") -> "Json.Decode.string" 42 | ETyCon (ETCon "Bool") -> "Json.Decode.bool" 43 | ETyCon (ETCon c) -> "jsonDec" ++ c 44 | ETyApp (ETyCon (ETCon "List")) t' -> "Json.Decode.list (" ++ jsonParserForType t' ++ ")" 45 | ETyApp (ETyCon (ETCon "Maybe")) t' -> if mh == Root 46 | then jsonParserForType t' 47 | else "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")" 48 | ETyApp (ETyCon (ETCon "Set")) t' -> "decodeSet (" ++ jsonParserForType t' ++ ")" 49 | ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String")) ) value -> "Json.Decode.dict (" ++ jsonParserForType value ++ ")" 50 | ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "decodeMap (" ++ jsonParserForType key ++ ") (" ++ jsonParserForType value ++ ")" 51 | _ -> 52 | case unpackTupleType ty of 53 | [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty 54 | [x] -> 55 | case unpackToplevelConstr x of 56 | (y : ys) -> 57 | jsonParserForType y ++ " " 58 | ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")" ) ys) 59 | _ -> error $ "Do suitable json parser found for " ++ show ty 60 | xs -> 61 | let tupleLen = length xs 62 | in "Json.Decode.map" ++ show tupleLen ++ " tuple" ++ show tupleLen ++ " " 63 | ++ unwords (zipWith (\i t' -> "(Json.Decode.index " ++ show (i :: Int) ++ " (" ++ jsonParserForType t' ++ "))") [0..] xs) 64 | 65 | parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String] 66 | parseRecords newtyped unwrap fields = 67 | case fields of 68 | [(_, ftype)] | unwrap -> [ succeed ++ " |> custom (" ++ jsonParserForType' (o ftype) ftype ++ ")" ] 69 | _ -> succeed : map mkField fields 70 | where 71 | succeed = " Json.Decode.succeed (\\" ++ unwords (map ( ('p':) . fst ) fields) ++ " -> " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}") ++ ")" 72 | mkNewtype x = case newtyped of 73 | Nothing -> x 74 | Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")" 75 | o fldType = if isOption fldType 76 | then Root 77 | else Leaf 78 | mkField (fldName, fldType) = 79 | " |> " ++ (if isOption fldType then "fnullable " else "required ") 80 | ++ show fldName 81 | ++ " (" ++ jsonParserForType' (o fldType) fldType ++ ")" 82 | 83 | -- | Checks that all the arguments to the ESum are unary values 84 | allUnaries :: Bool -> [SumTypeConstructor] -> Maybe [(String, String)] 85 | allUnaries False = const Nothing 86 | allUnaries True = mapM isUnary 87 | where 88 | isUnary (STC o c (Anonymous args)) = if null args then Just (o,c) else Nothing 89 | isUnary _ = Nothing 90 | 91 | -- | Compile a JSON parser for an Elm type definition 92 | jsonParserForDef :: ETypeDef -> String 93 | jsonParserForDef etd = 94 | case etd of 95 | ETypePrimAlias (EPrimAlias name ty) -> unlines 96 | [ decoderType name 97 | , makeName name ++ " =" 98 | , " " ++ jsonParserForType ty 99 | ] 100 | ETypeAlias (EAlias name fields _ newtyping unwrap) -> unlines 101 | ( decoderType name 102 | : (makeName name ++ " =") 103 | : parseRecords (if newtyping then Just name else Nothing) unwrap fields 104 | ) 105 | ETypeSum (ESum name opts (SumEncoding' encodingType) _ unarystring) -> 106 | decoderType name ++ "\n" ++ 107 | makeName name ++ " =" ++ 108 | case allUnaries unarystring opts of 109 | Just names -> " " ++ deriveUnaries names 110 | Nothing -> "\n" ++ encodingDictionary opts ++ isObjectSet ++ "\n" ++ declLine opts ++ "\n" 111 | where 112 | tab n s = replicate n ' ' ++ s 113 | typename = et_name name 114 | declLine [_] = "" 115 | declLine _ = " in " ++ case encodingType of 116 | ObjectWithSingleField -> unwords [ "decodeSumObjectWithSingleField ", show typename, dictName] 117 | TwoElemArray -> unwords [ "decodeSumTwoElemArray ", show typename, dictName ] 118 | TaggedObject tg el -> unwords [ "decodeSumTaggedObject", show typename, show tg, show el, dictName, isObjectSetName ] 119 | UntaggedValue -> "Json.Decode.oneOf (Dict.values " ++ dictName ++ ")" 120 | dictName = "jsonDecDict" ++ typename 121 | isObjectSetName = "jsonDecObjectSet" ++ typename 122 | deriveUnaries strs = unlines 123 | [ "" 124 | , " let " ++ dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\(o, s) -> "(" ++ show s ++ ", " ++ o ++ ")") strs ) ++ "]" 125 | , " in decodeSumUnaries " ++ show typename ++ " " ++ dictName 126 | ] 127 | encodingDictionary [STC cname _ args] = " " ++ mkDecoder cname args 128 | encodingDictionary os = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry os) ++ "\n" ++ tab 12 "]" 129 | isObjectSet = case encodingType of 130 | TaggedObject _ _ 131 | | length opts > 1 -> 132 | "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " objectSet ++ "]") 133 | where objectSet = 134 | (map (show . _stcName) $ filter (isNamed . _stcFields) opts) ++ 135 | -- if field is empty, it do not have content, so add to objectSet. 136 | (map (show . _stcName) $ filter (isEmpty . _stcFields) opts) 137 | _ -> "" 138 | dictEntry (STC cname oname args) = "(" ++ show oname ++ ", " ++ mkDecoder cname args ++ ")" 139 | mkDecoder cname (Named args) = lazy $ "Json.Decode.map " 140 | ++ cname 141 | ++ " (" 142 | ++ unwords (parseRecords Nothing False args) 143 | ++ ")" 144 | 145 | mkDecoder cname (Anonymous args) = lazy $ unwords ( decodeFunction 146 | : cname 147 | : zipWith (\t' i -> "(" ++ jsonParserForIndexedType t' i ++ ")") args [0..] 148 | ) 149 | where decodeFunction = case length args of 150 | 0 -> "Json.Decode.succeed" 151 | 1 -> "Json.Decode.map" 152 | n -> "Json.Decode.map" ++ show n 153 | jsonParserForIndexedType :: EType -> Int -> String 154 | jsonParserForIndexedType t' i | length args <= 1 = jsonParserForType t' 155 | | otherwise = "Json.Decode.index " ++ show i ++ " (" ++ jsonParserForType t' ++ ")" 156 | where 157 | funcname name = "jsonDec" ++ et_name name 158 | prependTypes str = map (\tv -> str ++ tv_name tv) . et_args 159 | decoderType name = funcname name ++ " : " ++ intercalate " -> " (prependTypes "Json.Decode.Decoder " name ++ [decoderTypeEnd name]) 160 | decoderTypeEnd name = unwords ("Json.Decode.Decoder" : "(" : et_name name : map tv_name (et_args name) ++ [")"]) 161 | makeName name = unwords (funcname name : prependTypes "localDecoder_" name) 162 | lazy decoder = "Json.Decode.lazy (\\_ -> " ++ decoder ++ ")" 163 | 164 | {-| Compile a JSON serializer for an Elm type. 165 | 166 | The 'omitNothingFields' option is currently not implemented! 167 | -} 168 | jsonSerForType :: EType -> String 169 | jsonSerForType = jsonSerForType' False [1..] 170 | 171 | jsonSerForType' :: Bool -> [Int] -> EType -> String 172 | jsonSerForType' omitnull ns ty = 173 | case ty of 174 | ETyVar (ETVar v) -> "localEncoder_" ++ v 175 | ETyCon (ETCon "Int") -> "Json.Encode.int" 176 | ETyCon (ETCon "Float") -> "Json.Encode.float" 177 | ETyCon (ETCon "String") -> "Json.Encode.string" 178 | ETyCon (ETCon "Bool") -> "Json.Encode.bool" 179 | ETyCon (ETCon c) -> "jsonEnc" ++ c 180 | ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list " ++ jsonSerForType' omitnull ns t' ++ ")" 181 | ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull 182 | then jsonSerForType' omitnull ns t' 183 | else "(maybeEncode (" ++ jsonSerForType' omitnull ns t' ++ "))" 184 | ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType' omitnull ns t' ++ ")" 185 | ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType' omitnull ns value ++ "))" 186 | ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType' omitnull ns key ++ ") (" ++ jsonSerForType' omitnull ns value ++ "))" 187 | _ -> 188 | case unpackTupleType ty of 189 | [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty 190 | [x] -> 191 | case unpackToplevelConstr x of 192 | (y : ys) -> 193 | "(" ++ jsonSerForType' omitnull ns y ++ " " 194 | ++ unwords (map (\t' -> "(" ++ jsonSerForType' omitnull ns t' ++ ")") ys) 195 | ++ ")" 196 | _ -> error $ "Do suitable json serialiser found for " ++ show ty 197 | xs -> 198 | let (ns', rest) = splitAt (length xs) ns 199 | tupleArgsV = zip xs ns' 200 | tupleArgs = 201 | intercalate "," $ map (\(_, v) -> "t" ++ show v) tupleArgsV 202 | in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType' omitnull rest t' ++ ") t" ++ show idx) tupleArgsV) ++ "])" 203 | 204 | 205 | -- | Compile a JSON serializer for an Elm type definition 206 | jsonSerForDef :: ETypeDef -> String 207 | jsonSerForDef etd = 208 | case etd of 209 | ETypePrimAlias (EPrimAlias name ty) -> 210 | makeName name False ++ " = " ++ jsonSerForType ty ++ " val\n" 211 | ETypeAlias (EAlias name [(fldName, fldType)] _ newtyping True) -> 212 | makeName name newtyping ++ " =\n " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName 213 | ETypeAlias (EAlias name fields _ newtyping _) -> 214 | makeName name newtyping ++ " =\n Json.Encode.object\n [" 215 | ++ intercalate "\n ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName ++ ")") fields) 216 | ++ "\n ]\n" 217 | ETypeSum (ESum name opts (SumEncoding' se) _ unarystring) -> 218 | case allUnaries unarystring opts of 219 | Nothing -> defaultEncoding opts 220 | Just strs -> unaryEncoding strs 221 | where 222 | encodeFunction = case se of 223 | ObjectWithSingleField -> "encodeSumObjectWithSingleField" 224 | TwoElemArray -> "encodeSumTwoElementArray" 225 | TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c] 226 | UntaggedValue -> "encodeSumUntagged" 227 | defaultEncoding [STC _ oname (Anonymous args)] = unlines 228 | [ makeType name 229 | , fname name ++ " " 230 | ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) 231 | ++ "(" ++ cap oname ++ " " ++ argList args ++ ") =" 232 | , " " ++ mkEncodeList args 233 | ] 234 | defaultEncoding os = unlines ( 235 | ( makeName name False ++ " =") 236 | : " let keyval v = case v of" 237 | : map ((replicate 12 ' ' ++) . mkcase) os 238 | ++ [ " " ++ unwords ["in", encodeFunction, "keyval", "val"] ] 239 | ) 240 | unaryEncoding names = unlines ( 241 | [ makeName name False ++ " =" 242 | , " case val of" 243 | ] ++ map (\(o, n) -> replicate 8 ' ' ++ o ++ " -> Json.Encode.string " ++ show n) names 244 | ) 245 | mkcase :: SumTypeConstructor -> String 246 | mkcase (STC cname oname (Anonymous args)) = replicate 8 ' ' ++ cap cname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", encodeValue (" ++ mkEncodeList args ++ "))" 247 | mkcase (STC cname oname (Named args)) = replicate 8 ' ' ++ cap cname ++ " vs -> (" ++ show oname ++ ", " ++ mkEncodeObject args ++ ")" 248 | argList a = unwords $ map (\i -> "v" ++ show i ) [1 .. length a] 249 | numargs :: (a -> String) -> [a] -> String 250 | numargs f = intercalate ", " . zipWith (\n a -> f a ++ " v" ++ show n) ([1..] :: [Int]) 251 | mkEncodeObject args = "encodeObject [" ++ intercalate ", " (map (\(n,t) -> "(" ++ show n ++ ", " ++ jsonSerForType t ++ " vs." ++ fixReserved n ++ ")") args) ++ "]" 252 | mkEncodeList [arg] = jsonSerForType arg ++ " v1" 253 | mkEncodeList args = "Json.Encode.list identity [" ++ numargs jsonSerForType args ++ "]" 254 | where 255 | fname name = "jsonEnc" ++ et_name name 256 | makeType name = fname name ++ " : " ++ intercalate " -> " (map (mkLocalEncoder . tv_name) (et_args name) ++ [unwords (et_name name : map tv_name (et_args name)) , "Value"]) 257 | mkLocalEncoder n = "(" ++ n ++ " -> Value)" 258 | makeName name newtyping = 259 | makeType name ++ "\n" 260 | ++ fname name ++ " " 261 | ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) 262 | ++ if newtyping 263 | then " (" ++ et_name name ++ " val)" 264 | else " val" 265 | 266 | -- | Serialize a type like 'type Color = Red | Green | Blue' in a function like 267 | -- 268 | -- > stringEncColor : Color -> String 269 | -- > stringEncColor x = 270 | -- > case x of 271 | -- > Red -> "red" 272 | -- > ... 273 | -- 274 | -- This is mainly useful for types which are used as part of query parameters and url captures. 275 | stringSerForSimpleAdt :: ETypeDef -> String 276 | stringSerForSimpleAdt etd = 277 | case etd of 278 | ETypeSum (ESum name opts (SumEncoding' _se) _ _unarystring) -> 279 | defaultEncoding opts 280 | where 281 | defaultEncoding os = 282 | unlines 283 | ((makeName name False ++ " =") : " case val of" : map mkcase os) 284 | mkcase :: SumTypeConstructor -> String 285 | mkcase (STC cname oname (Anonymous args)) = 286 | replicate 8 ' ' 287 | ++ cap cname 288 | ++ " " 289 | ++ argList args 290 | ++ " -> " 291 | ++ show oname 292 | mkcase _ = 293 | error "stringSerForSimpleAdt.mkcase: Expecting an Anonymous case" 294 | argList a = unwords $ map (\i -> "v" ++ show i) [1 .. length a] 295 | _ -> error "stringSerForSimpleAdt only works with ETypeSum" 296 | where 297 | fname name = "stringEnc" ++ et_name name 298 | makeType name = 299 | fname name 300 | ++ " : " 301 | ++ intercalate 302 | " -> " 303 | ([unwords (et_name name : map tv_name (et_args name))] ++ ["String"]) 304 | makeName name newtyping = 305 | makeType name 306 | ++ "\n" 307 | ++ fname name 308 | ++ " " 309 | ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) 310 | ++ if newtyping 311 | then " (" ++ et_name name ++ " val)" 312 | else " val" 313 | 314 | -- | Parse a String into a maybe-value for simple ADT types. See 'stringSerForSimpleAdt' for motivation 315 | stringParserForSimpleAdt :: ETypeDef -> String 316 | stringParserForSimpleAdt etd = 317 | case etd of 318 | ETypeSum (ESum name opts (SumEncoding' _encodingType) _ _unarystring) -> 319 | decoderType name 320 | ++ "\n" 321 | ++ makeName name 322 | ++ " s =\n" 323 | ++ encodingDictionary opts 324 | ++ "\n" 325 | where 326 | tab n s = replicate n ' ' ++ s 327 | encodingDictionary [STC cname _ args] = 328 | " " ++ mkDecoder cname args 329 | encodingDictionary os = 330 | " case s of\n" 331 | ++ tab 8 "" 332 | ++ intercalate ("\n" ++ replicate 8 ' ') (map dictEntry os) 333 | ++ "\n" 334 | ++ tab 8 "_ -> Nothing" 335 | dictEntry (STC cname oname _args) = 336 | show oname ++ " -> Just " ++ cname 337 | mkDecoder _cname _ = error "impossible!" 338 | _ -> error "impossible" 339 | where 340 | funcname name = "stringDec" ++ et_name name 341 | prependTypes str = map (\tv -> str ++ tv_name tv) . et_args 342 | decoderType name = 343 | funcname name 344 | ++ " : " 345 | ++ intercalate " -> " (["String"] ++ [decoderTypeEnd name]) 346 | decoderTypeEnd name = 347 | unwords ("Maybe" : et_name name : map tv_name (et_args name)) 348 | makeName name = unwords (funcname name : prependTypes "localDecoder_" name) 349 | -------------------------------------------------------------------------------- /src/Elm/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-| 4 | Functions in this module are used to generate Elm modules. Note that the generated modules depend on the @bartavelle/json-helpers@ package. 5 | 6 | -} 7 | module Elm.Module where 8 | 9 | import Control.Arrow (second) 10 | import Data.List 11 | import Data.Proxy 12 | 13 | import Elm.Json 14 | import Elm.TyRender 15 | import Elm.TyRep 16 | import Elm.Versions 17 | 18 | -- | Existential quantification wrapper for lists of type definitions 19 | data DefineElm 20 | = forall a. IsElmDefinition a => DefineElm (Proxy a) 21 | 22 | -- | The module header line for this version of Elm 23 | moduleHeader :: ElmVersion 24 | -> String 25 | -> String 26 | moduleHeader _ moduleName = "module " ++ moduleName ++ " exposing(..)" 27 | 28 | -- | Creates an Elm module for the given version. This will use the default 29 | -- type conversion rules (to -- convert @Vector@ to @List@, @HashMap a b@ 30 | -- to @List (a,b)@, etc.). 31 | makeElmModuleWithVersion :: ElmVersion 32 | -> String -- ^ Module name 33 | -> [DefineElm] -- ^ List of definitions to be included in the module 34 | -> String 35 | makeElmModuleWithVersion elmVersion moduleName defs = unlines 36 | [ moduleHeader elmVersion moduleName 37 | , "" 38 | , "import Json.Decode" 39 | , "import Json.Encode exposing (Value)" 40 | , "-- The following module comes from bartavelle/json-helpers" 41 | , "import Json.Helpers exposing (..)" 42 | , "import Dict exposing (Dict)" 43 | , "import Set exposing (Set)" 44 | , "" 45 | , "" 46 | ] ++ makeModuleContent defs 47 | 48 | -- | Creates an Elm module. This will use the default type conversion rules (to 49 | -- convert @Vector@ to @List@, @HashMap a b@ to @List (a,b)@, etc.). 50 | -- 51 | -- default to 0.19 52 | makeElmModule :: String -- ^ Module name 53 | -> [DefineElm] -- ^ List of definitions to be included in the module 54 | -> String 55 | makeElmModule = makeElmModuleWithVersion Elm0p19 56 | 57 | -- | Generates the content of a module. You will be responsible for 58 | -- including the required Elm headers. This uses the default type 59 | -- conversion rules. 60 | makeModuleContent :: [DefineElm] -> String 61 | makeModuleContent = makeModuleContentWithAlterations defaultAlterations 62 | 63 | -- | Generates the content of a module, using custom type conversion rules. 64 | makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String 65 | makeModuleContentWithAlterations alt = intercalate "\n\n" . map mkDef 66 | where 67 | mkDef (DefineElm proxy) = 68 | let def = alt (compileElmDef proxy) 69 | in renderElm def ++ "\n" ++ jsonParserForDef def ++ "\n" ++ jsonSerForDef def ++ "\n" 70 | 71 | {-| A helper function that will recursively traverse type definitions and let you convert types. 72 | 73 | > myAlteration : ETypeDef -> ETypeDef 74 | > myAlteration = recAlterType $ \t -> case t of 75 | > ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int") 76 | > ETyCon (ETCon "Text") -> ETyCon (ETCon "String") 77 | > _ -> t 78 | 79 | -} 80 | recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef 81 | recAlterType f td = case td of 82 | ETypeAlias a -> ETypeAlias (a { ea_fields = map (second f') (ea_fields a) }) 83 | ETypePrimAlias (EPrimAlias n t) -> ETypePrimAlias (EPrimAlias n (f' t)) 84 | ETypeSum s -> ETypeSum (s { es_constructors = map alterTypes (es_constructors s) }) 85 | where 86 | alterTypes :: SumTypeConstructor -> SumTypeConstructor 87 | alterTypes (STC cn dn s) = STC cn dn $ case s of 88 | Anonymous flds -> Anonymous (map f' flds) 89 | Named flds -> Named (map (second f') flds) 90 | f' (ETyApp a b) = f (ETyApp (f' a) (f' b)) 91 | f' x = f x 92 | 93 | -- | Given a list of type names, will @newtype@ all the matching type 94 | -- definitions. 95 | newtypeAliases :: [String] -> ETypeDef -> ETypeDef 96 | newtypeAliases nts (ETypeAlias e) = ETypeAlias $ if et_name (ea_name e) `elem` nts 97 | then e { ea_newtype = True } 98 | else e 99 | newtypeAliases _ x = x 100 | 101 | {-| A default set of type conversion rules: 102 | 103 | * @HashSet a@, @Set a@ -> if @a@ is comparable, then @Set a@, else @List a@ 104 | * @HashMap String v@, @Map String v@ -> @Dict String v@ 105 | * @HashMap k v@, @Map k v@ -> @List (k, v)@ 106 | * @Integer@ -> @Int@ 107 | * @Text@ -> @String@ 108 | * @Vector@ -> @List@ 109 | * @Double@ -> @Float@ 110 | * @Tagged t v@ -> @v@ 111 | -} 112 | defaultAlterations :: ETypeDef -> ETypeDef 113 | defaultAlterations = recAlterType defaultTypeAlterations 114 | 115 | defaultTypeAlterations :: EType -> EType 116 | defaultTypeAlterations t = case t of 117 | ETyApp (ETyCon (ETCon "HashSet")) s -> checkSet $ defaultTypeAlterations s 118 | ETyApp (ETyCon (ETCon "Set")) s -> checkSet $ defaultTypeAlterations s 119 | ETyApp (ETyApp (ETyCon (ETCon "HashMap")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) 120 | ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) 121 | ETyApp (ETyCon (ETCon "IntMap")) v -> checkMap int (defaultTypeAlterations v) 122 | ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) 123 | ETyApp (ETyApp (ETyCon (ETCon "Tagged")) _) v -> defaultTypeAlterations v 124 | ETyApp x y -> ETyApp (defaultTypeAlterations x) (defaultTypeAlterations y) 125 | ETyCon (ETCon "Integer") -> int 126 | ETyCon (ETCon "Natural") -> int 127 | ETyCon (ETCon "Int32") -> int 128 | ETyCon (ETCon "Int64") -> int 129 | ETyCon (ETCon "Text") -> tc "String" 130 | ETyCon (ETCon "Vector") -> tc "List" 131 | ETyCon (ETCon "Double") -> tc "Float" 132 | ETyCon (ETCon "UTCTime") -> tc "Posix" 133 | _ -> t 134 | where 135 | int = tc "Int" 136 | isComparable (ETyCon (ETCon n)) = n `elem` ["String", "Int", "Float", "Posix", "Char"] 137 | isComparable _ = False -- TODO Lists and Tuples of comparable types 138 | tc = ETyCon . ETCon 139 | checkMap k v | isComparable k = ETyApp (ETyApp (tc "Dict") k) v 140 | | otherwise = ETyApp (tc "List") (ETyApp (ETyApp (ETyTuple 2) k) v) 141 | checkSet s | isComparable s = ETyApp (tc "Set") s 142 | | otherwise = ETyApp (tc "List") s 143 | -------------------------------------------------------------------------------- /src/Elm/TyRender.hs: -------------------------------------------------------------------------------- 1 | {-| This module should not usually be imported. -} 2 | module Elm.TyRender where 3 | 4 | import Elm.TyRep 5 | import Elm.Utils 6 | 7 | import Data.List 8 | 9 | class ElmRenderable a where 10 | renderElm :: a -> String 11 | 12 | instance ElmRenderable ETypeDef where 13 | renderElm td = 14 | case td of 15 | ETypeAlias alias -> renderElm alias 16 | ETypeSum s -> renderElm s 17 | ETypePrimAlias pa -> renderElm pa 18 | 19 | instance ElmRenderable EType where 20 | renderElm ty = 21 | case unpackTupleType ty of 22 | [t] -> renderSingleTy t 23 | xs -> "(" ++ intercalate ", " (map renderElm xs) ++ ")" 24 | where 25 | renderApp (ETyApp l r) = renderApp l ++ " " ++ renderElm r 26 | renderApp x = renderElm x 27 | renderSingleTy typ = 28 | case typ of 29 | ETyVar v -> renderElm v 30 | ETyCon c -> renderElm c 31 | ETyTuple _ -> error "Library Bug: This should never happen!" 32 | ETyApp l r -> "(" ++ renderApp l ++ " " ++ renderElm r ++ ")" 33 | 34 | instance ElmRenderable ETCon where 35 | renderElm = tc_name 36 | 37 | instance ElmRenderable ETVar where 38 | renderElm = tv_name 39 | 40 | instance ElmRenderable ETypeName where 41 | renderElm tyName = 42 | et_name tyName ++ " " ++ unwords (map renderElm $ et_args tyName) 43 | 44 | instance ElmRenderable EAlias where 45 | renderElm alias = (if ea_newtype alias then withnewtype else nonewtype) ++ body 46 | where 47 | withnewtype = "type " ++ renderElm (ea_name alias) ++ " = " ++ et_name (ea_name alias) 48 | nonewtype = "type alias " ++ renderElm (ea_name alias) ++ " =" 49 | body = "\n { " 50 | ++ intercalate "\n , " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) (ea_fields alias)) 51 | ++ "\n }\n" 52 | 53 | instance ElmRenderable ESum where 54 | renderElm s = 55 | "type " ++ renderElm (es_name s) ++ " =\n " 56 | ++ intercalate "\n | " (map mkOpt (es_constructors s)) 57 | ++ "\n" 58 | where 59 | mkOpt (STC name _ (Named types)) = cap name ++ " {" ++ intercalate ", " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) types) ++ "}" 60 | mkOpt (STC name _ (Anonymous types)) = 61 | cap name ++ " " ++ unwords (map renderElm types) 62 | 63 | instance ElmRenderable EPrimAlias where 64 | renderElm pa = 65 | "type alias " ++ renderElm (epa_name pa) ++ " = " ++ renderElm (epa_type pa) ++ "\n" 66 | -------------------------------------------------------------------------------- /src/Elm/TyRep.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines how the derived Haskell data types are represented. 2 | - It is useful for writing type conversion rules. 3 | -} 4 | module Elm.TyRep where 5 | 6 | import qualified Data.Char as Char 7 | import Data.List 8 | import Data.Proxy 9 | import Data.Typeable (TyCon, TypeRep, Typeable, splitTyConApp, 10 | tyConName, typeRep, typeRepTyCon) 11 | 12 | import Data.Aeson.Types (SumEncoding (..)) 13 | import Data.Maybe (fromMaybe) 14 | 15 | -- | Type definition, including constructors. 16 | data ETypeDef 17 | = ETypeAlias EAlias 18 | | ETypePrimAlias EPrimAlias 19 | | ETypeSum ESum 20 | deriving (Show, Eq) 21 | 22 | -- | Type construction : type variables, type constructors, tuples and type 23 | -- application. 24 | data EType 25 | = ETyVar ETVar 26 | | ETyCon ETCon 27 | | ETyApp EType EType 28 | | ETyTuple Int 29 | deriving (Show, Eq, Ord) 30 | 31 | {-| Type constructor: 32 | 33 | > ETCon "Int" 34 | -} 35 | newtype ETCon 36 | = ETCon 37 | { tc_name :: String 38 | } deriving (Show, Eq, Ord) 39 | 40 | {-| Type variable: 41 | 42 | > ETVar "a" 43 | -} 44 | newtype ETVar 45 | = ETVar 46 | { tv_name :: String 47 | } deriving (Show, Eq, Ord) 48 | 49 | 50 | {-| Type name: 51 | 52 | > ETypeName "Map" [ETVar "k", ETVar "v"] 53 | -} 54 | data ETypeName 55 | = ETypeName 56 | { et_name :: String 57 | , et_args :: [ETVar] 58 | } deriving (Show, Eq, Ord) 59 | 60 | data EPrimAlias 61 | = EPrimAlias 62 | { epa_name :: ETypeName 63 | , epa_type :: EType 64 | } deriving (Show, Eq, Ord) 65 | 66 | data EAlias 67 | = EAlias 68 | { ea_name :: ETypeName 69 | , ea_fields :: [(String, EType)] 70 | , ea_omit_null :: Bool 71 | , ea_newtype :: Bool 72 | , ea_unwrap_unary :: Bool 73 | } deriving (Show, Eq, Ord) 74 | 75 | data SumTypeFields 76 | = Anonymous [EType] 77 | | Named [(String, EType)] 78 | deriving (Show, Eq, Ord) 79 | 80 | isNamed :: SumTypeFields -> Bool 81 | isNamed s = 82 | case s of 83 | Named _ -> True 84 | _ -> False 85 | 86 | isEmpty :: SumTypeFields -> Bool 87 | isEmpty (Anonymous []) = True 88 | isEmpty (Named []) = True 89 | isEmpty _ = False 90 | 91 | data SumTypeConstructor 92 | = STC 93 | { _stcName :: String 94 | , _stcEncoded :: String 95 | , _stcFields :: SumTypeFields 96 | } deriving (Show, Eq, Ord) 97 | 98 | data ESum 99 | = ESum 100 | { es_name :: ETypeName 101 | , es_constructors :: [SumTypeConstructor] 102 | , es_type :: SumEncoding' 103 | , es_omit_null :: Bool 104 | , es_unary_strings :: Bool 105 | } deriving (Show, Eq, Ord) 106 | 107 | -- | Transforms tuple types in a list of types. Otherwise returns 108 | -- a singleton list with the original type. 109 | unpackTupleType :: EType -> [EType] 110 | unpackTupleType et = fromMaybe [et] (extract et) 111 | where 112 | extract :: EType -> Maybe [EType] 113 | extract ty = case ty of 114 | ETyTuple 0 -> return [] 115 | ETyApp (ETyTuple _) t -> return [t] 116 | ETyApp app@(ETyApp _ _) t -> fmap (++ [t]) (extract app) 117 | _ -> Nothing 118 | 119 | unpackToplevelConstr :: EType -> [EType] 120 | unpackToplevelConstr t = 121 | reverse $ 122 | flip unfoldr (Just t) $ \mT -> 123 | case mT of 124 | Nothing -> Nothing 125 | Just t' -> 126 | case t' of 127 | ETyApp l r -> 128 | Just (r, Just l) 129 | _ -> 130 | Just (t', Nothing) 131 | 132 | class IsElmDefinition a where 133 | compileElmDef :: Proxy a -> ETypeDef 134 | 135 | newtype SumEncoding' = SumEncoding' SumEncoding 136 | 137 | instance Show SumEncoding' where 138 | show (SumEncoding' se) = case se of 139 | TaggedObject n f -> "TaggedObject " ++ show n ++ " " ++ show f 140 | ObjectWithSingleField -> "ObjectWithSingleField" 141 | TwoElemArray -> "TwoElemArray" 142 | UntaggedValue -> "UntaggedValue" 143 | 144 | instance Eq SumEncoding' where 145 | SumEncoding' a == SumEncoding' b = case (a,b) of 146 | (TaggedObject a1 b1, TaggedObject a2 b2) -> a1 == a2 && b1 == b2 147 | (ObjectWithSingleField, ObjectWithSingleField) -> True 148 | (TwoElemArray, TwoElemArray) -> True 149 | (UntaggedValue, UntaggedValue) -> True 150 | _ -> False 151 | 152 | instance Ord SumEncoding' where 153 | compare (SumEncoding' a) (SumEncoding' b) = 154 | case (a,b) of 155 | (TaggedObject a1 b1, TaggedObject a2 b2) -> compare a1 a2 <> compare b1 b2 156 | (ObjectWithSingleField, ObjectWithSingleField) -> EQ 157 | (TwoElemArray, TwoElemArray) -> EQ 158 | (UntaggedValue, UntaggedValue) -> EQ 159 | (TaggedObject _ _, _) -> LT 160 | (_, TaggedObject _ _) -> GT 161 | (ObjectWithSingleField, _) -> LT 162 | (_, ObjectWithSingleField) -> GT 163 | (UntaggedValue, _) -> LT 164 | (_, UntaggedValue) -> GT 165 | 166 | defSumEncoding :: SumEncoding' 167 | defSumEncoding = SumEncoding' ObjectWithSingleField 168 | 169 | -- | Get an @elm-bridge@ type representation for a Haskell type. 170 | -- This can be used to render the type declaration via 171 | -- 'Elm.TyRender.ElmRenderable' or the the JSON serializer/parser names via 172 | -- 'Elm.Json.jsonSerForType' and 'Elm.Json.jsonParserForType'. 173 | toElmType :: (Typeable a) => Proxy a -> EType 174 | toElmType ty = toElmType' $ typeRep ty 175 | where 176 | toElmType' :: TypeRep -> EType 177 | toElmType' rep 178 | -- String (A list of Char) 179 | | con == typeRepTyCon (typeRep (Proxy :: Proxy [])) && 180 | args == [typeRep (Proxy :: Proxy Char)] = ETyCon (ETCon "String") 181 | -- List is special because the constructor name is [] in Haskell and List in elm 182 | | con == typeRepTyCon (typeRep (Proxy :: Proxy [])) = ETyApp (ETyCon $ ETCon "List") (toElmType' (head args)) 183 | -- The unit type '()' is a 0-ary tuple. 184 | | isTuple $ tyConName con = foldl ETyApp (ETyTuple $ length args) $ map toElmType' args 185 | | otherwise = typeApplication con args 186 | where 187 | (con, args) = splitTyConApp rep 188 | 189 | isTuple :: String -> Bool 190 | isTuple "Unit" = True 191 | isTuple ('T': 'u' : 'p': 'l' : 'e' : ds) = all Char.isDigit ds 192 | isTuple ('(':xs) = isTuple' $ reverse xs -- base <= 4.17 193 | where 194 | isTuple' :: String -> Bool 195 | isTuple' (')':xs') = all (== ',') xs' 196 | isTuple' _ = False 197 | isTuple _ = False 198 | 199 | typeApplication :: TyCon -> [TypeRep] -> EType 200 | typeApplication con args = typeApplication' (reverse args) 201 | where 202 | typeApplication' [] = ETyCon (ETCon $ tyConName con) 203 | typeApplication' [x] = 204 | ETyApp 205 | (ETyCon $ ETCon $ tyConName con) 206 | (toElmType' x) 207 | typeApplication' (x:xs) = 208 | ETyApp (typeApplication' xs) (toElmType' x) 209 | -------------------------------------------------------------------------------- /src/Elm/Utils.hs: -------------------------------------------------------------------------------- 1 | module Elm.Utils where 2 | 3 | import Data.Char (toUpper) 4 | 5 | cap :: String -> String 6 | cap "" = "" 7 | cap (x:xs) = toUpper x : xs 8 | 9 | fixReserved :: String -> String 10 | fixReserved x | x `elem` reservedWords = x ++ "_" 11 | | otherwise = x 12 | where 13 | reservedWords = [ "if", "then", "else" 14 | , "case", "of" 15 | , "let", "in" 16 | , "type" 17 | , "module", "where" 18 | , "import", "as", "hiding", "exposing" 19 | , "port", "export", "foreign" 20 | , "perform" 21 | , "deriving" 22 | ] 23 | -------------------------------------------------------------------------------- /src/Elm/Versions.hs: -------------------------------------------------------------------------------- 1 | {-| A type to represent versions of Elm for produced code to work against. 2 | 3 | This module only supports Elm 0.19.x !!! 4 | -} 5 | module Elm.Versions where 6 | 7 | data ElmVersion 8 | = Elm0p19 9 | 10 | -------------------------------------------------------------------------------- /test/Elm/DeriveSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Elm.DeriveSpec (spec) where 3 | 4 | import Elm.Derive 5 | import Elm.TyRep 6 | 7 | import Data.Proxy 8 | import Test.Hspec 9 | import Data.Char (toLower) 10 | 11 | data Foo 12 | = Foo 13 | { f_name :: String 14 | , f_blablub :: Int 15 | } deriving (Show, Eq) 16 | 17 | data Bar a 18 | = Bar 19 | { b_name :: a 20 | , b_blablub :: Int 21 | , b_tuple :: (Int, String) 22 | , b_list :: [Bool] 23 | } deriving (Show, Eq) 24 | 25 | data Change a = Change { _before :: a, _after :: a } 26 | 27 | data Baz a = Baz1 { _fOo :: Int, _qux :: a } 28 | | Baz2 { _bar :: Int, _sTr :: String } 29 | | Zob a 30 | 31 | data Qux a = Qux1 { _quxfoo :: Int, _quxqux :: a } 32 | | Qux2 { _quxbar :: Int, _quxstr :: String } 33 | 34 | data Test a = Test { _t1 :: Change Int 35 | , _t2 :: Change a 36 | } 37 | 38 | data SomeOpts a 39 | = Okay Int 40 | | NotOkay a 41 | 42 | data Simple 43 | = SimpleA 44 | | SimpleB 45 | 46 | deriveElmDef defaultOptions ''Foo 47 | deriveElmDef defaultOptions ''Bar 48 | deriveElmDef defaultOptions ''SomeOpts 49 | deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz 50 | deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Test 51 | deriveElmDef defaultOptions { fieldLabelModifier = drop 4 . map toLower, sumEncoding = TaggedObject "key" "value" } ''Qux 52 | deriveElmDef defaultOptions { constructorTagModifier = drop 6 . map toLower} ''Simple 53 | 54 | testElm :: ETypeDef 55 | testElm = ETypeAlias $ EAlias 56 | { ea_name = 57 | ETypeName 58 | { et_name = "Test" 59 | , et_args = [ETVar {tv_name = "a"}] 60 | } 61 | , ea_fields = 62 | [ ("t1",ETyApp (ETyCon (ETCon {tc_name = "Change"})) (ETyCon (ETCon {tc_name = "Int"}))) 63 | , ("t2",ETyApp (ETyCon (ETCon {tc_name = "Change"})) (ETyVar (ETVar {tv_name = "a"}))) 64 | ] 65 | , ea_omit_null = False 66 | , ea_newtype = False 67 | , ea_unwrap_unary = True 68 | } 69 | 70 | fooElm :: ETypeDef 71 | fooElm = 72 | ETypeAlias $ 73 | EAlias 74 | { ea_name = 75 | ETypeName 76 | { et_name = "Foo" 77 | , et_args = [] 78 | } 79 | , ea_fields = 80 | [("f_name",ETyCon (ETCon {tc_name = "String"})),("f_blablub",ETyCon (ETCon {tc_name = "Int"}))] 81 | , ea_omit_null = False 82 | , ea_newtype = False 83 | , ea_unwrap_unary = True 84 | } 85 | 86 | barElm :: ETypeDef 87 | barElm = 88 | ETypeAlias $ 89 | EAlias 90 | { ea_name = 91 | ETypeName 92 | { et_name = "Bar" 93 | , et_args = [ETVar {tv_name = "a"}] 94 | } 95 | , ea_fields = 96 | [ ("b_name",ETyVar (ETVar {tv_name = "a"})) 97 | , ("b_blablub",ETyCon (ETCon {tc_name = "Int"})) 98 | , ("b_tuple",ETyApp (ETyApp (ETyTuple 2) (ETyCon (ETCon {tc_name = "Int"}))) (ETyCon (ETCon {tc_name = "String"}))) 99 | , ("b_list",ETyApp (ETyCon (ETCon {tc_name = "List"})) (ETyCon (ETCon {tc_name = "Bool"}))) 100 | ] 101 | , ea_omit_null = False 102 | , ea_newtype = False 103 | , ea_unwrap_unary = True 104 | } 105 | 106 | bazElm :: ETypeDef 107 | bazElm = ETypeSum $ ESum 108 | { es_name = ETypeName {et_name = "Baz", et_args = [ETVar {tv_name = "a"}]} 109 | , es_constructors = 110 | [ STC "Baz1" "Baz1" (Named [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))]) 111 | , STC "Baz2" "Baz2" (Named [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))]) 112 | , STC "Zob" "Zob" (Anonymous [ETyVar (ETVar {tv_name = "a"})]) 113 | ] 114 | , es_type = SumEncoding' ObjectWithSingleField 115 | , es_omit_null = False 116 | , es_unary_strings = True 117 | } 118 | 119 | quxElm :: ETypeDef 120 | quxElm = ETypeSum $ ESum 121 | { es_name = ETypeName {et_name = "Qux", et_args = [ETVar {tv_name = "a"}]} 122 | , es_constructors = 123 | [ STC "Qux1" "Qux1" (Named [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))]) 124 | , STC "Qux2" "Qux2" (Named [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))]) 125 | ] 126 | , es_type = SumEncoding' $ TaggedObject "key" "value" 127 | , es_omit_null = False 128 | , es_unary_strings = True 129 | } 130 | 131 | someOptsElm :: ETypeDef 132 | someOptsElm = 133 | ETypeSum $ 134 | ESum 135 | { es_name = 136 | ETypeName 137 | { et_name = "SomeOpts" 138 | , et_args = [ETVar {tv_name = "a"}] 139 | } 140 | , es_constructors = 141 | [ STC "Okay" "Okay" (Anonymous [ETyCon (ETCon {tc_name = "Int"})]) 142 | , STC "NotOkay" "NotOkay" (Anonymous [ETyVar (ETVar {tv_name = "a"})]) 143 | ] 144 | , es_type = defSumEncoding 145 | , es_omit_null = False 146 | , es_unary_strings = True 147 | } 148 | 149 | simpleElm :: ETypeDef 150 | simpleElm = ETypeSum $ 151 | ESum 152 | { es_name = ETypeName {et_name = "Simple", et_args = []}, es_constructors = [STC "SimpleA" "a" (Anonymous []),STC "SimpleB" "b" (Anonymous [])] 153 | , es_type = SumEncoding' ObjectWithSingleField 154 | , es_omit_null = False 155 | , es_unary_strings = True 156 | } 157 | 158 | spec :: Spec 159 | spec = 160 | describe "deriveElmRep" $ 161 | it "should produce the correct types" $ 162 | do compileElmDef (Proxy :: Proxy Foo) `shouldBe` fooElm 163 | compileElmDef (Proxy :: Proxy (Bar a)) `shouldBe` barElm 164 | compileElmDef (Proxy :: Proxy (SomeOpts a)) `shouldBe` someOptsElm 165 | compileElmDef (Proxy :: Proxy (Baz a)) `shouldBe` bazElm 166 | compileElmDef (Proxy :: Proxy (Qux a)) `shouldBe` quxElm 167 | compileElmDef (Proxy :: Proxy (Test a)) `shouldBe` testElm 168 | compileElmDef (Proxy :: Proxy Simple) `shouldBe` simpleElm 169 | -------------------------------------------------------------------------------- /test/Elm/JsonSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Elm.JsonSpec (spec) where 3 | 4 | import Elm.Derive 5 | import Elm.Json 6 | import Elm.TyRender 7 | import Elm.TyRep 8 | 9 | import qualified Data.Aeson.TH as TH 10 | import Data.Aeson.Types (defaultTaggedObject) 11 | import Data.Char (toLower) 12 | import qualified Data.Map.Strict as M 13 | import Data.Proxy 14 | import Test.Hspec 15 | 16 | data Foo 17 | = Foo 18 | { f_name :: String 19 | , f_blablub :: Int 20 | } deriving (Show, Eq) 21 | 22 | data Bar a 23 | = Bar 24 | { b_name :: a 25 | , b_blablub :: Int 26 | , b_tuple :: (Int, String) 27 | , b_list :: [Bool] 28 | } deriving (Show, Eq) 29 | 30 | data SomeOpts a 31 | = Okay Int 32 | | NotOkay a 33 | 34 | data UnaryA = UnaryA1 | UnaryA2 35 | data UnaryB = UnaryB1 | UnaryB2 36 | 37 | data Change a = Change { _before :: a, _after :: a } 38 | 39 | data Baz a = Baz1 { _foo :: Int, _qux :: M.Map Int a } 40 | | Baz2 { _bar :: Maybe Int, _str :: String } 41 | | Testing (Baz a) 42 | 43 | data TestComp a = TestComp { _t1 :: Change Int 44 | , _t2 :: Change a 45 | } 46 | 47 | data DoneState = Done | NotDone deriving (Eq, Show) 48 | 49 | data Id = Id String deriving (Show, Eq) 50 | data EditDone = EditDone Id DoneState DoneState deriving (Show, Eq) 51 | 52 | newtype NTA = NTA Int 53 | newtype NTB = NTB { getNtb :: Int } 54 | newtype NTC = NTC Int 55 | newtype NTD = NTD { getNtd :: Int } 56 | 57 | newtype PhantomA a = PhantomA Int 58 | newtype PhantomB a = PhantomB { getPhantomB :: Int } 59 | newtype PhantomC a = PhantomC Int 60 | newtype PhantomD a = PhantomD { getPhantomD :: Int } 61 | 62 | $(deriveElmDef (defaultOptionsDropLower 2) ''Foo) 63 | $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) 64 | $(deriveElmDef (defaultOptionsDropLower 1) ''TestComp) 65 | $(deriveElmDef defaultOptions ''SomeOpts) 66 | $(deriveElmDef defaultOptions{ allNullaryToStringTag = False } ''UnaryA) 67 | $(deriveElmDef defaultOptions{ allNullaryToStringTag = True } ''UnaryB) 68 | $(deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz) 69 | $(deriveElmDef (defaultOptions { sumEncoding = defaultTaggedObject }) ''DoneState) 70 | $(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''Id) 71 | $(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''EditDone) 72 | $(deriveElmDef defaultOptions ''NTA) 73 | $(deriveElmDef defaultOptions ''NTB) 74 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTC) 75 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTD) 76 | $(deriveElmDef defaultOptions ''PhantomA) 77 | $(deriveElmDef defaultOptions ''PhantomB) 78 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC) 79 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD) 80 | 81 | fooSer :: String 82 | fooSer = "jsonEncFoo : Foo -> Value\njsonEncFoo val =\n Json.Encode.object\n [ (\"name\", Json.Encode.string val.name)\n , (\"blablub\", Json.Encode.int val.blablub)\n ]\n" 83 | 84 | fooParse :: String 85 | fooParse = unlines 86 | [ "jsonDecFoo : Json.Decode.Decoder ( Foo )" 87 | , "jsonDecFoo =" 88 | , " Json.Decode.succeed (\\pname pblablub -> {name = pname, blablub = pblablub})" 89 | , " |> required \"name\" (Json.Decode.string)" 90 | , " |> required \"blablub\" (Json.Decode.int)" 91 | ] 92 | 93 | barSer :: String 94 | barSer = unlines 95 | [ "jsonEncBar : (a -> Value) -> Bar a -> Value" 96 | , "jsonEncBar localEncoder_a val =" 97 | , " Json.Encode.object" 98 | , " [ (\"name\", localEncoder_a val.name)" 99 | , " , (\"blablub\", Json.Encode.int val.blablub)" 100 | , " , (\"tuple\", (\\(t1,t2) -> Json.Encode.list identity [(Json.Encode.int) t1,(Json.Encode.string) t2]) val.tuple)" 101 | , " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)" 102 | , " ]" 103 | ] 104 | 105 | bazSer :: String 106 | bazSer = unlines 107 | [ "jsonEncBaz : (a -> Value) -> Baz a -> Value" 108 | , "jsonEncBaz localEncoder_a val =" 109 | , " let keyval v = case v of" 110 | , " Baz1 vs -> (\"Baz1\", encodeObject [(\"foo\", Json.Encode.int vs.foo), (\"qux\", (jsonEncMap (Json.Encode.int) (localEncoder_a)) vs.qux)])" 111 | , " Baz2 vs -> (\"Baz2\", encodeObject [(\"bar\", (maybeEncode (Json.Encode.int)) vs.bar), (\"str\", Json.Encode.string vs.str)])" 112 | , " Testing v1 -> (\"Testing\", encodeValue ((jsonEncBaz (localEncoder_a)) v1))" 113 | , " in encodeSumObjectWithSingleField keyval val" 114 | ] 115 | 116 | barParse :: String 117 | barParse = unlines 118 | [ "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" 119 | , "jsonDecBar localDecoder_a =" 120 | , " Json.Decode.succeed (\\pname pblablub ptuple plist -> {name = pname, blablub = pblablub, tuple = ptuple, list = plist})" 121 | , " |> required \"name\" (localDecoder_a)" 122 | , " |> required \"blablub\" (Json.Decode.int)" 123 | , " |> required \"tuple\" (Json.Decode.map2 tuple2 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))" 124 | , " |> required \"list\" (Json.Decode.list (Json.Decode.bool))" 125 | ] 126 | 127 | bazParse :: String 128 | bazParse = unlines 129 | [ "jsonDecBaz : Json.Decode.Decoder a -> Json.Decode.Decoder ( Baz a )" 130 | , "jsonDecBaz localDecoder_a =" 131 | , " let jsonDecDictBaz = Dict.fromList" 132 | , " [ (\"Baz1\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz1 ( Json.Decode.succeed (\\pfoo pqux -> {foo = pfoo, qux = pqux}) |> required \"foo\" (Json.Decode.int) |> required \"qux\" (jsonDecMap (Json.Decode.int) (localDecoder_a)))))" 133 | , " , (\"Baz2\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz2 ( Json.Decode.succeed (\\pbar pstr -> {bar = pbar, str = pstr}) |> fnullable \"bar\" (Json.Decode.int) |> required \"str\" (Json.Decode.string))))" 134 | , " , (\"Testing\", Json.Decode.lazy (\\_ -> Json.Decode.map Testing (jsonDecBaz (localDecoder_a))))" 135 | , " ]" 136 | , " in decodeSumObjectWithSingleField \"Baz\" jsonDecDictBaz" 137 | ] 138 | 139 | someOptsParse :: String 140 | someOptsParse = unlines 141 | [ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )" 142 | , "jsonDecSomeOpts localDecoder_a =" 143 | , " let jsonDecDictSomeOpts = Dict.fromList" 144 | , " [ (\"Okay\", Json.Decode.lazy (\\_ -> Json.Decode.map Okay (Json.Decode.int)))" 145 | , " , (\"NotOkay\", Json.Decode.lazy (\\_ -> Json.Decode.map NotOkay (localDecoder_a)))" 146 | , " ]" 147 | , " in decodeSumObjectWithSingleField \"SomeOpts\" jsonDecDictSomeOpts" 148 | ] 149 | 150 | someOptsSer :: String 151 | someOptsSer = unlines 152 | [ "jsonEncSomeOpts : (a -> Value) -> SomeOpts a -> Value" 153 | , "jsonEncSomeOpts localEncoder_a val =" 154 | , " let keyval v = case v of" 155 | , " Okay v1 -> (\"Okay\", encodeValue (Json.Encode.int v1))" 156 | , " NotOkay v1 -> (\"NotOkay\", encodeValue (localEncoder_a v1))" 157 | , " in encodeSumObjectWithSingleField keyval val" 158 | ] 159 | 160 | test1Parse :: String 161 | test1Parse = unlines 162 | [ "jsonDecTestComp : Json.Decode.Decoder a -> Json.Decode.Decoder ( TestComp a )" 163 | , "jsonDecTestComp localDecoder_a =" 164 | , " Json.Decode.succeed (\\pt1 pt2 -> {t1 = pt1, t2 = pt2})" 165 | , " |> required \"t1\" (jsonDecChange (Json.Decode.int))" 166 | , " |> required \"t2\" (jsonDecChange (localDecoder_a))" 167 | ] 168 | 169 | unaryAParse :: String 170 | unaryAParse = unlines 171 | [ "jsonDecUnaryA : Json.Decode.Decoder ( UnaryA )" 172 | , "jsonDecUnaryA =" 173 | , " let jsonDecDictUnaryA = Dict.fromList" 174 | , " [ (\"UnaryA1\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA1))" 175 | , " , (\"UnaryA2\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA2))" 176 | , " ]" 177 | , " in decodeSumObjectWithSingleField \"UnaryA\" jsonDecDictUnaryA" 178 | ] 179 | 180 | unaryAStringParser :: String 181 | unaryAStringParser = unlines 182 | [ "stringDecUnaryA : String -> Maybe UnaryA" 183 | , "stringDecUnaryA s =" 184 | , " case s of" 185 | , " \"UnaryA1\" -> Just UnaryA1" 186 | , " \"UnaryA2\" -> Just UnaryA2" 187 | , " _ -> Nothing" 188 | ] 189 | 190 | unaryBParse :: String 191 | unaryBParse = unlines 192 | [ "jsonDecUnaryB : Json.Decode.Decoder ( UnaryB )" 193 | , "jsonDecUnaryB = " 194 | , " let jsonDecDictUnaryB = Dict.fromList [(\"UnaryB1\", UnaryB1), (\"UnaryB2\", UnaryB2)]" 195 | , " in decodeSumUnaries \"UnaryB\" jsonDecDictUnaryB" 196 | ] 197 | 198 | unaryASer :: String 199 | unaryASer = unlines 200 | [ "jsonEncUnaryA : UnaryA -> Value" 201 | , "jsonEncUnaryA val =" 202 | , " let keyval v = case v of" 203 | , " UnaryA1 -> (\"UnaryA1\", encodeValue (Json.Encode.list identity []))" 204 | , " UnaryA2 -> (\"UnaryA2\", encodeValue (Json.Encode.list identity []))" 205 | , " in encodeSumObjectWithSingleField keyval val" 206 | ] 207 | 208 | unaryAStringSer :: String 209 | unaryAStringSer = unlines 210 | [ "stringEncUnaryA : UnaryA -> String" 211 | , "stringEncUnaryA val =" 212 | , " case val of" 213 | , " UnaryA1 -> \"UnaryA1\"" 214 | , " UnaryA2 -> \"UnaryA2\"" 215 | ] 216 | 217 | unaryBSer :: String 218 | unaryBSer = unlines 219 | [ "jsonEncUnaryB : UnaryB -> Value" 220 | , "jsonEncUnaryB val =" 221 | , " case val of" 222 | , " UnaryB1 -> Json.Encode.string \"UnaryB1\"" 223 | , " UnaryB2 -> Json.Encode.string \"UnaryB2\"" 224 | ] 225 | 226 | doneParse :: String 227 | doneParse = unlines 228 | [ "jsonDecDoneState : Json.Decode.Decoder ( DoneState )" 229 | , "jsonDecDoneState = " 230 | , " let jsonDecDictDoneState = Dict.fromList [(\"Done\", Done), (\"NotDone\", NotDone)]" 231 | , " in decodeSumUnaries \"DoneState\" jsonDecDictDoneState" 232 | ] 233 | 234 | editDoneParse :: String 235 | editDoneParse = unlines 236 | [ "jsonDecEditDone : Json.Decode.Decoder ( EditDone )" 237 | , "jsonDecEditDone =" 238 | , " Json.Decode.lazy (\\_ -> Json.Decode.map3 EditDone (Json.Decode.index 0 (jsonDecId)) (Json.Decode.index 1 (jsonDecDoneState)) (Json.Decode.index 2 (jsonDecDoneState)))" 239 | , "" 240 | ] 241 | 242 | idParse :: String 243 | idParse = unlines 244 | [ "jsonDecId : Json.Decode.Decoder ( Id )" 245 | , "jsonDecId =" 246 | , " Json.Decode.lazy (\\_ -> Json.Decode.map Id (Json.Decode.string))" 247 | , "" 248 | ] 249 | 250 | ntaParse :: String 251 | ntaParse = unlines 252 | [ "jsonDecNTA : Json.Decode.Decoder ( NTA )" 253 | , "jsonDecNTA =" 254 | , " Json.Decode.int" 255 | ] 256 | 257 | ntbParse :: String 258 | ntbParse = unlines 259 | [ "jsonDecNTB : Json.Decode.Decoder ( NTB )" 260 | , "jsonDecNTB =" 261 | , " Json.Decode.int" 262 | ] 263 | 264 | ntcParse :: String 265 | ntcParse = unlines 266 | [ "jsonDecNTC : Json.Decode.Decoder ( NTC )" 267 | , "jsonDecNTC =" 268 | , " Json.Decode.int" 269 | ] 270 | 271 | ntdParse :: String 272 | ntdParse = unlines 273 | [ "jsonDecNTD : Json.Decode.Decoder ( NTD )" 274 | , "jsonDecNTD =" 275 | , " Json.Decode.succeed (\\pgetNtd -> (NTD {getNtd = pgetNtd}))" 276 | , " |> required \"getNtd\" (Json.Decode.int)" 277 | ] 278 | 279 | phantomAParse :: String 280 | phantomAParse = unlines 281 | [ "jsonDecPhantomA : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomA a )" 282 | , "jsonDecPhantomA localDecoder_a =" 283 | , " Json.Decode.int" 284 | ] 285 | phantomBParse :: String 286 | phantomBParse = unlines 287 | [ "jsonDecPhantomB : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomB a )" 288 | , "jsonDecPhantomB localDecoder_a =" 289 | , " Json.Decode.int" 290 | ] 291 | phantomCParse :: String 292 | phantomCParse = unlines 293 | [ "jsonDecPhantomC : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomC a )" 294 | , "jsonDecPhantomC localDecoder_a =" 295 | , " Json.Decode.int" 296 | ] 297 | phantomDParse :: String 298 | phantomDParse = unlines 299 | [ "jsonDecPhantomD : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomD a )" 300 | , "jsonDecPhantomD localDecoder_a =" 301 | , " Json.Decode.succeed (\\pgetPhantomD -> (PhantomD {getPhantomD = pgetPhantomD}))" 302 | , " |> required \"getPhantomD\" (Json.Decode.int)" 303 | ] 304 | 305 | spec :: Spec 306 | spec = 307 | describe "json serialisation" $ 308 | do let rFoo = compileElmDef (Proxy :: Proxy Foo) 309 | rBar = compileElmDef (Proxy :: Proxy (Bar a)) 310 | rBaz = compileElmDef (Proxy :: Proxy (Baz a)) 311 | rTest1 = compileElmDef (Proxy :: Proxy (TestComp a)) 312 | rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a)) 313 | rUnaryA = compileElmDef (Proxy :: Proxy UnaryA) 314 | rUnaryB = compileElmDef (Proxy :: Proxy UnaryB) 315 | rDoneState = compileElmDef (Proxy :: Proxy DoneState) 316 | rId = compileElmDef (Proxy :: Proxy Id) 317 | rEditDone = compileElmDef (Proxy :: Proxy EditDone) 318 | rNTA = compileElmDef (Proxy :: Proxy NTA) 319 | rNTB = compileElmDef (Proxy :: Proxy NTB) 320 | rNTC = compileElmDef (Proxy :: Proxy NTC) 321 | rNTD = compileElmDef (Proxy :: Proxy NTD) 322 | rPhantomA = compileElmDef (Proxy :: Proxy (PhantomA a)) 323 | rPhantomB = compileElmDef (Proxy :: Proxy (PhantomB a)) 324 | rPhantomC = compileElmDef (Proxy :: Proxy (PhantomC a)) 325 | rPhantomD = compileElmDef (Proxy :: Proxy (PhantomD a)) 326 | it "should produce the correct ser code" $ do 327 | jsonSerForDef rFoo `shouldBe` fooSer 328 | jsonSerForDef rBar `shouldBe` barSer 329 | jsonSerForDef rSomeOpts `shouldBe` someOptsSer 330 | jsonSerForDef rBaz `shouldBe` bazSer 331 | it "should produce the correct ser code for unary unions" $ do 332 | jsonSerForDef rUnaryA `shouldBe` unaryASer 333 | jsonSerForDef rUnaryB `shouldBe` unaryBSer 334 | it "should produce the correct stringSerForSimpleAdt code" $ do 335 | stringSerForSimpleAdt rUnaryA `shouldBe` unaryAStringSer 336 | it "should produce the correct stringParserForDef code" $ do 337 | stringParserForSimpleAdt rUnaryA `shouldBe` unaryAStringParser 338 | it "should produce the correct parse code for aliases" $ do 339 | jsonParserForDef rFoo `shouldBe` fooParse 340 | jsonParserForDef rBar `shouldBe` barParse 341 | it "should produce the correct parse code generic sum types" $ do 342 | jsonParserForDef rBaz `shouldBe` bazParse 343 | jsonParserForDef rSomeOpts `shouldBe` someOptsParse 344 | jsonParserForDef rTest1 `shouldBe` test1Parse 345 | it "should produce the correct parse code for unary unions" $ do 346 | jsonParserForDef rUnaryA `shouldBe` unaryAParse 347 | jsonParserForDef rUnaryB `shouldBe` unaryBParse 348 | it "should produce the correct parse code for issue #18" $ do 349 | jsonParserForDef rDoneState `shouldBe` doneParse 350 | jsonParserForDef rId `shouldBe` idParse 351 | jsonParserForDef rEditDone `shouldBe` editDoneParse 352 | it "should produce the correct parse code for newtypes with unwrapUnaryRecords=True" $ do 353 | jsonParserForDef rNTA `shouldBe` ntaParse 354 | jsonParserForDef rNTB `shouldBe` ntbParse 355 | it "should produce the correct parse code for newtypes with unwrapUnaryRecords=False" $ do 356 | jsonParserForDef rNTC `shouldBe` ntcParse 357 | jsonParserForDef rNTD `shouldBe` ntdParse 358 | it "should produce the correct parse code for phantom newtypes" $ do 359 | jsonParserForDef rPhantomA `shouldBe` phantomAParse 360 | jsonParserForDef rPhantomB `shouldBe` phantomBParse 361 | jsonParserForDef rPhantomC `shouldBe` phantomCParse 362 | jsonParserForDef rPhantomD `shouldBe` phantomDParse 363 | -------------------------------------------------------------------------------- /test/Elm/ModuleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Elm.ModuleSpec (spec) where 3 | 4 | import Elm.Derive 5 | import Elm.Module 6 | import Elm.Versions 7 | 8 | import Data.Map (Map) 9 | import Data.Proxy 10 | import Test.Hspec 11 | 12 | data Bar a 13 | = Bar 14 | { b_name :: a 15 | , b_blablub :: Int 16 | , b_tuple :: (Int, String) 17 | , b_list :: [Bool] 18 | , b_list_map :: [Map String Bool] 19 | } deriving (Show, Eq) 20 | 21 | data Qux a = Qux1 Int String 22 | | Qux2 { _qux2a :: Int, _qux2test :: a } 23 | deriving (Show, Eq) 24 | 25 | $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) 26 | $(deriveElmDef (defaultOptionsDropLower 5) ''Qux) 27 | 28 | moduleHeader' :: ElmVersion -> String -> String 29 | moduleHeader' Elm0p19 name = "module " ++ name ++ " exposing(..)" 30 | 31 | moduleCode :: ElmVersion -> String 32 | moduleCode elmVersion = unlines 33 | [ moduleHeader' elmVersion "Foo" 34 | , "" 35 | , "import Json.Decode" 36 | , "import Json.Encode exposing (Value)" 37 | , "-- The following module comes from bartavelle/json-helpers" 38 | , "import Json.Helpers exposing (..)" 39 | , "import Dict exposing (Dict)" 40 | , "import Set exposing (Set)" 41 | , "" 42 | , "" 43 | , "type alias Bar a =" 44 | , " { name: a" 45 | , " , blablub: Int" 46 | , " , tuple: (Int, String)" 47 | , " , list: (List Bool)" 48 | , " , list_map: (List (Dict String Bool))" 49 | , " }" 50 | , "" 51 | , "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" 52 | , "jsonDecBar localDecoder_a =" 53 | , " Json.Decode.succeed (\\pname pblablub ptuple plist plist_map -> {name = pname, blablub = pblablub, tuple = ptuple, list = plist, list_map = plist_map})" 54 | , " |> required \"name\" (localDecoder_a)" 55 | , " |> required \"blablub\" (Json.Decode.int)" 56 | , " |> required \"tuple\" (Json.Decode.map2 tuple2 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))" 57 | , " |> required \"list\" (Json.Decode.list (Json.Decode.bool))" 58 | , " |> required \"list_map\" (Json.Decode.list (Json.Decode.dict (Json.Decode.bool)))" 59 | , "" 60 | , "jsonEncBar : (a -> Value) -> Bar a -> Value" 61 | , "jsonEncBar localEncoder_a val =" 62 | , " Json.Encode.object" 63 | , " [ (\"name\", localEncoder_a val.name)" 64 | , " , (\"blablub\", Json.Encode.int val.blablub)" 65 | , " , (\"tuple\", (\\(t1,t2) -> Json.Encode.list identity [(Json.Encode.int) t1,(Json.Encode.string) t2]) val.tuple)" 66 | , " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)" 67 | , " , (\"list_map\", (Json.Encode.list (Json.Encode.dict identity (Json.Encode.bool))) val.list_map)" 68 | , " ]" 69 | , "" 70 | ] 71 | 72 | moduleCode' :: ElmVersion -> String 73 | moduleCode' elmVersion = unlines 74 | [ moduleHeader' elmVersion "Qux" 75 | , "" 76 | , "import Json.Decode" 77 | , "import Json.Encode exposing (Value)" 78 | , "-- The following module comes from bartavelle/json-helpers" 79 | , "import Json.Helpers exposing (..)" 80 | , "import Dict exposing (Dict)" 81 | , "import Set exposing (Set)" 82 | , "" 83 | , "" 84 | , "type Qux a =" 85 | , " Qux1 Int String" 86 | , " | Qux2 {a: Int, test: a}" 87 | , "" 88 | , "jsonDecQux : Json.Decode.Decoder a -> Json.Decode.Decoder ( Qux a )" 89 | , "jsonDecQux localDecoder_a =" 90 | , " let jsonDecDictQux = Dict.fromList" 91 | , " [ (\"Qux1\", Json.Decode.lazy (\\_ -> Json.Decode.map2 Qux1 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string))))" 92 | , " , (\"Qux2\", Json.Decode.lazy (\\_ -> Json.Decode.map Qux2 ( Json.Decode.succeed (\\pa ptest -> {a = pa, test = ptest}) |> required \"a\" (Json.Decode.int) |> required \"test\" (localDecoder_a))))" 93 | , " ]" 94 | , " in decodeSumObjectWithSingleField \"Qux\" jsonDecDictQux" 95 | , "" 96 | , "jsonEncQux : (a -> Value) -> Qux a -> Value" 97 | , "jsonEncQux localEncoder_a val =" 98 | , " let keyval v = case v of" 99 | , " Qux1 v1 v2 -> (\"Qux1\", encodeValue (Json.Encode.list identity [Json.Encode.int v1, Json.Encode.string v2]))" 100 | , " Qux2 vs -> (\"Qux2\", encodeObject [(\"a\", Json.Encode.int vs.a), (\"test\", localEncoder_a vs.test)])" 101 | , " in encodeSumObjectWithSingleField keyval val" 102 | , "" 103 | ] 104 | 105 | spec :: Spec 106 | spec = do 107 | makeElmModuleSpec 108 | version0p19Spec 109 | 110 | makeElmModuleSpec :: Spec 111 | makeElmModuleSpec = 112 | describe "makeElmModule" $ 113 | it "should produce the correct code" $ 114 | do let modu = makeElmModule "Foo" [DefineElm (Proxy :: Proxy (Bar a))] 115 | let modu' = makeElmModule "Qux" [DefineElm (Proxy :: Proxy (Qux a))] 116 | modu `shouldBe` moduleCode Elm0p19 117 | modu' `shouldBe` moduleCode' Elm0p19 118 | 119 | version0p19Spec :: Spec 120 | version0p19Spec = 121 | describe "makeElmModuleWithVersion Elm0p19" $ 122 | it "should produce the correct code" $ 123 | do let modu = makeElmModuleWithVersion Elm0p19 "Foo" [DefineElm (Proxy :: Proxy (Bar a))] 124 | let modu' = makeElmModuleWithVersion Elm0p19 "Qux" [DefineElm (Proxy :: Proxy (Qux a))] 125 | modu `shouldBe` moduleCode Elm0p19 126 | modu' `shouldBe` moduleCode' Elm0p19 127 | -------------------------------------------------------------------------------- /test/Elm/TyRenderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Elm.TyRenderSpec (spec) where 3 | 4 | import Elm.Derive 5 | import Elm.TyRep 6 | import Elm.TyRender 7 | 8 | import Data.Proxy 9 | import Test.Hspec 10 | 11 | data Foo 12 | = Foo 13 | { f_name :: String 14 | , f_blablub :: Int 15 | } deriving (Show, Eq) 16 | 17 | data Bar a 18 | = Bar 19 | { b_name :: a 20 | , b_blablub :: Int 21 | , b_tuple :: (Int, String) 22 | , b_list :: [Bool] 23 | } deriving (Show, Eq) 24 | 25 | data SomeOpts a 26 | = Okay Int 27 | | NotOkay a 28 | 29 | data Unit 30 | = Unit 31 | { u_unit :: () 32 | } 33 | 34 | data Paa 35 | = PA1 36 | | PA2 37 | 38 | newtype PhantomA a = PhantomA Int 39 | newtype PhantomB a = PhantomB { getPhantomB :: Int } 40 | newtype PhantomC a = PhantomC Int 41 | newtype PhantomD a = PhantomD { getPhantomD :: Int } 42 | 43 | $(deriveElmDef (defaultOptionsDropLower 2) ''Foo) 44 | $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) 45 | $(deriveElmDef defaultOptions ''SomeOpts) 46 | $(deriveElmDef defaultOptions ''Unit) 47 | $(deriveElmDef defaultOptions{allNullaryToStringTag = True, constructorTagModifier = drop 1} ''Paa) 48 | $(deriveElmDef defaultOptions ''PhantomA) 49 | $(deriveElmDef defaultOptions ''PhantomB) 50 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC) 51 | $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD) 52 | 53 | fooCode :: String 54 | fooCode = "type alias Foo =\n { name: String\n , blablub: Int\n }\n" 55 | 56 | barCode :: String 57 | barCode = "type alias Bar a =\n { name: a\n , blablub: Int\n , tuple: (Int, String)\n , list: (List Bool)\n }\n" 58 | 59 | someOptsCode :: String 60 | someOptsCode = "type SomeOpts a =\n Okay Int\n | NotOkay a\n" 61 | 62 | unitCode :: String 63 | unitCode = "type alias Unit =\n { u_unit: ()\n }\n" 64 | 65 | paaCode :: String 66 | paaCode = unlines 67 | [ "type Paa =" 68 | , " PA1 " 69 | , " | PA2 " 70 | ] 71 | 72 | phantomATy :: String 73 | phantomATy = "type alias PhantomA a = Int\n" 74 | phantomBTy :: String 75 | phantomBTy = "type alias PhantomB a = Int\n" 76 | phantomCTy :: String 77 | phantomCTy = "type alias PhantomC a = Int\n" 78 | phantomDTy :: String 79 | phantomDTy = "type PhantomD a = PhantomD\n { getPhantomD: Int\n }\n" 80 | 81 | spec :: Spec 82 | spec = 83 | describe "deriveElmRep" $ 84 | do let rFoo = compileElmDef (Proxy :: Proxy Foo) 85 | rBar = compileElmDef (Proxy :: Proxy (Bar a)) 86 | rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a)) 87 | rUnit = compileElmDef (Proxy :: Proxy Unit) 88 | rPaa = compileElmDef (Proxy :: Proxy Paa) 89 | rPhA = compileElmDef (Proxy :: Proxy (PhantomA a)) 90 | rPhB = compileElmDef (Proxy :: Proxy (PhantomB a)) 91 | rPhC = compileElmDef (Proxy :: Proxy (PhantomC a)) 92 | rPhD = compileElmDef (Proxy :: Proxy (PhantomD a)) 93 | it "should produce the correct code" $ 94 | do renderElm rFoo `shouldBe` fooCode 95 | renderElm rBar `shouldBe` barCode 96 | renderElm rSomeOpts `shouldBe` someOptsCode 97 | renderElm rUnit `shouldBe` unitCode 98 | renderElm rPaa `shouldBe` paaCode 99 | renderElm rPhA `shouldBe` phantomATy 100 | renderElm rPhB `shouldBe` phantomBTy 101 | renderElm rPhC `shouldBe` phantomCTy 102 | renderElm rPhD `shouldBe` phantomDTy 103 | -------------------------------------------------------------------------------- /test/Elm/TyRepSpec.hs: -------------------------------------------------------------------------------- 1 | module Elm.TyRepSpec (spec) where 2 | 3 | import Elm.TyRep 4 | 5 | import Data.Proxy 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = 10 | describe "toElmType" $ 11 | it "should produce the correct code" $ 12 | do toElmType (Proxy :: Proxy Int) `shouldBe` ETyCon (ETCon "Int") 13 | toElmType (Proxy :: Proxy Float) `shouldBe` ETyCon (ETCon "Float") 14 | toElmType (Proxy :: Proxy String) `shouldBe` ETyCon (ETCon "String") 15 | toElmType (Proxy :: Proxy Bool) `shouldBe` ETyCon (ETCon "Bool") 16 | toElmType (Proxy :: Proxy Char) `shouldBe` ETyCon (ETCon "Char") 17 | toElmType (Proxy :: Proxy [Int]) `shouldBe` ETyApp (ETyCon $ ETCon "List") (ETyCon $ ETCon "Int") 18 | toElmType (Proxy :: Proxy (Maybe Int)) `shouldBe` ETyApp (ETyCon $ ETCon "Maybe") (ETyCon $ ETCon "Int") 19 | toElmType (Proxy :: Proxy ()) `shouldBe` ETyTuple 0 20 | toElmType (Proxy :: Proxy (Int, Bool)) `shouldBe` ETyApp (ETyApp (ETyTuple 2) (ETyCon $ ETCon "Int")) (ETyCon $ ETCon "Bool") 21 | toElmType (Proxy :: Proxy (Int, Bool, String)) `shouldBe` ETyApp (ETyApp (ETyApp (ETyTuple 3) (ETyCon $ ETCon "Int")) (ETyCon $ ETCon "Bool")) (ETyCon $ ETCon "String") 22 | -------------------------------------------------------------------------------- /test/EndToEnd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Main where 4 | 5 | import Control.Applicative 6 | import Data.Aeson hiding (defaultOptions) 7 | import Data.Aeson.Types (SumEncoding (..)) 8 | import Data.Char (toLower) 9 | import Data.List (stripPrefix) 10 | import qualified Data.Map.Strict as M 11 | import Data.Proxy 12 | import qualified Data.Text as T 13 | import Elm.Derive 14 | import Elm.Module 15 | import Prelude 16 | import System.Environment 17 | import Test.QuickCheck.Arbitrary 18 | import Test.QuickCheck.Gen (Gen, oneof, sample') 19 | 20 | data Record1 a = Record1 { _r1foo :: Int, _r1bar :: Maybe Int, _r1baz :: a, _r1qux :: Maybe a, _r1jmap :: M.Map String Int } deriving Show 21 | data Record2 a = Record2 { _r2foo :: Int, _r2bar :: Maybe Int, _r2baz :: a, _r2qux :: Maybe a } deriving Show 22 | data RecordNestTuple a = RecordNestTuple (a, (a, a)) deriving Show 23 | 24 | data Sum01 a = Sum01A a | Sum01B (Maybe a) | Sum01C a a | Sum01D { _s01foo :: a } | Sum01E { _s01bar :: Int, _s01baz :: Int } deriving Show 25 | data Sum02 a = Sum02A a | Sum02B (Maybe a) | Sum02C a a | Sum02D { _s02foo :: a } | Sum02E { _s02bar :: Int, _s02baz :: Int } deriving Show 26 | data Sum03 a = Sum03A a | Sum03B (Maybe a) | Sum03C a a | Sum03D { _s03foo :: a } | Sum03E { _s03bar :: Int, _s03baz :: Int } deriving Show 27 | data Sum04 a = Sum04A a | Sum04B (Maybe a) | Sum04C a a | Sum04D { _s04foo :: a } | Sum04E { _s04bar :: Int, _s04baz :: Int } deriving Show 28 | data Sum05 a = Sum05A a | Sum05B (Maybe a) | Sum05C a a | Sum05D { _s05foo :: a } | Sum05E { _s05bar :: Int, _s05baz :: Int } deriving Show 29 | data Sum06 a = Sum06A a | Sum06B (Maybe a) | Sum06C a a | Sum06D { _s06foo :: a } | Sum06E { _s06bar :: Int, _s06baz :: Int } deriving Show 30 | data Sum07 a = Sum07A a | Sum07B (Maybe a) | Sum07C a a | Sum07D { _s07foo :: a } | Sum07E { _s07bar :: Int, _s07baz :: Int } deriving Show 31 | data Sum08 a = Sum08A a | Sum08B (Maybe a) | Sum08C a a | Sum08D { _s08foo :: a } | Sum08E { _s08bar :: Int, _s08baz :: Int } deriving Show 32 | data Sum09 a = Sum09A a | Sum09B (Maybe a) | Sum09C a a | Sum09D { _s09foo :: a } | Sum09E { _s09bar :: Int, _s09baz :: Int } deriving Show 33 | data Sum10 a = Sum10A a | Sum10B (Maybe a) | Sum10C a a | Sum10D { _s10foo :: a } | Sum10E { _s10bar :: Int, _s10baz :: Int } deriving Show 34 | data Sum11 a = Sum11A a | Sum11B (Maybe a) | Sum11C a a | Sum11D { _s11foo :: a } | Sum11E { _s11bar :: Int, _s11baz :: Int } deriving Show 35 | data Sum12 a = Sum12A a | Sum12B (Maybe a) | Sum12C a a | Sum12D { _s12foo :: a } | Sum12E { _s12bar :: Int, _s12baz :: Int } deriving Show 36 | 37 | data Simple01 a = Simple01 a deriving Show 38 | data Simple02 a = Simple02 a deriving Show 39 | data Simple03 a = Simple03 a deriving Show 40 | data Simple04 a = Simple04 a deriving Show 41 | data SimpleRecord01 a = SimpleRecord01 { _s01qux :: a } deriving Show 42 | data SimpleRecord02 a = SimpleRecord02 { _s02qux :: a } deriving Show 43 | data SimpleRecord03 a = SimpleRecord03 { _s03qux :: a } deriving Show 44 | data SimpleRecord04 a = SimpleRecord04 { _s04qux :: a } deriving Show 45 | 46 | data SumUntagged a = SMInt Int | SMList a 47 | deriving Show 48 | 49 | -- | It include unit, and non single field. 50 | data SumIncludeUnit a = SumIncludeUnitZero | SumIncludeUnitOne a | SumIncludeUnitTwo a a deriving Show 51 | 52 | newtype NT1 = NT1 [Int] deriving Show 53 | newtype NT2 = NT2 { _nt2foo :: [Int] } deriving Show 54 | newtype NT3 = NT3 [Int] deriving Show 55 | newtype NT4 = NT4 { _nt4foo :: [Int] } deriving Show 56 | 57 | extractNT1 :: NT1 -> [Int] 58 | extractNT1 (NT1 x) =x 59 | extractNT2 :: NT2 -> [Int] 60 | extractNT2 (NT2 x) =x 61 | extractNT3 :: NT3 -> [Int] 62 | extractNT3 (NT3 x) =x 63 | 64 | dropAll :: String -> String -> String 65 | dropAll needle haystack 66 | = case stripPrefix needle haystack of 67 | Just nxt -> dropAll needle nxt 68 | Nothing -> case haystack of 69 | [] -> [] 70 | (x:xs) -> x : dropAll needle xs 71 | 72 | 73 | mkDecodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String 74 | mkDecodeTest pred prefix num elems = unlines ( 75 | [ map toLower pred ++ "Decode" ++ num ++ " : Test" 76 | , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\"" 77 | ] 78 | ++ map mktest (zip ([1..] :: [Int]) elems) 79 | ++ [" ]"] 80 | ) 81 | where 82 | mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString (jsonDec" ++ pred ++ num ++ " (Json.Decode.list Json.Decode.int)) " ++ encoded ++ "))" 83 | where 84 | pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e 85 | encoded = show (encode e) 86 | pfix = if n == 1 then " [ " else " , " 87 | 88 | mkDecodeTestNT :: ToJSON n => String -> String -> String -> (n -> [Int]) -> [n] -> String 89 | mkDecodeTestNT pred prefix num extract elems = unlines ( 90 | [ map toLower pred ++ "Decode" ++ num ++ " : Test" 91 | , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\"" 92 | ] 93 | ++ map mktest (zip ([1..] :: [Int]) elems) 94 | ++ [" ]"] 95 | ) 96 | where 97 | mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString jsonDec" ++ pred ++ num ++ " " ++ encoded ++ "))" 98 | where 99 | pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract e) 100 | encoded = show (encode e) 101 | pfix = if n == 1 then " [ " else " , " 102 | 103 | mkSumDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String 104 | mkSumDecodeTest = mkDecodeTest "Sum" "_s" 105 | 106 | mkRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String 107 | mkRecordDecodeTest = mkDecodeTest "Record" "_r" 108 | 109 | mkEncodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String 110 | mkEncodeTest pred prefix num elems = unlines ( 111 | [ map toLower pred ++ "Encode" ++ num ++ " : Test" 112 | , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\"" 113 | ] 114 | ++ map mktest (zip ([1..] :: [Int]) elems) 115 | ++ [" ]"] 116 | ) 117 | where 118 | mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ "(Json.Encode.list Json.Encode.int) (" ++ pretty ++ "))))" 119 | where 120 | pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e 121 | encoded = show (encode e) 122 | pfix = if n == 1 then " [ " else " , " 123 | 124 | mkEncodeTestNT :: (Show a, ToJSON n) => String -> String -> String -> (n -> a) -> [n] -> String 125 | mkEncodeTestNT pred prefix num extract elems = unlines ( 126 | [ map toLower pred ++ "Encode" ++ num ++ " : Test" 127 | , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\"" 128 | ] 129 | ++ map mktest (zip ([1..] :: [Int]) elems) 130 | ++ [" ]"] 131 | ) 132 | where 133 | mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ " (" ++ pretty ++ "))))" 134 | where 135 | pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract e) 136 | encoded = show (encode e) 137 | pfix = if n == 1 then " [ " else " , " 138 | 139 | mkSumEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String 140 | mkSumEncodeTest = mkEncodeTest "Sum" "_s" 141 | 142 | mkRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String 143 | mkRecordEncodeTest = mkEncodeTest "Record" "_r" 144 | 145 | mkSimpleRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String 146 | mkSimpleRecordDecodeTest = mkDecodeTest "SimpleRecord" "_s" 147 | 148 | mkSimpleRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String 149 | mkSimpleRecordEncodeTest = mkEncodeTest "SimpleRecord" "_s" 150 | 151 | mkSimpleDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String 152 | mkSimpleDecodeTest = mkDecodeTest "Simple" "_s" 153 | 154 | mkSimpleEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String 155 | mkSimpleEncodeTest = mkEncodeTest "Simple" "_s" 156 | 157 | 158 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) 159 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2) 160 | $(deriveBoth defaultOptions ''RecordNestTuple) 161 | 162 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum01) 163 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum02) 164 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TaggedObject "tag" "content" } ''Sum03) 165 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TaggedObject "tag" "content" } ''Sum04) 166 | 167 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = ObjectWithSingleField } ''Sum05) 168 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = ObjectWithSingleField } ''Sum06) 169 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = ObjectWithSingleField } ''Sum07) 170 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = ObjectWithSingleField } ''Sum08) 171 | 172 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = TwoElemArray } ''Sum09) 173 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = TwoElemArray } ''Sum10) 174 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum11) 175 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum12) 176 | 177 | $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False } ''Simple01) 178 | $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True } ''Simple02) 179 | $(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = False } ''Simple03) 180 | $(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = True } ''Simple04) 181 | 182 | $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord01) 183 | $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord02) 184 | $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord03) 185 | $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord04) 186 | 187 | $(deriveBoth defaultOptions{ sumEncoding = UntaggedValue } ''SumUntagged) 188 | 189 | -- servant-elm use TaggedObject. 190 | $(deriveBoth defaultOptions{ fieldLabelModifier = drop 14, sumEncoding = TaggedObject "tag" "content" } ''SumIncludeUnit) 191 | 192 | $(deriveBoth defaultOptions ''NT1) 193 | $(deriveBoth defaultOptions { fieldLabelModifier = drop 4 } ''NT2) 194 | $(deriveBoth defaultOptions { unwrapUnaryRecords = False }''NT3) 195 | $(deriveBoth defaultOptions { fieldLabelModifier = drop 4, unwrapUnaryRecords = False } ''NT4) 196 | 197 | instance Arbitrary a => Arbitrary (Record1 a) where 198 | arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary <*> (M.singleton "a" <$> arbitrary) 199 | instance Arbitrary a => Arbitrary (Record2 a) where 200 | arbitrary = Record2 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary 201 | 202 | arb :: Arbitrary a => (a -> b) -> (Maybe a -> b) -> (a -> a -> b) -> (a -> b) -> (Int -> Int -> b) -> Gen b 203 | arb c1 c2 c3 c4 c5 = oneof 204 | [ c1 <$> arbitrary 205 | , c2 . Just <$> arbitrary 206 | , c3 <$> arbitrary <*> arbitrary 207 | , c4 <$> arbitrary 208 | , c5 <$> arbitrary <*> arbitrary 209 | ] 210 | 211 | instance Arbitrary a => Arbitrary (RecordNestTuple a) where 212 | arbitrary = (\x y z -> RecordNestTuple (x, (y, z))) <$> arbitrary <*> arbitrary <*> arbitrary 213 | instance Arbitrary a => Arbitrary (Sum01 a) where arbitrary = arb Sum01A Sum01B Sum01C Sum01D Sum01E 214 | instance Arbitrary a => Arbitrary (Sum02 a) where arbitrary = arb Sum02A Sum02B Sum02C Sum02D Sum02E 215 | instance Arbitrary a => Arbitrary (Sum03 a) where arbitrary = arb Sum03A Sum03B Sum03C Sum03D Sum03E 216 | instance Arbitrary a => Arbitrary (Sum04 a) where arbitrary = arb Sum04A Sum04B Sum04C Sum04D Sum04E 217 | instance Arbitrary a => Arbitrary (Sum05 a) where arbitrary = arb Sum05A Sum05B Sum05C Sum05D Sum05E 218 | instance Arbitrary a => Arbitrary (Sum06 a) where arbitrary = arb Sum06A Sum06B Sum06C Sum06D Sum06E 219 | instance Arbitrary a => Arbitrary (Sum07 a) where arbitrary = arb Sum07A Sum07B Sum07C Sum07D Sum07E 220 | instance Arbitrary a => Arbitrary (Sum08 a) where arbitrary = arb Sum08A Sum08B Sum08C Sum08D Sum08E 221 | instance Arbitrary a => Arbitrary (Sum09 a) where arbitrary = arb Sum09A Sum09B Sum09C Sum09D Sum09E 222 | instance Arbitrary a => Arbitrary (Sum10 a) where arbitrary = arb Sum10A Sum10B Sum10C Sum10D Sum10E 223 | instance Arbitrary a => Arbitrary (Sum11 a) where arbitrary = arb Sum11A Sum11B Sum11C Sum11D Sum11E 224 | instance Arbitrary a => Arbitrary (Sum12 a) where arbitrary = arb Sum12A Sum12B Sum12C Sum12D Sum12E 225 | 226 | instance Arbitrary a => Arbitrary (Simple01 a) where arbitrary = Simple01 <$> arbitrary 227 | instance Arbitrary a => Arbitrary (Simple02 a) where arbitrary = Simple02 <$> arbitrary 228 | instance Arbitrary a => Arbitrary (Simple03 a) where arbitrary = Simple03 <$> arbitrary 229 | instance Arbitrary a => Arbitrary (Simple04 a) where arbitrary = Simple04 <$> arbitrary 230 | instance Arbitrary a => Arbitrary (SimpleRecord01 a) where arbitrary = SimpleRecord01 <$> arbitrary 231 | instance Arbitrary a => Arbitrary (SimpleRecord02 a) where arbitrary = SimpleRecord02 <$> arbitrary 232 | instance Arbitrary a => Arbitrary (SimpleRecord03 a) where arbitrary = SimpleRecord03 <$> arbitrary 233 | instance Arbitrary a => Arbitrary (SimpleRecord04 a) where arbitrary = SimpleRecord04 <$> arbitrary 234 | 235 | instance Arbitrary a => Arbitrary (SumUntagged a) where arbitrary = oneof [ SMInt <$> arbitrary, SMList <$> arbitrary ] 236 | 237 | instance Arbitrary a => Arbitrary (SumIncludeUnit a) where 238 | arbitrary = oneof [ return SumIncludeUnitZero, SumIncludeUnitOne <$> arbitrary, SumIncludeUnitTwo <$> arbitrary <*> arbitrary] 239 | 240 | instance Arbitrary NT1 where arbitrary = fmap NT1 arbitrary 241 | instance Arbitrary NT2 where arbitrary = fmap NT2 arbitrary 242 | instance Arbitrary NT3 where arbitrary = fmap NT3 arbitrary 243 | instance Arbitrary NT4 where arbitrary = fmap NT4 arbitrary 244 | 245 | elmModuleContent :: String 246 | elmModuleContent = unlines 247 | [ "module MyTests exposing (..)" 248 | , "-- This module requires the following packages:" 249 | , "-- * bartavelle/json-helpers" 250 | , "-- * NoRedInk/elm-json-decode-pipeline" 251 | , "-- * elm/json" 252 | , "-- * elm-explorations/test" 253 | , "" 254 | , "import Dict exposing (Dict, fromList)" 255 | , "import Expect exposing (Expectation, equal)" 256 | , "import Set exposing (Set)" 257 | , "import Json.Decode exposing (field, Value)" 258 | , "import Json.Encode" 259 | , "import Json.Helpers exposing (..)" 260 | , "import String" 261 | , "import Test exposing (Test, describe, test)" 262 | , "" 263 | , "newtypeDecode : Test" 264 | , "newtypeDecode = describe \"Newtype decoding checks\"" 265 | , " [ ntDecode1" 266 | , " , ntDecode2" 267 | , " , ntDecode3" 268 | , " , ntDecode4" 269 | , " ]" 270 | , "" 271 | , "newtypeEncode : Test" 272 | , "newtypeEncode = describe \"Newtype encoding checks\"" 273 | , " [ ntEncode1" 274 | , " , ntEncode2" 275 | , " , ntEncode3" 276 | , " , ntEncode4" 277 | , " ]" 278 | , "" 279 | , "recordDecode : Test" 280 | , "recordDecode = describe \"Record decoding checks\"" 281 | , " [ recordDecode1" 282 | , " , recordDecode2" 283 | , " , recordDecodeNestTuple" 284 | , " ]" 285 | , "" 286 | , "recordEncode : Test" 287 | , "recordEncode = describe \"Record encoding checks\"" 288 | , " [ recordEncode1" 289 | , " , recordEncode2" 290 | , " , recordEncodeNestTuple" 291 | , " ]" 292 | , "" 293 | , "sumDecode : Test" 294 | , "sumDecode = describe \"Sum decoding checks\"" 295 | , " [ sumDecode01" 296 | , " , sumDecode02" 297 | , " , sumDecode03" 298 | , " , sumDecode04" 299 | , " , sumDecode05" 300 | , " , sumDecode06" 301 | , " , sumDecode07" 302 | , " , sumDecode08" 303 | , " , sumDecode09" 304 | , " , sumDecode10" 305 | , " , sumDecode11" 306 | , " , sumDecode12" 307 | , " , sumDecodeUntagged" 308 | , " , sumDecodeIncludeUnit" 309 | , " ]" 310 | , "" 311 | , "sumEncode : Test" 312 | , "sumEncode = describe \"Sum encoding checks\"" 313 | , " [ sumEncode01" 314 | , " , sumEncode02" 315 | , " , sumEncode03" 316 | , " , sumEncode04" 317 | , " , sumEncode05" 318 | , " , sumEncode06" 319 | , " , sumEncode07" 320 | , " , sumEncode08" 321 | , " , sumEncode09" 322 | , " , sumEncode10" 323 | , " , sumEncode11" 324 | , " , sumEncode12" 325 | , " , sumEncodeUntagged" 326 | , " , sumEncodeIncludeUnit" 327 | , " ]" 328 | , "" 329 | , "simpleDecode : Test" 330 | , "simpleDecode = describe \"Simple records/types decode checks\"" 331 | , " [ simpleDecode01" 332 | , " , simpleDecode02" 333 | , " , simpleDecode03" 334 | , " , simpleDecode04" 335 | , " , simplerecordDecode01" 336 | , " , simplerecordDecode02" 337 | , " , simplerecordDecode03" 338 | , " , simplerecordDecode04" 339 | , " ]" 340 | , "" 341 | , "simpleEncode : Test" 342 | , "simpleEncode = describe \"Simple records/types encode checks\"" 343 | , " [ simpleEncode01" 344 | , " , simpleEncode02" 345 | , " , simpleEncode03" 346 | , " , simpleEncode04" 347 | , " , simplerecordEncode01" 348 | , " , simplerecordEncode02" 349 | , " , simplerecordEncode03" 350 | , " , simplerecordEncode04" 351 | , " ]" 352 | , "" 353 | , "-- this is done to prevent artificial differences due to object ordering, this won't work with Maybe's though :(" 354 | , "equalHack : String -> String -> Expectation" 355 | , "equalHack a b =" 356 | , " let remix = Json.Decode.decodeString Json.Decode.value" 357 | , " in equal (remix a) (remix b)" 358 | , "" 359 | , "" 360 | , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) 361 | [ DefineElm (Proxy :: Proxy (Record1 a)) 362 | , DefineElm (Proxy :: Proxy (Record2 a)) 363 | , DefineElm (Proxy :: Proxy (RecordNestTuple a)) 364 | , DefineElm (Proxy :: Proxy (Sum01 a)) 365 | , DefineElm (Proxy :: Proxy (Sum02 a)) 366 | , DefineElm (Proxy :: Proxy (Sum03 a)) 367 | , DefineElm (Proxy :: Proxy (Sum04 a)) 368 | , DefineElm (Proxy :: Proxy (Sum05 a)) 369 | , DefineElm (Proxy :: Proxy (Sum06 a)) 370 | , DefineElm (Proxy :: Proxy (Sum07 a)) 371 | , DefineElm (Proxy :: Proxy (Sum08 a)) 372 | , DefineElm (Proxy :: Proxy (Sum09 a)) 373 | , DefineElm (Proxy :: Proxy (Sum10 a)) 374 | , DefineElm (Proxy :: Proxy (Sum11 a)) 375 | , DefineElm (Proxy :: Proxy (Sum12 a)) 376 | , DefineElm (Proxy :: Proxy (Simple01 a)) 377 | , DefineElm (Proxy :: Proxy (Simple02 a)) 378 | , DefineElm (Proxy :: Proxy (Simple03 a)) 379 | , DefineElm (Proxy :: Proxy (Simple04 a)) 380 | , DefineElm (Proxy :: Proxy (SimpleRecord01 a)) 381 | , DefineElm (Proxy :: Proxy (SimpleRecord02 a)) 382 | , DefineElm (Proxy :: Proxy (SimpleRecord03 a)) 383 | , DefineElm (Proxy :: Proxy (SimpleRecord04 a)) 384 | , DefineElm (Proxy :: Proxy (SumUntagged a)) 385 | , DefineElm (Proxy :: Proxy (SumIncludeUnit a)) 386 | , DefineElm (Proxy :: Proxy NT1) 387 | , DefineElm (Proxy :: Proxy NT2) 388 | , DefineElm (Proxy :: Proxy NT3) 389 | , DefineElm (Proxy :: Proxy NT4) 390 | ] 391 | ] 392 | 393 | 394 | main :: IO () 395 | main = do 396 | ss01 <- sample' arbitrary :: IO [Sum01 [Int]] 397 | ss02 <- sample' arbitrary :: IO [Sum02 [Int]] 398 | ss03 <- sample' arbitrary :: IO [Sum03 [Int]] 399 | ss04 <- sample' arbitrary :: IO [Sum04 [Int]] 400 | ss05 <- sample' arbitrary :: IO [Sum05 [Int]] 401 | ss06 <- sample' arbitrary :: IO [Sum06 [Int]] 402 | ss07 <- sample' arbitrary :: IO [Sum07 [Int]] 403 | ss08 <- sample' arbitrary :: IO [Sum08 [Int]] 404 | ss09 <- sample' arbitrary :: IO [Sum09 [Int]] 405 | ss10 <- sample' arbitrary :: IO [Sum10 [Int]] 406 | ss11 <- sample' arbitrary :: IO [Sum11 [Int]] 407 | ss12 <- sample' arbitrary :: IO [Sum12 [Int]] 408 | re01 <- sample' arbitrary :: IO [Record1 [Int]] 409 | re02 <- sample' arbitrary :: IO [Record2 [Int]] 410 | rent <- sample' arbitrary :: IO [RecordNestTuple [Int]] 411 | sp01 <- sample' arbitrary :: IO [Simple01 [Int]] 412 | sp02 <- sample' arbitrary :: IO [Simple02 [Int]] 413 | sp03 <- sample' arbitrary :: IO [Simple03 [Int]] 414 | sp04 <- sample' arbitrary :: IO [Simple04 [Int]] 415 | sr01 <- sample' arbitrary :: IO [SimpleRecord01 [Int]] 416 | sr02 <- sample' arbitrary :: IO [SimpleRecord02 [Int]] 417 | sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]] 418 | sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]] 419 | sm <- sample' arbitrary :: IO [SumUntagged [Int]] 420 | smiu <- sample' arbitrary :: IO [SumIncludeUnit [Int]] 421 | nt1 <- sample' arbitrary :: IO [NT1] 422 | nt2 <- sample' arbitrary :: IO [NT2] 423 | nt3 <- sample' arbitrary :: IO [NT3] 424 | nt4 <- sample' arbitrary :: IO [NT4] 425 | args <- getArgs 426 | case args of 427 | [] -> return () 428 | (x:_) -> writeFile x $ 429 | unlines [ elmModuleContent 430 | , mkSumEncodeTest "01" ss01 431 | , mkSumEncodeTest "02" ss02 432 | , mkSumEncodeTest "03" ss03 433 | , mkSumEncodeTest "04" ss04 434 | , mkSumEncodeTest "05" ss05 435 | , mkSumEncodeTest "06" ss06 436 | , mkSumEncodeTest "07" ss07 437 | , mkSumEncodeTest "08" ss08 438 | , mkSumEncodeTest "09" ss09 439 | , mkSumEncodeTest "10" ss10 440 | , mkSumEncodeTest "11" ss11 441 | , mkSumEncodeTest "12" ss12 442 | , mkSumDecodeTest "01" ss01 443 | , mkSumDecodeTest "02" ss02 444 | , mkSumDecodeTest "03" ss03 445 | , mkSumDecodeTest "04" ss04 446 | , mkSumDecodeTest "05" ss05 447 | , mkSumDecodeTest "06" ss06 448 | , mkSumDecodeTest "07" ss07 449 | , mkSumDecodeTest "08" ss08 450 | , mkSumDecodeTest "09" ss09 451 | , mkSumDecodeTest "10" ss10 452 | , mkSumDecodeTest "11" ss11 453 | , mkSumDecodeTest "12" ss12 454 | , mkRecordDecodeTest "1" re01 455 | , mkRecordDecodeTest "2" re02 456 | , mkRecordEncodeTest "1" re01 457 | , mkRecordEncodeTest "2" re02 458 | , mkRecordDecodeTest "NestTuple" rent 459 | , mkRecordEncodeTest "NestTuple" rent 460 | , mkSimpleEncodeTest "01" sp01 461 | , mkSimpleEncodeTest "02" sp02 462 | , mkSimpleEncodeTest "03" sp03 463 | , mkSimpleEncodeTest "04" sp04 464 | , mkSimpleDecodeTest "01" sp01 465 | , mkSimpleDecodeTest "02" sp02 466 | , mkSimpleDecodeTest "03" sp03 467 | , mkSimpleDecodeTest "04" sp04 468 | , mkSimpleRecordEncodeTest "01" sr01 469 | , mkSimpleRecordEncodeTest "02" sr02 470 | , mkSimpleRecordEncodeTest "03" sr03 471 | , mkSimpleRecordEncodeTest "04" sr04 472 | , mkSimpleRecordDecodeTest "01" sr01 473 | , mkSimpleRecordDecodeTest "02" sr02 474 | , mkSimpleRecordDecodeTest "03" sr03 475 | , mkSimpleRecordDecodeTest "04" sr04 476 | , mkSumEncodeTest "Untagged" sm 477 | , mkSumDecodeTest "Untagged" sm 478 | , mkSumEncodeTest "IncludeUnit" smiu 479 | , mkSumDecodeTest "IncludeUnit" smiu 480 | , mkDecodeTestNT "NT" "_nt" "1" extractNT1 nt1 481 | , mkEncodeTestNT "NT" "_nt" "1" extractNT1 nt1 482 | , mkDecodeTestNT "NT" "_nt" "2" extractNT2 nt2 483 | , mkEncodeTestNT "NT" "_nt" "2" extractNT2 nt2 484 | , mkDecodeTestNT "NT" "_nt" "3" extractNT3 nt3 485 | , mkEncodeTestNT "NT" "_nt" "3" extractNT3 nt3 486 | , dropAll "(Json.Decode.list Json.Decode.int)" (mkDecodeTest "NT" "_nt" "4" nt4) 487 | , dropAll "(Json.Encode.list Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) 488 | ] 489 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Elm.DeriveSpec 4 | import qualified Elm.TyRenderSpec 5 | import qualified Elm.JsonSpec 6 | import qualified Elm.ModuleSpec 7 | import qualified Elm.TyRepSpec 8 | 9 | import Test.Hspec 10 | 11 | main :: IO () 12 | main = hspec $ do 13 | describe "Elm.DeriveSpec" Elm.DeriveSpec.spec 14 | describe "Elm.TyRenderSpec" Elm.TyRenderSpec.spec 15 | describe "Elm.JsonSpec" Elm.JsonSpec.spec 16 | describe "Elm.ModuleSpec" Elm.ModuleSpec.spec 17 | describe "Elm.TyRepSpec" Elm.TyRepSpec.spec 18 | -------------------------------------------------------------------------------- /test/current-end-to-end/.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | -------------------------------------------------------------------------------- /test/current-end-to-end/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.0", 10 | "bartavelle/json-helpers": "2.0.2", 11 | "elm/browser": "1.0.2", 12 | "elm/core": "1.0.5", 13 | "elm/html": "1.0.0", 14 | "elm/json": "1.1.3", 15 | "elm-explorations/test": "1.2.2" 16 | }, 17 | "indirect": { 18 | "elm/random": "1.0.0", 19 | "elm/time": "1.0.0", 20 | "elm/url": "1.0.0", 21 | "elm/virtual-dom": "1.0.2" 22 | } 23 | }, 24 | "test-dependencies": { 25 | "direct": {}, 26 | "indirect": {} 27 | } 28 | } 29 | --------------------------------------------------------------------------------