diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml new file mode 100644 index 00000000..71144dfc --- /dev/null +++ b/.github/workflows/CI.yml @@ -0,0 +1,38 @@ +name: CI + +on: + push: + branches: [master, staging] + pull_request: + branches: [master, staging] + workflow_dispatch: + +jobs: + ci: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2 + - uses: cachix/install-nix-action@v16 + name: Set up nix and IOHK cache + with: + nix_path: nixpkgs=channel:nixos-unstable + extra_nix_config: | + trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= + substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ + experimental-features = nix-command flakes + - uses: cachix/cachix-action@v10 + with: + name: mlabs + authToken: "${{ secrets.CACHIXKEY }}" + - name: Cache cabal folder + id: cabal + uses: actions/cache@v2.1.4 + with: + path: | + ~/.cabal/packages + ~/.cabal/store + dist-newstyle + key: ${{ runner.os }}-cabal + - name: Check files and build + run: make ci + diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000..4e73857d --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,10 @@ +- ignore: {name: "Use <$>"} +- warn: {name: "Use explicit module export list"} +- warn: {name: "Use fewer imports"} +- warn: {name: "Use fewer LANGUAGE pragmas"} +- warn: {name: "Unused LANGUAGE pragma"} +- warn: {name: "Use DerivingStrategies"} +- ignore: {name: "Use newtype instead of data"} +- modules: + - {name: [PlutusTx.Prelude], as: PlutusTx, message: "You would make the MLabs styleguide happy."} + - {name: [Prelude], as: Hask, message: "You would make the MLabs styleguide happy."} diff --git a/.shellcheckrc b/.shellcheckrc new file mode 100644 index 00000000..cf179afb --- /dev/null +++ b/.shellcheckrc @@ -0,0 +1 @@ +disable=SC2086 \ No newline at end of file diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index b504acfb..00000000 --- a/.travis.yml +++ /dev/null @@ -1,89 +0,0 @@ -# vim: nospell -language: minimal -sudo: false - -cache: - directories: - - $HOME/.stack - -matrix: - include: - - env: GHC=7.10.3 CABAL=1.22 - compiler: "GHC 7.10" - addons: - apt: - sources: - - hvr-ghc - packages: - - ghc-7.10.3 - - cabal-install-1.22 - - happy-1.19.5 - - alex-3.1.4 - - - env: GHC=8.0.1 CABAL=1.24 - compiler: "GHC 8.0" - addons: - apt: - sources: - - hvr-ghc - packages: - - ghc-8.0.1 - - cabal-install-1.24 - - happy-1.19.5 - - alex-3.1.4 - - - env: GHC=head CABAL=1.24 - compiler: "GHC HEAD" - addons: - apt: - sources: - - hvr-ghc - packages: - - ghc-head - - cabal-install-1.24 - - happy-1.19.5 - - alex-3.1.4 - - allow_failures: - - env: GHC=head CABAL=1.24 - - fast_finish: true - - -before_install: - - export PATH=/opt/ghc/$GHC/bin:/opt/cabal/$CABAL/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.5/bin:$PATH - - # cabal - - travis_retry cabal update - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - # stack - - mkdir -p $HOME/bin - - export PATH=$HOME/bin:$PATH - - travis_retry curl -L "https://www.stackage.org/stack/linux-x86_64" | gunzip | tar -x - - mv stack-*/stack $HOME/bin - - if [ ${GHC} != head ]; then ln -s stack-${GHC%.*}.yaml stack.yaml; fi - - pwd - - ls -lh - - travis_retry stack setup - - travis_retry stack install hscolour - -install: - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - stack --version - - cabal --version - - opt --version; true - - llc --version; true - - | - if [ ${GHC} != head ]; then - travis_retry stack build --only-dependencies --no-terminal --no-haddock-deps -j2 - else - travis_retry cabal install --only-dependencies --allow-newer - fi -script: - - | - if [ ${GHC} != head ]; then - stack test --no-terminal - else - cabal install --allow-newer - fi diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..f4dbb0ba --- /dev/null +++ b/Makefile @@ -0,0 +1,37 @@ +current-system := $(shell nix eval --impure --expr builtins.currentSystem) + +NIX_BUILD:= nix -L --show-trace build +NIX_RUN:= nix -L --show-trace run + +# Tests +test: + $(NIX_BUILD) .#checks.${current-system}.purescript-bridge:test:tests + +test-all: test + +# Build all +build-all: + $(NIX_BUILD) .#build-all.${current-system} + +build-test-all: build-all test-all + +# Fix files +fix-files: + $(NIX_RUN) .#$@.${current-system} + +# Check files +check-files: + $(NIX_BUILD) .#$@.${current-system} + +# Run what CI would +ci: check-files build-all + +# Clean local folder. +clean: + @ rm -rf dist-newstyle || true + @ rm -rf .psc-ide-port || true + @ rm -rf ./test/RoundTrip/app/dist || true + @ rm -rf ./test/RoundTrip/app/output || true + @ rm -rf ./test/RoundTrip/app/.spago || true + @ rm -rf ./test/RoundTrip/app/.psci_modules || true + @ rm -rf ./test/RoundTrip/app/.spago2nix || true diff --git a/Setup.hs b/Setup.hs index 9a994af6..e8ef27db 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..fb725a24 --- /dev/null +++ b/cabal.project @@ -0,0 +1,30 @@ +index-state: 2022-01-22T00:00:00Z + +packages: . + +tests: true + +write-ghc-environment-files: never + +test-show-details: streaming + +allow-newer: + -- Pins to an old version of Template Haskell, unclear if/when it will be updated + size-based:template-haskell + , ouroboros-consensus-byron:formatting + , beam-core:aeson + , beam-sqlite:aeson + , beam-sqlite:dlist + , beam-migrate:aeson + +constraints: + -- big breaking change here, inline-r doens't have an upper bound + singletons < 3.0 + -- bizarre issue: in earlier versions they define their own 'GEq', in newer + -- ones they reuse the one from 'some', but there isn't e.g. a proper version + -- constraint from dependent-sum-template (which is the library we actually use). + , dependent-sum > 0.6.2.0 + -- Newer Hashable have instances for Set, which breaks beam-migrate + -- which declares its own instances of Hashable Set + , hashable < 1.3.4.0 + diff --git a/flake.lock b/flake.lock index 88ad8b1f..5f7a3930 100644 --- a/flake.lock +++ b/flake.lock @@ -16,6 +16,98 @@ "type": "github" } }, + "HTTP_2": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "HTTP_3": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "Win32-network": { + "flake": false, + "locked": { + "lastModified": 1627315969, + "narHash": "sha256-Hesb5GXSx0IwKSIi42ofisVELcQNX6lwHcoZcbaDiqc=", + "owner": "input-output-hk", + "repo": "Win32-network", + "rev": "3825d3abf75f83f406c1f7161883c438dac7277d", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "Win32-network", + "rev": "3825d3abf75f83f406c1f7161883c438dac7277d", + "type": "github" + } + }, + "bot-plutus-interface": { + "inputs": { + "Win32-network": "Win32-network", + "cardano-addresses": "cardano-addresses", + "cardano-base": "cardano-base", + "cardano-config": "cardano-config", + "cardano-crypto": "cardano-crypto", + "cardano-ledger": "cardano-ledger", + "cardano-node": "cardano-node", + "cardano-prelude": "cardano-prelude", + "cardano-wallet": "cardano-wallet", + "flake-compat": "flake-compat", + "flat": "flat", + "goblins": "goblins", + "haskell-nix": "haskell-nix", + "iohk-monitoring-framework": "iohk-monitoring-framework", + "iohk-nix": "iohk-nix", + "nixpkgs": [ + "bot-plutus-interface", + "haskell-nix", + "nixpkgs-unstable" + ], + "optparse-applicative": "optparse-applicative", + "ouroboros-network": "ouroboros-network", + "plutus": "plutus", + "plutus-apps": "plutus-apps", + "purescript-bridge": "purescript-bridge", + "servant-purescript": "servant-purescript" + }, + "locked": { + "lastModified": 1649173221, + "narHash": "sha256-QbGtipYZ2oVsjHnIhx+e4TJD34kJBR3svGdwR6onRR4=", + "owner": "mlabs-haskell", + "repo": "bot-plutus-interface", + "rev": "ea23586df347d60533384351374fde2605e694cf", + "type": "github" + }, + "original": { + "owner": "mlabs-haskell", + "repo": "bot-plutus-interface", + "type": "github" + } + }, "cabal-32": { "flake": false, "locked": { @@ -33,6 +125,40 @@ "type": "github" } }, + "cabal-32_2": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-32_3": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, "cabal-34": { "flake": false, "locked": { @@ -50,269 +176,1273 @@ "type": "github" } }, - "cardano-shell": { + "cabal-34_2": { "flake": false, "locked": { - "lastModified": 1608537748, - "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", - "owner": "input-output-hk", - "repo": "cardano-shell", - "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "lastModified": 1640353650, + "narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=", + "owner": "haskell", + "repo": "cabal", + "rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd", "type": "github" }, "original": { - "owner": "input-output-hk", - "repo": "cardano-shell", + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", "type": "github" } }, - "easy-ps": { + "cabal-34_3": { "flake": false, "locked": { - "lastModified": 1631961521, - "narHash": "sha256-1yPjUdOYzw1+UGFzBXbyZqEbsM6XZu/6+v8W35qFdLo=", - "owner": "justinwoo", - "repo": "easy-purescript-nix", - "rev": "d9a37c75ed361372e1545f6efbc08d819b3c28c8", + "lastModified": 1640353650, + "narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=", + "owner": "haskell", + "repo": "cabal", + "rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd", "type": "github" }, "original": { - "owner": "justinwoo", - "repo": "easy-purescript-nix", + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", "type": "github" } }, - "flake-utils": { + "cabal-36": { + "flake": false, "locked": { - "lastModified": 1631561581, - "narHash": "sha256-3VQMV5zvxaVLvqqUrNz3iJelLw30mIVSfZmAaauM3dA=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "7e5bf3925f6fbdfaf50a2a7ca0be2879c4261d19", + "lastModified": 1641652457, + "narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=", + "owner": "haskell", + "repo": "cabal", + "rev": "f27667f8ec360c475027dcaee0138c937477b070", "type": "github" }, "original": { - "owner": "numtide", - "repo": "flake-utils", + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", "type": "github" } }, - "flake-utils_2": { + "cabal-36_2": { + "flake": false, "locked": { - "lastModified": 1623875721, - "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", + "lastModified": 1641652457, + "narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=", + "owner": "haskell", + "repo": "cabal", + "rev": "f27667f8ec360c475027dcaee0138c937477b070", "type": "github" }, "original": { - "owner": "numtide", - "repo": "flake-utils", + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", "type": "github" } }, - "ghc-8.6.5-iohk": { + "cardano-addresses": { "flake": false, "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "lastModified": 1639584472, + "narHash": "sha256-Eyu7PVYk1oQLp/Hd43S2PW+PojyAT/Rr48Xng6sbtIU=", "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "repo": "cardano-addresses", + "rev": "71006f9eb956b0004022e80aadd4ad50d837b621", "type": "github" }, "original": { "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", + "repo": "cardano-addresses", + "rev": "71006f9eb956b0004022e80aadd4ad50d837b621", "type": "github" } }, - "hackage": { + "cardano-base": { "flake": false, "locked": { - "lastModified": 1633396333, - "narHash": "sha256-mq7OoYa7ODDoKzUxR8xuEtQ0F0LO9I5uZG9DTZY+A/U=", + "lastModified": 1635841753, + "narHash": "sha256-OXKsJ1UTj5kJ9xaThM54ZmxFAiFINTPKd4JQa4dPmEU=", "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "0b33cf7ca5f152a6b3acda375433a6bc86f8d3e7", + "repo": "cardano-base", + "rev": "41545ba3ac6b3095966316a99883d678b5ab8da8", "type": "github" }, "original": { "owner": "input-output-hk", - "repo": "hackage.nix", + "repo": "cardano-base", + "rev": "41545ba3ac6b3095966316a99883d678b5ab8da8", "type": "github" } }, - "haskellNix": { - "inputs": { - "HTTP": "HTTP", - "cabal-32": "cabal-32", - "cabal-34": "cabal-34", - "cardano-shell": "cardano-shell", - "flake-utils": "flake-utils_2", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "hackage": "hackage", - "hpc-coveralls": "hpc-coveralls", - "nix-tools": "nix-tools", - "nixpkgs": [ - "haskellNix", - "nixpkgs-2105" - ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2009": "nixpkgs-2009", - "nixpkgs-2105": "nixpkgs-2105", - "nixpkgs-unstable": "nixpkgs-unstable", - "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage" - }, + "cardano-config": { + "flake": false, "locked": { - "lastModified": 1633435111, - "narHash": "sha256-0wYA9+2BZXFGj241f4W66nbvP2s+bbikOa39CZQP05A=", + "lastModified": 1634339627, + "narHash": "sha256-jQbwcfNJ8am7Q3W+hmTFmyo3wp3QItquEH//klNiofI=", "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "56f22053e647efcad0b5ee9c32334d5d4214bcde", + "repo": "cardano-config", + "rev": "e9de7a2cf70796f6ff26eac9f9540184ded0e4e6", "type": "github" }, "original": { "owner": "input-output-hk", - "repo": "haskell.nix", + "repo": "cardano-config", + "rev": "e9de7a2cf70796f6ff26eac9f9540184ded0e4e6", "type": "github" } }, - "hpc-coveralls": { + "cardano-crypto": { "flake": false, "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "lastModified": 1604244485, + "narHash": "sha256-2Fipex/WjIRMrvx6F3hjJoAeMtFd2wGnZECT0kuIB9k=", + "owner": "input-output-hk", + "repo": "cardano-crypto", + "rev": "f73079303f663e028288f9f4a9e08bcca39a923e", "type": "github" }, "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", + "owner": "input-output-hk", + "repo": "cardano-crypto", + "rev": "f73079303f663e028288f9f4a9e08bcca39a923e", "type": "github" } }, - "nix-tools": { + "cardano-ledger": { "flake": false, "locked": { - "lastModified": 1627889534, - "narHash": "sha256-9eEbK2nrRp6rYGQoBv6LO9IA/ANZpofwAkxMuGBD45Y=", + "lastModified": 1639498285, + "narHash": "sha256-lRNfkGMHnpPO0T19FZY5BnuRkr0zTRZIkxZVgHH0fys=", "owner": "input-output-hk", - "repo": "nix-tools", - "rev": "15d2e4b61cb63ff351f3c490c12c4d89eafd31a1", + "repo": "cardano-ledger", + "rev": "1a9ec4ae9e0b09d54e49b2a40c4ead37edadcce5", "type": "github" }, "original": { "owner": "input-output-hk", - "repo": "nix-tools", + "repo": "cardano-ledger", + "rev": "1a9ec4ae9e0b09d54e49b2a40c4ead37edadcce5", "type": "github" } }, - "nixpkgs-2003": { + "cardano-node": { + "inputs": { + "customConfig": "customConfig", + "haskellNix": "haskellNix", + "iohkNix": "iohkNix", + "nixpkgs": [ + "bot-plutus-interface", + "cardano-node", + "haskellNix", + "nixpkgs-2105" + ], + "utils": "utils" + }, "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "lastModified": 1640022647, + "narHash": "sha256-M+YnF7Zj/7QK2pu0T75xNVaX0eEeijtBH8yz+jEHIMM=", + "owner": "input-output-hk", + "repo": "cardano-node", + "rev": "814df2c146f5d56f8c35a681fe75e85b905aed5d", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", - "repo": "nixpkgs", + "owner": "input-output-hk", + "repo": "cardano-node", + "rev": "814df2c146f5d56f8c35a681fe75e85b905aed5d", "type": "github" } }, - "nixpkgs-2009": { + "cardano-prelude": { + "flake": false, "locked": { - "lastModified": 1624271064, - "narHash": "sha256-qns/uRW7MR2EfVf6VEeLgCsCp7pIOjDeR44JzTF09MA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "46d1c3f28ca991601a53e9a14fdd53fcd3dd8416", + "lastModified": 1617089317, + "narHash": "sha256-kgX3DKyfjBb8/XcDEd+/adlETsFlp5sCSurHWgsFAQI=", + "owner": "input-output-hk", + "repo": "cardano-prelude", + "rev": "bb4ed71ba8e587f672d06edf9d2e376f4b055555", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.09-darwin", - "repo": "nixpkgs", + "owner": "input-output-hk", + "repo": "cardano-prelude", + "rev": "bb4ed71ba8e587f672d06edf9d2e376f4b055555", "type": "github" } }, - "nixpkgs-2105": { + "cardano-shell": { + "flake": false, "locked": { - "lastModified": 1630481079, - "narHash": "sha256-leWXLchbAbqOlLT6tju631G40SzQWPqaAXQG3zH1Imw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "110a2c9ebbf5d4a94486854f18a37a938cfacbbb", + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", + "owner": "input-output-hk", + "repo": "cardano-shell", "type": "github" } }, - "nixpkgs-unstable": { + "cardano-shell_2": { + "flake": false, "locked": { - "lastModified": 1628785280, - "narHash": "sha256-2B5eMrEr6O8ff2aQNeVxTB+9WrGE80OB4+oM6T7fOcc=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6525bbc06a39f26750ad8ee0d40000ddfdc24acb", + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", + "owner": "input-output-hk", + "repo": "cardano-shell", "type": "github" } }, - "old-ghc-nix": { + "cardano-shell_3": { "flake": false, "locked": { - "lastModified": 1631092763, - "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", - "owner": "angerman", - "repo": "old-ghc-nix", - "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", "type": "github" }, "original": { - "owner": "angerman", - "ref": "master", - "repo": "old-ghc-nix", + "owner": "input-output-hk", + "repo": "cardano-shell", "type": "github" } }, - "root": { - "inputs": { - "easy-ps": "easy-ps", - "flake-utils": "flake-utils", - "haskellNix": "haskellNix", - "nixpkgs": [ - "haskellNix", + "cardano-wallet": { + "flake": false, + "locked": { + "lastModified": 1642494510, + "narHash": "sha256-A3im2IkoumUx3NzgPooaXGC18/iYxbEooMa9ho93/6o=", + "owner": "input-output-hk", + "repo": "cardano-wallet", + "rev": "a5085acbd2670c24251cf8d76a4e83c77a2679ba", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-wallet", + "rev": "a5085acbd2670c24251cf8d76a4e83c77a2679ba", + "type": "github" + } + }, + "customConfig": { + "locked": { + "lastModified": 1630400035, + "narHash": "sha256-MWaVOCzuFwp09wZIW9iHq5wWen5C69I940N1swZLEQ0=", + "owner": "input-output-hk", + "repo": "empty-flake", + "rev": "2040a05b67bf9a669ce17eca56beb14b4206a99a", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "empty-flake", + "type": "github" + } + }, + "easy-ps": { + "flake": false, + "locked": { + "lastModified": 1649768932, + "narHash": "sha256-T96xGZV2AEP07smv/L2s5U7jY1LTdJEiTnA90gJ3Fco=", + "owner": "justinwoo", + "repo": "easy-purescript-nix", + "rev": "d56c436a66ec2a8a93b309c83693cef1507dca7a", + "type": "github" + }, + "original": { + "owner": "justinwoo", + "repo": "easy-purescript-nix", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1641205782, + "narHash": "sha256-4jY7RCWUoZ9cKD8co0/4tFARpWB+57+r1bLLvXNJliY=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "b7547d3eed6f32d06102ead8991ec52ab0a4f1a7", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "locked": { + "lastModified": 1623875721, + "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_2": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_3": { + "locked": { + "lastModified": 1631561581, + "narHash": "sha256-3VQMV5zvxaVLvqqUrNz3iJelLw30mIVSfZmAaauM3dA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "7e5bf3925f6fbdfaf50a2a7ca0be2879c4261d19", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_4": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flat": { + "flake": false, + "locked": { + "lastModified": 1628771504, + "narHash": "sha256-lRFND+ZnZvAph6ZYkr9wl9VAx41pb3uSFP8Wc7idP9M=", + "owner": "input-output-hk", + "repo": "flat", + "rev": "ee59880f47ab835dbd73bea0847dab7869fc20d8", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "flat", + "rev": "ee59880f47ab835dbd73bea0847dab7869fc20d8", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc-8.6.5-iohk_2": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc-8.6.5-iohk_3": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "goblins": { + "flake": false, + "locked": { + "lastModified": 1598362523, + "narHash": "sha256-z9ut0y6umDIjJIRjz9KSvKgotuw06/S8QDwOtVdGiJ0=", + "owner": "input-output-hk", + "repo": "goblins", + "rev": "cde90a2b27f79187ca8310b6549331e59595e7ba", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "goblins", + "rev": "cde90a2b27f79187ca8310b6549331e59595e7ba", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1639098768, + "narHash": "sha256-DZ4sG8FeDxWvBLixrj0jELXjtebZ0SCCPmQW43HNzIE=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "c7b123af6b0b9b364cab03363504d42dca16a4b5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage_2": { + "flake": false, + "locked": { + "lastModified": 1644887696, + "narHash": "sha256-o4gltv4npUl7+1gEQIcrRqZniwqC9kK8QsPaftlrawc=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "6ff64aa49b88e75dd6e0bbd2823c2a92c9174fa5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage_3": { + "flake": false, + "locked": { + "lastModified": 1650157984, + "narHash": "sha256-hitutrIIn+qINGi6oef53f87we+cp3QNmXSBiCzVU90=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "2290fdc4d135407896f41ba518a0eae8efaae9c5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskell-nix": { + "inputs": { + "HTTP": "HTTP_2", + "cabal-32": "cabal-32_2", + "cabal-34": "cabal-34_2", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell_2", + "flake-utils": "flake-utils_2", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2", + "hackage": "hackage_2", + "hpc-coveralls": "hpc-coveralls_2", + "nix-tools": "nix-tools_2", + "nixpkgs": [ + "bot-plutus-interface", + "haskell-nix", "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003_2", + "nixpkgs-2105": "nixpkgs-2105_2", + "nixpkgs-2111": "nixpkgs-2111_2", + "nixpkgs-unstable": "nixpkgs-unstable_2", + "old-ghc-nix": "old-ghc-nix_2", + "stackage": "stackage_2" + }, + "locked": { + "lastModified": 1644944726, + "narHash": "sha256-jJWdP/3Ne1y1akC3m9rSO5ItRoBc4UTdVQZBCuPmmrM=", + "owner": "L-as", + "repo": "haskell.nix", + "rev": "45c583b5580c130487eb5a342679f0bdbc2b23fc", + "type": "github" + }, + "original": { + "owner": "L-as", + "repo": "haskell.nix", + "type": "github" + } + }, + "haskell-nix_2": { + "inputs": { + "HTTP": "HTTP_3", + "cabal-32": "cabal-32_3", + "cabal-34": "cabal-34_3", + "cabal-36": "cabal-36_2", + "cardano-shell": "cardano-shell_3", + "flake-utils": "flake-utils_4", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk_3", + "hackage": "hackage_3", + "hpc-coveralls": "hpc-coveralls_3", + "hydra": "hydra", + "nix-tools": "nix-tools_3", + "nixpkgs": [ + "haskell-nix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003_3", + "nixpkgs-2105": "nixpkgs-2105_3", + "nixpkgs-2111": "nixpkgs-2111_3", + "nixpkgs-unstable": "nixpkgs-unstable_3", + "old-ghc-nix": "old-ghc-nix_3", + "stackage": "stackage_3" + }, + "locked": { + "lastModified": 1650194184, + "narHash": "sha256-wwRdO075Gh+NbyTH4Gce/hxn7hKJjbNs4/YrKpOguAA=", + "owner": "mlabs-haskell", + "repo": "haskell.nix", + "rev": "cf1f0460b65efadac6dc96169ef1e497410fa4f4", + "type": "github" + }, + "original": { + "owner": "mlabs-haskell", + "repo": "haskell.nix", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cardano-shell": "cardano-shell", + "flake-utils": "flake-utils", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "hackage": "hackage", + "hpc-coveralls": "hpc-coveralls", + "nix-tools": "nix-tools", + "nixpkgs": [ + "bot-plutus-interface", + "cardano-node", + "nixpkgs" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-2111": "nixpkgs-2111", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1639098904, + "narHash": "sha256-7VrCNEaKGLm4pTOS11dt1dRL2033oqrNCfal0uONsqA=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "b18c6ce0867fee77f12ecf41dc6c67f7a59d9826", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hpc-coveralls_2": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hpc-coveralls_3": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskell-nix", + "hydra", + "nix", + "nixpkgs" ] + }, + "locked": { + "lastModified": 1646878427, + "narHash": "sha256-KtbrofMtN8GlM7D+n90kixr7QpSlVmdN+vK5CA/aRzc=", + "owner": "NixOS", + "repo": "hydra", + "rev": "28b682b85b7efc5cf7974065792a1f22203a5927", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "iohk-monitoring-framework": { + "flake": false, + "locked": { + "lastModified": 1624367860, + "narHash": "sha256-QE3QRpIHIABm+qCP/wP4epbUx0JmSJ9BMePqWEd3iMY=", + "owner": "input-output-hk", + "repo": "iohk-monitoring-framework", + "rev": "46f994e216a1f8b36fe4669b47b2a7011b0e153c", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "iohk-monitoring-framework", + "rev": "46f994e216a1f8b36fe4669b47b2a7011b0e153c", + "type": "github" + } + }, + "iohk-nix": { + "flake": false, + "locked": { + "lastModified": 1643251385, + "narHash": "sha256-Czbd69lg0ARSZfC18V6h+gtPMioWDAEVPbiHgL2x9LM=", + "owner": "input-output-hk", + "repo": "iohk-nix", + "rev": "9d6ee3dcb3482f791e40ed991ad6fc649b343ad4", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "iohk-nix", + "type": "github" + } + }, + "iohk-nix_2": { + "flake": false, + "locked": { + "lastModified": 1649070135, + "narHash": "sha256-UFKqcOSdPWk3TYUCPHF22p1zf7aXQpCmmgf7UMg7fWA=", + "owner": "input-output-hk", + "repo": "iohk-nix", + "rev": "cecab9c71d1064f05f1615eead56ac0b9196bc20", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "iohk-nix", + "type": "github" + } + }, + "iohkNix": { + "inputs": { + "nixpkgs": [ + "bot-plutus-interface", + "cardano-node", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1633964277, + "narHash": "sha256-7G/BK514WiMRr90EswNBthe8SmH9tjPaTBba/RW/VA8=", + "owner": "input-output-hk", + "repo": "iohk-nix", + "rev": "1e51437aac8a0e49663cb21e781f34163c81ebfb", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "iohk-nix", + "type": "github" + } + }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1643066034, + "narHash": "sha256-xEPeMcNJVOeZtoN+d+aRwolpW8mFSEQx76HTRdlhPhg=", + "owner": "NixOS", + "repo": "nix", + "rev": "a1cd7e58606a41fcf62bf8637804cf8306f17f62", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.6.0", + "repo": "nix", + "type": "github" + } + }, + "nix-tools": { + "flake": false, + "locked": { + "lastModified": 1636018067, + "narHash": "sha256-ng306fkuwr6V/malWtt3979iAC4yMVDDH2ViwYB6sQE=", + "owner": "input-output-hk", + "repo": "nix-tools", + "rev": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "nix-tools", + "type": "github" + } + }, + "nix-tools_2": { + "flake": false, + "locked": { + "lastModified": 1644395812, + "narHash": "sha256-BVFk/BEsTLq5MMZvdy3ZYHKfaS3dHrsKh4+tb5t5b58=", + "owner": "input-output-hk", + "repo": "nix-tools", + "rev": "d847c63b99bbec78bf83be2a61dc9f09b8a9ccc1", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "nix-tools", + "type": "github" + } + }, + "nix-tools_3": { + "flake": false, + "locked": { + "lastModified": 1649424170, + "narHash": "sha256-XgKXWispvv5RCvZzPb+p7e6Hy3LMuRjafKMl7kXzxGw=", + "owner": "input-output-hk", + "repo": "nix-tools", + "rev": "e109c94016e3b6e0db7ed413c793e2d4bdb24aa7", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "nix-tools", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1632864508, + "narHash": "sha256-d127FIvGR41XbVRDPVvozUPQ/uRHbHwvfyKHwEt5xFM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "82891b5e2c2359d7e58d08849e4c89511ab94234", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "ref": "nixos-21.05-small", + "type": "indirect" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003_2": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003_3": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1630481079, + "narHash": "sha256-leWXLchbAbqOlLT6tju631G40SzQWPqaAXQG3zH1Imw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "110a2c9ebbf5d4a94486854f18a37a938cfacbbb", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105_2": { + "locked": { + "lastModified": 1642244250, + "narHash": "sha256-vWpUEqQdVP4srj+/YLJRTN9vjpTs4je0cdWKXPbDItc=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0fd9ee1aa36ce865ad273f4f07fdc093adeb5c00", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105_3": { + "locked": { + "lastModified": 1645296114, + "narHash": "sha256-y53N7TyIkXsjMpOG7RhvqJFGDacLs9HlyHeSTBioqYU=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "530a53dcbc9437363471167a5e4762c5fcfa34a1", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1638410074, + "narHash": "sha256-MQYI4k4XkoTzpeRjq5wl+1NShsl1CKq8MISFuZ81sWs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "5b80f23502f8e902612a8c631dfce383e1c56596", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111_2": { + "locked": { + "lastModified": 1644510859, + "narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111_3": { + "locked": { + "lastModified": 1648744337, + "narHash": "sha256-bYe1dFJAXovjqiaPKrmAbSBEK5KUkgwVaZcTbSoJ7hg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0a58eebd8ec65ffdef2ce9562784123a73922052", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-regression": { + "locked": { + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "indirect" + } + }, + "nixpkgs-unstable": { + "locked": { + "lastModified": 1635295995, + "narHash": "sha256-sGYiXjFlxTTMNb4NSkgvX+knOOTipE6gqwPUQpxNF+c=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "22a500a3f87bbce73bd8d777ef920b43a636f018", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-unstable_2": { + "locked": { + "lastModified": 1644486793, + "narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1882c6b7368fd284ad01b0a5b5601ef136321292", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-unstable_3": { + "locked": { + "lastModified": 1648219316, + "narHash": "sha256-Ctij+dOi0ZZIfX5eMhgwugfvB+WZSrvVNAyAuANOsnQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "30d3d79b7d3607d56546dd2a6b49e156ba0ec634", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "old-ghc-nix_2": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "old-ghc-nix_3": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "optparse-applicative": { + "flake": false, + "locked": { + "lastModified": 1628901899, + "narHash": "sha256-uQx+SEYsCH7JcG3xAT0eJck9yq3y0cvx49bvItLLer8=", + "owner": "input-output-hk", + "repo": "optparse-applicative", + "rev": "7497a29cb998721a9068d5725d49461f2bba0e7a", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "optparse-applicative", + "rev": "7497a29cb998721a9068d5725d49461f2bba0e7a", + "type": "github" + } + }, + "ouroboros-network": { + "flake": false, + "locked": { + "lastModified": 1639752881, + "narHash": "sha256-fZ6FfG2z6HWDxjIHycLPSQHoYtfUmWZOX7lfAUE+s6M=", + "owner": "input-output-hk", + "repo": "ouroboros-network", + "rev": "d2d219a86cda42787325bb8c20539a75c2667132", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "ouroboros-network", + "rev": "d2d219a86cda42787325bb8c20539a75c2667132", + "type": "github" + } + }, + "plutus": { + "flake": false, + "locked": { + "lastModified": 1642505687, + "narHash": "sha256-Pl3M9rMEoiEKRsTdDr4JwNnRo5Xs4uN66uVpOfaMCfE=", + "owner": "input-output-hk", + "repo": "plutus", + "rev": "cc72a56eafb02333c96f662581b57504f8f8992f", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "plutus", + "rev": "cc72a56eafb02333c96f662581b57504f8f8992f", + "type": "github" + } + }, + "plutus-apps": { + "flake": false, + "locked": { + "lastModified": 1644841368, + "narHash": "sha256-OX4+S7fFUqXRz935wQqdcEm1I6aqg0udSdP19XJtSAk=", + "owner": "input-output-hk", + "repo": "plutus-apps", + "rev": "7f543e21d4945a2024e46c572303b9c1684a5832", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "plutus-apps", + "rev": "7f543e21d4945a2024e46c572303b9c1684a5832", + "type": "github" + } + }, + "purescript-bridge": { + "flake": false, + "locked": { + "lastModified": 1642802224, + "narHash": "sha256-/SbnmXrB9Y2rrPd6E79Iu5RDaKAKozIl685HQ4XdQTU=", + "owner": "input-output-hk", + "repo": "purescript-bridge", + "rev": "47a1f11825a0f9445e0f98792f79172efef66c00", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "purescript-bridge", + "rev": "47a1f11825a0f9445e0f98792f79172efef66c00", + "type": "github" + } + }, + "root": { + "inputs": { + "bot-plutus-interface": "bot-plutus-interface", + "easy-ps": "easy-ps", + "flake-utils": "flake-utils_3", + "haskell-nix": "haskell-nix_2", + "iohk-nix": "iohk-nix_2" + } + }, + "servant-purescript": { + "flake": false, + "locked": { + "lastModified": 1642798070, + "narHash": "sha256-DH9ISydu5gxvN4xBuoXVv1OhYCaqGOtzWlACdJ0H64I=", + "owner": "input-output-hk", + "repo": "servant-purescript", + "rev": "44e7cacf109f84984cd99cd3faf185d161826963", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "servant-purescript", + "rev": "44e7cacf109f84984cd99cd3faf185d161826963", + "type": "github" } }, "stackage": { "flake": false, "locked": { - "lastModified": 1633224172, - "narHash": "sha256-Hw2jWJiS6ky0D5BhSyaw5PItzmTpRni4BUcCJmbESWk=", + "lastModified": 1639012797, + "narHash": "sha256-hiLyBa5XFBvxD+BcYPKyYd/0dNMccxAuywFNqYtIIvs=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "9ea6ea359da91c75a71e334b25aa7dc5ddc4b2c6", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "stackage_2": { + "flake": false, + "locked": { + "lastModified": 1644887829, + "narHash": "sha256-tjUXJpqB7MMnqM4FF5cdtZipfratUcTKRQVA6F77sEQ=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "db8bdef6588cf4f38e6069075ba76f0024381f68", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "stackage_3": { + "flake": false, + "locked": { + "lastModified": 1650158092, + "narHash": "sha256-uQ/TEFcce0bKmYcoBziDhYYzCDmhPsjC5WgsJjpd9wA=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "948c9bde3d0b3aa452e0b19c34ae6385ac563160", + "rev": "adc7f942e756b382a7a833520ebef6dfc859af8e", "type": "github" }, "original": { @@ -320,6 +1450,21 @@ "repo": "stackage.nix", "type": "github" } + }, + "utils": { + "locked": { + "lastModified": 1638122382, + "narHash": "sha256-sQzZzAbvKEqN9s0bzWuYmRaA03v40gaJ4+iL1LXjaeI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "74f7e4319258e287b0f9cb95426c9853b282730b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 67527868..0293ea5b 100644 --- a/flake.nix +++ b/flake.nix @@ -1,50 +1,71 @@ { description = "Generate PureScript data types from Haskell data types"; - inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; - inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; - inputs.flake-utils.url = "github:numtide/flake-utils"; - inputs.easy-ps = { - url = "github:justinwoo/easy-purescript-nix"; - flake = false; + nixConfig.bash-prompt = "\\[\\e[0m\\][\\[\\e[0;2m\\]nix-develop \\[\\e[0;1m\\]purescript-bridge \\[\\e[0;93m\\]\\w\\[\\e[0m\\]]\\[\\e[0m\\]$ \\[\\e[0m\\]"; + inputs = { + haskell-nix.url = "github:mlabs-haskell/haskell.nix"; + flake-utils.url = "github:numtide/flake-utils"; + easy-ps = { + url = "github:justinwoo/easy-purescript-nix"; + flake = false; + }; + + # Needed for crypto overlay + iohk-nix = { + url = "github:input-output-hk/iohk-nix"; + flake = false; + }; + + # We're reusing inputs from bot-plutus-interface as it's currently the source of nix truth. + bot-plutus-interface.url = "github:mlabs-haskell/bot-plutus-interface"; + }; - outputs = { self, nixpkgs, flake-utils, haskellNix, easy-ps }: + + outputs = inputs@{ self, flake-utils, ... }: flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: let - overlays = [ - haskellNix.overlay - (final: prev: { - # This overlay adds our project to pkgs - purescript-bridge = - final.haskell-nix.project' { - src = ./.; - compiler-nix-name = "ghc8107"; - }; - }) - ]; - pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; - flake = pkgs.purescript-bridge.flake { }; + # TODO: Perhaps cleanSource + src = ./.; + + # Nixpkgs from bot-plutus-interface + inherit (inputs.bot-plutus-interface.inputs) nixpkgs; + + # Reliably cached + pkgs = import nixpkgs { inherit system; }; + + easy-ps = import inputs.easy-ps { inherit pkgs; }; + pursBridgeHsProjectFor = system: import ./nix/haskell.nix { + inherit src system pkgs easy-ps; + inputs = inputs // inputs.bot-plutus-interface.inputs; + extraSources = inputs.bot-plutus-interface.extraSources; + }; + pursBridgeFlakeFor = system: (pursBridgeHsProjectFor system).flake { }; + cq = import ./nix/code-quality.nix { projectName = ""; inherit pkgs easy-ps; }; + fileCheckers = cq.checkers pkgs; in - flake // { - # Built by `nix build .` - defaultPackage = flake.packages."purescript-bridge:test:purescript-bridge"; - devShell = pkgs.purescript-bridge.shellFor { - withHoogle = true; - tools = { - cabal = "latest"; - hlint = "latest"; - haskell-language-server = "latest"; - }; - - exactDeps = true; - - buildInputs = with pkgs; with import easy-ps { inherit pkgs; }; [ - ghcid - nixpkgs-fmt - purs - purescript-language-server - spago - haskellPackages.ormolu - ]; + { + # Useful attributes + inherit pkgs; + pursBridgeFlake = pursBridgeFlakeFor system; + + # Flake standard attributes + packages = self.pursBridgeFlake.${system}.packages; + checks = self.pursBridgeFlake.${system}.checks; + devShells = { + "default" = self.pursBridgeFlake.${system}.devShell; }; - }); + + # Fix files + fix-files = cq.format; + + # Used by CI + build-all = pkgs.runCommand "build-all" + (self.packages.${system} // self.devShells.${system}) + "touch $out"; + + check-files = pkgs.runCommand "check-files" + (builtins.mapAttrs (_: v: v src) fileCheckers) + "touch $out"; + + } + ); } diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..ed2de01b --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 2 +comma-style: leading +record-brace-space: true +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 00000000..04cd2439 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/nix/code-quality.nix b/nix/code-quality.nix new file mode 100644 index 00000000..afb21659 --- /dev/null +++ b/nix/code-quality.nix @@ -0,0 +1,155 @@ +{ projectName, pkgs, easy-ps }: +let + + # Recursively build script contents from a list of script addresses. They get + # concatenated sequentially. + mkScriptContents = sPs: + if sPs == [ ] + then "" + else (with builtins;(readFile (head sPs)) + "\n" + (mkScriptContents (tail sPs))); + + # Util fn. + makeCIAction = { action, scriptPaths, buildInputsAdditional }: + pkgs.symlinkJoin rec { + + name = "${action}-${projectName}"; + + scriptContents = mkScriptContents scriptPaths; + + script = + (pkgs.writeScriptBin name scriptContents).overrideAttrs + (old: { + buildCommand = '' + ${old.buildCommand} + patchShebangs $out''; + }); + + paths = [ script ] ++ buildInputs; + + buildInputs = [ pkgs.makeWrapper ] ++ buildInputsAdditional; + + postBuild = '' + wrapProgram $out/bin/${name} \ + --prefix PATH : $out/bin \ + --prefix PATH : $out/lib/node_modules/.bin + ''; + + }; + dependencies = { + + format = [ + pkgs.haskellPackages.fourmolu + pkgs.haskellPackages.cabal-fmt + pkgs.nixpkgs-fmt + pkgs.shfmt + pkgs.dhall + easy-ps.purs-tidy + ]; + + lint = [ + pkgs.hlint + pkgs.haskellPackages.apply-refact + pkgs.shellcheck + ]; + }; + + # Shell scripts. + sScript = { + format = ./scripts/format.sh; + lint-inplace = ./scripts/lint-inplace.sh; + }; +in +{ + "format" = makeCIAction { + action = "format"; + scriptPaths = [ sScript.format ]; + buildInputsAdditional = dependencies.format; + }; + + "lint-inplace" = makeCIAction { + action = "lint-inplace"; + scriptPaths = [ sScript.lint-inplace ]; + buildInputsAdditional = dependencies.lint; + }; + + "format-lint" = makeCIAction { + action = "format-lint"; + scriptPaths = [ sScript.format sScript.lint-inplace ]; + buildInputsAdditional = dependencies.lint ++ dependencies.format; + }; + + + checkers = pkgs: + let + nixpkgs-fmt = pkgs.nixpkgs-fmt; + fourmolu = pkgs.haskellPackages.fourmolu; + hlint = pkgs.hlint; + cabal-fmt = pkgs.haskellPackages.cabal-fmt; + shfmt = pkgs.shfmt; + shellcheck = pkgs.shellcheck; + dhall = pkgs.dhall; + purs-tidy = easy-ps.purs-tidy; + + in + { + checkNixFiles = src: pkgs.runCommand "check-nix-files" { } + '' + touch $out + echo "Check Nix files" + NIX_FILES=$(find ${src} -name "*.nix") + ${nixpkgs-fmt}/bin/nixpkgs-fmt --check $NIX_FILES + ''; + + checkHaskellFiles = src: pkgs.runCommand "check-haskell-files" { } + '' + touch $out + echo "Check Haskell files" + EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -XBangPatterns -o -fplugin=RecordDotPreprocessor" + HASKELL_FILES=$(find ${src} -name "*.hs") + ${fourmolu}/bin/fourmolu --mode check --check-idempotence $EXTENSIONS $HASKELL_FILES + if [ $? -ne 0 ]; then + echo "Fourmolu complained." + exit 1 + fi + EXTENSIONS="-XTypeApplications -XTemplateHaskell -XImportQualifiedPost -XPatternSynonyms -XBangPatterns" + ${hlint}/bin/hlint $EXTENSIONS $HASKELL_FILES + ''; + + checkCabalFiles = src: pkgs.runCommand "check-cabal-files" { } + '' + touch $out + echo "Check Cabal files" + CABAL_FILES=$(find ${src} -name "*.cabal") + ${cabal-fmt}/bin/cabal-fmt --check $CABAL_FILES + ''; + + checkShellFiles = src: pkgs.runCommand "check-shell-files" { } + '' + touch $out + echo "Check Shell files" + SHELL_FILES=$(find ${src} -name "*.sh") + ${shfmt}/bin/shfmt -d $SHELL_FILES + ${shellcheck}/bin/shellcheck $SHELL_FILES + ''; + + checkDhallFiles = src: pkgs.runCommand "check-dhall-files" { } + '' + touch $out + echo "Check Dhall files" + DHALL_FILES=$(find ${src} -name "*.dhall") + ${dhall}/bin/dhall format --check $DHALL_FILES + ''; + + checkPurescriptFiles = src: pkgs.runCommand "check-purescript-files" { } + '' + touch $out + echo "Check Purescript files" + PURS_FILES=$(find ${src} -name "*.purs") + ${purs-tidy}/bin/purs-tidy check $PURS_FILES + ''; + }; +} + + + + diff --git a/nix/haskell.nix b/nix/haskell.nix new file mode 100644 index 00000000..5ea8adb7 --- /dev/null +++ b/nix/haskell.nix @@ -0,0 +1,109 @@ +{ src, system, pkgs, easy-ps, inputs, extraSources }: +let + # Poor caching due to overlay + pkgs' = import inputs.nixpkgs { + overlays = + [ inputs.haskell-nix.overlay (import "${inputs.iohk-nix}/overlays/crypto") ]; + inherit system; + inherit (inputs.haskell-nix) config; + }; +in +pkgs'.haskell-nix.cabalProject' { + inherit src; + compiler-nix-name = "ghc8107"; + cabalProjectFileName = "cabal.project"; + modules = [ + ({ config, ... }: { + packages = { + allComponent.doHoogle = true; + + # Massaging the compilation + plutus-ledger.doHaddock = false; + plutus-ledger.flags.defer-plugin-errors = false; + plutus-contract.doHaddock = false; + plutus-contract.flags.defer-plugin-errors = false; + plutus-use-cases.doHaddock = false; + plutus-use-cases.flags.defer-plugin-errors = false; + + cardano-crypto-praos.components.library.pkgconfig = + pkgs'.lib.mkForce [ [ pkgs'.libsodium-vrf ] ]; + + cardano-crypto-class.components.library.pkgconfig = + pkgs'.lib.mkForce [ [ pkgs'.libsodium-vrf ] ]; + + cardano-wallet-core.components.library.build-tools = + [ pkgs'.buildPackages.buildPackages.gitMinimal ]; + + cardano-config.components.library.build-tools = + [ pkgs'.buildPackages.buildPackages.gitMinimal ]; + + # Required for Spago based `around` tests + purescript-bridge.components.tests.tests.build-tools = + [ + easy-ps.purs-0_14_5 + easy-ps.spago + pkgs.nodejs-12_x + ]; + + # Don't build in dev + # TODO: Add purescript-bridge.components.library.configureFlags = [ dev ]; + + }; + + }) + ]; + + inherit extraSources; + + shell = { + + withHoogle = true; + + exactDeps = true; + + # We use the ones from Nixpkgs, since they are cached reliably. + # Eventually we will probably want to build these with haskell.nix. + nativeBuildInputs = with pkgs; [ + # Building code + cabal-install + easy-ps.spago + easy-ps.spago2nix + easy-ps.psc-package + dhall + pkgs.nodejs-12_x # includes npm + nodePackages.node2nix + easy-ps.purs-0_14_5 + # Code assistance + easy-ps.purescript-language-server + easy-ps.pscid + dhall-lsp-server + # Code quality + # Haskell/Cabal + hlint + haskellPackages.fourmolu + haskellPackages.hasktags + haskellPackages.cabal-fmt + haskellPackages.apply-refact + # Nix + nixpkgs-fmt + # Shell + shellcheck + shfmt + # Purescript + easy-ps.purs-tidy + # JSON + nodePackages.jsonlint + ]; + + # Add here so `cabal build` can find them + additional = ps: [ ps.plutus-tx ps.plutus-ledger-api ]; + + tools = { haskell-language-server = "latest"; }; + + shellHook = '' + export LC_CTYPE=C.UTF-8 + export LC_ALL=C.UTF-8 + export LANG=C.UTF-8 + ''; + }; +} diff --git a/nix/purescript-flake.nix b/nix/purescript-flake.nix new file mode 100644 index 00000000..60ef4271 --- /dev/null +++ b/nix/purescript-flake.nix @@ -0,0 +1,87 @@ +{ name +, src +, pursSubDirs ? [ /src /test ] +, pkgs +, system +, easy-ps +, spagoPkgs +, spagoLocalPkgs ? [ ] +, nodejs +, nodePkgs +, purs ? easy-ps.purs-0_14_5 +}: + +let + nodePkgs' = nodePkgs // { + shell = nodePkgs.shell.override { + # see https://github.com/svanderburg/node2nix/issues/198 + buildInputs = [ pkgs.nodePackages.node-gyp-build ]; + }; + }; + nodeModules = nodePkgs'.shell.nodeDependencies; + ps-lib = import ./purescript-lib.nix { + inherit pkgs spagoPkgs spagoLocalPkgs nodejs nodeModules purs; + spago = easy-ps.spago; + }; + projectDir = src; +in +rec { + defaultPackage = packages.${system}.${name}; + + packages.${name} = ps-lib.buildPursProject { + inherit projectDir pursSubDirs; + }; + packages."${name}-bundle-commonjs" = ps-lib.bundlePursProjectCommonJs { + inherit projectDir pursSubDirs; + }; + + checks."${name}-check" = ps-lib.runPursTest { + inherit projectDir pursSubDirs; + }; + + check = pkgs.runCommand "combined-check" + { + nativeBuildInputs = builtins.attrValues packages.${name}; + + } "touch $out"; + + devShell = pkgs.mkShell { + buildInputs = (with easy-ps; [ + spago + purs-tidy + purescript-language-server + pscid + spago2nix + psc-package + ]) ++ (with pkgs; [ + dhall + dhall-lsp-server + nodejs # includes npm + nodePackages.node2nix + nodePackages.jsonlint + ]) ++ [ purs ]; + + inherit nodeModules spagoLocalPkgs; + + phases = [ "installPhase" ]; + installPhase = ''touch $out''; + + shellHook = '' + export XDG_CACHE_HOME=$TMPDIR + export XDG_RUNTIME_DIR=$TMPDIR + + echo "Setting up Nodejs dependencies" + ln -s $nodeModules/lib/node_modules $TMPDIR/node_modules + export NODE_PATH="$TMPDIR/node_modules:$NODE_PATH" + export PATH="$nodeModules/bin:$PATH" + + echo "Setting up local Spago packages" + mkdir $TMPDIR/spagoLocals + for slp in $spagoLocalPkgs; do + slpName=$(dhall repl <<< "($slp/spago.dhall).name" | grep \" | tr -d '"') + ln -s $slp $TMPDIR/spagoLocals/$slpName + done + ''; + }; +} + diff --git a/nix/purescript-lib.nix b/nix/purescript-lib.nix new file mode 100644 index 00000000..57ff8e34 --- /dev/null +++ b/nix/purescript-lib.nix @@ -0,0 +1,86 @@ +{ pkgs +, spago +, spagoPkgs +, spagoLocalPkgs ? [ ] +, nodejs +, purs +, nodeModules +}: +rec { + pursFilterSource = pursDirs: builtins.filterSource (path: type: type == "regular" && builtins.elem (builtins.baseNameOf path) pursDirs) ./.; + + buildPursProject = { projectDir, pursSubDirs ? [ /src /test ], checkWarnings ? true }: + pkgs.stdenv.mkDerivation rec { + name = "purescript-lib-build-purs-project"; + pursDirs = (builtins.map (sd: projectDir + sd) pursSubDirs); + src = pursFilterSource pursDirs; + inherit spagoLocalPkgs; + buildInputs = with spagoPkgs; [ + installSpagoStyle + buildFromNixStore + ]; + nativeBuildInputs = [ + purs + spago + pkgs.jq + ]; + phases = [ "buildPhase" "checkPhase" "installPhase" ]; + doCheck = checkWarnings; + buildPhase = '' + install-spago-style + PURS_SOURCES=$(for pursDir in $pursDirs; do find $pursDir -name "*.purs"; done) + SPL_PURS_SOURCES=$(for slp in $spagoLocalPkgs; do find $slp -name "*.purs"; done) + build-from-store $PURS_SOURCES $SPL_PURS_SOURCES --json-errors | grep '\{\"' > errors.json || build-from-store $PURS_SOURCES $SPL_PURS_SOURCES + ''; + checkPhase = '' + touch my_errors.json + for ps in $PURS_SOURCES; do + echo "checking for $ps" + jq "(.errors[], .warnings[]) | select(.filename == \"$ps\")" errors.json >> my_errors.json + done + if [ -s my_errors.json ]; then + echo "Compilation finished with warnings/errors" + cat my_errors.json + exit 1 + fi + ''; + installPhase = '' + mkdir $out + mv errors.json $out/ + mv output $out/ + mv .spago $out/ + ''; + }; + + runPursTest = args: + let + pursProject = buildPursProject args; + in + pkgs.stdenv.mkDerivation { + name = "purescript-lib-run-purs-test"; + src = pursFilterSource [ ]; + inherit pursProject nodeModules; + doCheck = true; + buildInputs = [ nodejs ]; + checkPhase = '' + export NODE_PATH=${nodeModules}/lib/node_modules + node -e 'require("${pursProject}/output/Test.Main").main()' > out.log + ''; + installPhase = '' + cp out.log $out + ''; + }; + bundlePursProjectCommonJs = args: + let + pursProject = buildPursProject args; + in + pkgs.stdenv.mkDerivation { + name = "purescript-lib-bundle-purs-project-common-js"; + src = pursFilterSource [ ]; + buildInputs = [ spago purs ]; + installPhase = '' + ln -s ${pursProject}/output output + spago --global-cache skip bundle-module --no-install --no-build --to $out + ''; + }; +} diff --git a/nix/scripts/format.sh b/nix/scripts/format.sh new file mode 100755 index 00000000..28bbab04 --- /dev/null +++ b/nix/scripts/format.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash +echo "Format Haskell files" +# Extensions necessary to tell fourmolu about +EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -XBangPatterns -o -fplugin=RecordDotPreprocessor" +HASKELL_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') +fourmolu -i $EXTENSIONS $HASKELL_FILES + +echo "Format Cabal files" +CABAL_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal') +cabal-fmt --inplace $CABAL_FILES + +echo "Format Nix files" +NIX_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix') +nixpkgs-fmt $NIX_FILES + +echo "Format Shell files" +SHELL_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.sh$') +shfmt -w $SHELL_FILES + +echo "Format Dhall files" +DHALL_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.dhall') +dhall format $DHALL_FILES + +echo "Format Purescript files" +PURS_FILES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.purs') +purs-tidy format-in-place $PURS_FILES diff --git a/nix/scripts/lint-inplace.sh b/nix/scripts/lint-inplace.sh new file mode 100755 index 00000000..8d01f69d --- /dev/null +++ b/nix/scripts/lint-inplace.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +echo "Linting Haskell files and replacing them inplace." + +# Extensions necessary to tell hlint about +EXTENSIONS="-XTypeApplications -XTemplateHaskell -XImportQualifiedPost -XPatternSynonyms -XBangPatterns" +SOURCES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') + +hlint $EXTENSIONS $SOURCES + +if [ $? -eq 1 ]; then + echo $SOURCES | xargs -t -n 1 hlint --refactor --refactor-options="--inplace" $EXTENSIONS +fi diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 68429d10..eec814ac 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -1,8 +1,4 @@ --- Initial purescript-bridge.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: purescript-bridge +name: purescript-bridge -- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. @@ -10,109 +6,224 @@ name: purescript-bridge -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.14.0.0 +version: 0.14.0.0 -- A short (one-line) description of the package. -synopsis: Generate PureScript data types from Haskell data types +synopsis: Generate PureScript data types from Haskell data types -- A longer description of the package. -- description: -- The license under which the package is released. -license: BSD3 +license: BSD3 -- The file containing the license text. -license-file: LICENSE +license-file: LICENSE -- The package author(s). -author: Robert Klotzner +author: Robert Klotzner -- An email address to which users can send suggestions, bug reports, and -- patches. -maintainer: robert . klotzner A T gmx . at +maintainer: robert . klotzner A T gmx . at -- A copyright notice. -- copyright: -category: Web - -build-type: Simple +category: Web +build-type: Simple -- Extra files to be distributed with the package, such as examples or a -- README. -- extra-source-files: -- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - +cabal-version: >=1.10 extra-source-files: README.md -source-repository head - type: git - location: https://github.com/eskimor/purescript-bridge.git - library -- Modules exported by the library. - exposed-modules: Language.PureScript.Bridge - , Language.PureScript.Bridge.CodeGenSwitches - , Language.PureScript.Bridge.Builder - , Language.PureScript.Bridge.Primitives - , Language.PureScript.Bridge.Printer - , Language.PureScript.Bridge.PSTypes - , Language.PureScript.Bridge.SumType - , Language.PureScript.Bridge.Tuple - , Language.PureScript.Bridge.TypeInfo - , Language.PureScript.Bridge.TypeParameters + exposed-modules: + Language.PureScript.Bridge + Language.PureScript.Bridge.Builder + Language.PureScript.Bridge.CodeGenSwitches + Language.PureScript.Bridge.Plutus + Language.PureScript.Bridge.Primitives + Language.PureScript.Bridge.Printer + Language.PureScript.Bridge.PSTypes + Language.PureScript.Bridge.SumType + Language.PureScript.Bridge.Tuple + Language.PureScript.Bridge.TypeInfo + Language.PureScript.Bridge.TypeParameters + PlutusTx.Aux -- Modules included in this library but not exported. -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: + default-extensions: + NoStarIsType + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GADTSyntax + GeneralisedNewtypeDeriving + HexFloatLiterals + ImplicitPrelude + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MonomorphismRestriction + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + PostfixOperators + RankNTypes + RelaxedPolyRec + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TraditionalRecordSyntax + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + ViewPatterns -- Other library packages from which modules are imported. - build-depends: base >=4.8 && < 6.0 - , containers - , directory - , filepath - , mtl - , lens - , text - , transformers - , wl-pprint-text - , generic-deriving - - ghc-options: -Wall - -fwarn-incomplete-patterns - -Werror + build-depends: + base >=4.8 && <6.0 + , containers + , directory + , filepath + , generic-deriving + , lens + , mtl + , plutus-ledger-api + , plutus-tx + , template-haskell + , text + , th-abstraction + , transformers + , wl-pprint-text + + ghc-options: -Wall -fwarn-incomplete-patterns -Werror -- Directories containing source files. - hs-source-dirs: src + hs-source-dirs: src -- Base language which the package is written in. - default-language: Haskell2010 - - -Test-Suite tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: TestData - , RoundTrip.Spec - , RoundTrip.Types - build-depends: aeson - , bytestring - , HUnit - , base - , containers - , directory - , hspec - , hspec-expectations-pretty-diff - , process - , purescript-bridge - , QuickCheck - , text - , utf8-string - , wl-pprint-text - - hs-source-dirs: test - default-language: Haskell2010 + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + RoundTrip.Spec + RoundTrip.Types + TestData + + default-extensions: + NoStarIsType + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GADTSyntax + GeneralisedNewtypeDeriving + HexFloatLiterals + ImplicitPrelude + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MonomorphismRestriction + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + PostfixOperators + RankNTypes + RelaxedPolyRec + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TraditionalRecordSyntax + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + ViewPatterns + + build-depends: + aeson + , base + , bytestring + , containers + , directory + , hspec + , hspec-expectations + , HUnit + , process + , purescript-bridge + , QuickCheck + , text + , utf8-string + , wl-pprint-text + + hs-source-dirs: test + + -- Initial purescript-bridge.cabal generated by cabal init. For further + -- documentation, see http://haskell.org/cabal/users-guide/ + + -- The name of the package. + default-language: Haskell2010 diff --git a/result b/result new file mode 120000 index 00000000..d99c2030 --- /dev/null +++ b/result @@ -0,0 +1 @@ +/nix/store/cmqfalnirz6yvf5q10qhsl30wd2p70kf-check-files \ No newline at end of file diff --git a/shell.nix b/shell.nix index 3f54dc34..677057c9 100644 --- a/shell.nix +++ b/shell.nix @@ -1,8 +1,11 @@ -(import ( - fetchTarball { - url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz"; - sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; } -) { - src = ./.; -}).shellNix.default +(import + ( + fetchTarball { + url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz"; + sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; + } + ) + { + src = ./.; + }).shellNix.default diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 966344c7..a1574db9 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -3,95 +3,278 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Language.PureScript.Bridge - ( bridgeSumType, - defaultBridge, - module Bridge, - writePSTypes, - writePSTypesWith, - defaultSwitch, - noLenses, - genLenses, - ) -where - -import Data.Bifunctor (Bifunctor(second)) -import Control.Applicative +module Language.PureScript.Bridge ( + bridgeSumType, + defaultBridge, + module Bridge, + writePSTypes, + writePSTypesWith, + defaultSwitch, + noLenses, + genLenses, +) where + +import Control.Applicative (Alternative ((<|>))) import Control.Lens (over, traversed) -import qualified Data.Map as M -import qualified Data.Set as Set -import qualified Data.Text.IO as T -import Language.PureScript.Bridge.Builder as Bridge -import Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.Primitives as Bridge -import Language.PureScript.Bridge.Printer as Bridge -import Language.PureScript.Bridge.SumType as Bridge -import Language.PureScript.Bridge.Tuple as Bridge -import Language.PureScript.Bridge.TypeInfo as Bridge - --- | Your entry point to this library and quite likely all you will need. --- Make sure all your types derive `Generic` and `Typeable`. --- Typeable is not needed from ghc-7.10 on. --- --- Then list all your types you want to use in PureScript and call 'writePSTypes': --- --- > data Foo = Foo { ... } deriving (Eq, Generic) --- > data Bar = A | B | C deriving (Eq, Ord, Generic) --- > data Baz = ... deriving (Generic) --- > --- > -- | All types will have a `Generic` instance produced in Purescript. --- > myTypes :: [SumType 'Haskell] --- > myTypes = --- > [ equal (mkSumType @Foo) -- Also produce a `Eq` instance. --- > , order (mkSumType @Bar) -- Produce both `Eq` and `Ord`. --- > , mkSumType @Baz -- Just produce a `Generic` instance. --- > ] --- > --- > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes --- --- You can define your own type bridges based on 'defaultBridge': --- --- --- > myBridge = defaultBridge <|> mySpecialTypeBridge --- --- and use it with 'writePSTypes': --- --- > writePSTypes "path/to/your/purescript/project" (buildBridge myBridge) myTypes --- --- Find examples for implementing your own bridges in: "Language.PureScript.Bridge.Primitives". --- --- == Result: --- 'writePSTypes' will write out PureScript modules to the given path, mirroring the hierarchy of the Haskell modules --- the types came from. In addition a list of needed PS packages is printed to the console. --- --- The list of needed packages is retrieved from the bridged 'TypeInfo' data, so make sure you set '_typePackage' correctly --- in your own bridges, in order for this feature to be useful. --- --- == Real world usage example (at time of this writing outdated, at time of reading hopefully fixed): --- A real world use case of this library can be found . --- --- With custom bridges defined and --- custom PS types defined . --- --- Parts of the generated output can be found . --- --- Note how 'Secret' and 'Key' --- get translated according to our custom rules, with correct imports and everything. --- Also the formatting is quite nice, would you have guessed that this code was generated? --- --- == /WARNING/: --- This function overwrites files - make backups or use version control! +import Data.Bifunctor (Bifunctor (second)) +import Data.Map qualified as M +import Data.Set qualified as Set +import Data.Text.IO qualified as T +import Language.PureScript.Bridge.Builder as Bridge ( + BridgeBuilder, + BridgeData, + BridgePart, + FixUpBridge, + FixUpBuilder, + FullBridge, + buildBridge, + buildBridgeWithCustomFixUp, + clearPackageFixUp, + doCheck, + errorFixUp, + fullBridge, + psTypeParameters, + (<|>), + (^==), + ) +import Language.PureScript.Bridge.CodeGenSwitches as Switches ( + Settings (generateLenses), + Switch, + defaultSwitch, + genLenses, + getSettings, + noLenses, + ) +import Language.PureScript.Bridge.Primitives as Bridge ( + boolBridge, + doubleBridge, + dummyBridge, + eitherBridge, + intBridge, + listBridge, + mapBridge, + maybeBridge, + noContentBridge, + setBridge, + stringBridge, + textBridge, + unitBridge, + ) +import Language.PureScript.Bridge.Printer as Bridge ( + Module (..), + Modules, + PSModule, + branch, + caseOf, + case_of, + constrainWith, + constructor, + constructorOptics, + constructorPattern, + constructorToDecode, + constructorToDoc, + constructorToOptic, + decodeJsonConstraints, + def, + encloseHsep, + encloseVsep, + encodeJsonConstraints, + eqConstraints, + field, + fieldSignature, + fieldSignatures, + fields, + flattenTuple, + genericsImports, + hasUnderscore, + hrecord, + importLineToText, + instanceToQualifiedImports, + instances, + instancesToImportLines, + instancesToQualifiedImports, + isEnum, + iso, + lambda, + lensImports, + memberToMethod, + mergeImportLines, + mkType, + moduleToText, + newtypeIso, + normalExpr, + normalLabels, + normalPattern, + nullaryExpr, + nullaryPattern, + ordConstraints, + pattern', + printModule, + prism, + qualifiedImportToText, + recordEntryToLens, + recordOptics, + recordPattern, + renderText, + showConstraints, + signature, + signature', + sumTypeToDecode, + sumTypeToDocs, + sumTypeToEncode, + sumTypeToModule, + sumTypeToNeededPackages, + sumTypeToOptics, + sumTypeToTypeDecls, + sumTypesToModules, + sumTypesToNeededPackages, + typeInfoToDecl, + typeInfoToDoc, + typeParams, + typeToDecode, + typeToEncode, + typeToImportLines, + typesToImportLines, + typesToRecord, + unionImportLine, + unionImportLines, + unionModules, + unionQualifiedImports, + unlessM, + vrecord, + ) +import Language.PureScript.Bridge.SumType as Bridge ( + CustomInstance (..), + DataConstructor (..), + DataConstructorArgs (..), + GDataConstructor (..), + GDataConstructorArgs (..), + ImportLine (..), + ImportLines, + Instance (..), + InstanceImplementation (..), + InstanceMember (..), + PSInstance, + RecordEntry (..), + SumType (..), + argonaut, + constraintToType, + constructorToTypes, + customConstraints, + customHead, + customImplementation, + equal, + equal1, + extremelyUnsafeMkSumType, + functor, + genericShow, + getUsedTypes, + implementationToTypes, + importsFromList, + instanceToImportLines, + instanceToTypes, + memberBindings, + memberBody, + memberDependencies, + memberImportLines, + memberName, + mkSumType, + mkSumTypeIndexed, + nootype, + order, + recLabel, + recValue, + sigConstructor, + sigValues, + sumTypeConstructors, + sumTypeInfo, + ) +import Language.PureScript.Bridge.Tuple as Bridge ( + TupleParserState (..), + isTuple, + step, + tupleBridge, + ) +import Language.PureScript.Bridge.TypeInfo as Bridge ( + HasHaskType (..), + HaskellType, + Language (..), + PSType, + TypeInfo (..), + flattenTypeInfo, + mkTypeInfo, + mkTypeInfo', + typeModule, + typeName, + typePackage, + typeParameters, + ) + +{- +| Your entry point to this library and quite likely all you will need. + Make sure all your types derive `Generic` and `Typeable`. + Typeable is not needed from ghc-7.10 on. + + Then list all your types you want to use in PureScript and call 'writePSTypes': + + > data Foo = Foo { ... } deriving (Eq, Generic) + > data Bar = A | B | C deriving (Eq, Ord, Generic) + > data Baz = ... deriving (Generic) + > + > -- | All types will have a `Generic` instance produced in Purescript. + > myTypes :: [SumType 'Haskell] + > myTypes = + > [ equal (mkSumType @Foo) -- Also produce a `Eq` instance. + > , order (mkSumType @Bar) -- Produce both `Eq` and `Ord`. + > , mkSumType @Baz -- Just produce a `Generic` instance. + > ] + > + > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes + + You can define your own type bridges based on 'defaultBridge': + + > myBridge = defaultBridge <|> mySpecialTypeBridge + + and use it with 'writePSTypes': + + > writePSTypes "path/to/your/purescript/project" (buildBridge myBridge) myTypes + + Find examples for implementing your own bridges in: "Language.PureScript.Bridge.Primitives". + + == Result: + 'writePSTypes' will write out PureScript modules to the given path, mirroring the hierarchy of the Haskell modules + the types came from. In addition a list of needed PS packages is printed to the console. + + The list of needed packages is retrieved from the bridged 'TypeInfo' data, so make sure you set '_typePackage' correctly + in your own bridges, in order for this feature to be useful. + + == Real world usage example (at time of this writing outdated, at time of reading hopefully fixed): + A real world use case of this library can be found . + + With custom bridges defined and + custom PS types defined . + + Parts of the generated output can be found . + + Note how 'Secret' and 'Key' + get translated according to our custom rules, with correct imports and everything. + Also the formatting is quite nice, would you have guessed that this code was generated? + + == /WARNING/: + This function overwrites files - make backups or use version control! +-} writePSTypes :: FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypes = writePSTypesWith Switches.defaultSwitch --- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code --- --- == Switches/Settings: --- --- - `noLenses` and `genLenses` to control if the `purescript-profunctor-lenses` are generated for your types --- --- == /WARNING/: --- This function overwrites files - make backups or use version control! +{- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code + + == Switches/Settings: + + - `noLenses` and `genLenses` to control if the `purescript-profunctor-lenses` are generated for your types + + == /WARNING/: + This function overwrites files - make backups or use version control! +-} writePSTypesWith :: Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypesWith switch root bridge sts = do @@ -110,17 +293,18 @@ writePSTypesWith switch root bridge sts = do (const $ Switches.generateLenses settings) (Set.singleton "purescript-profunctor-lenses") --- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. --- --- Example usage, with defaultBridge: --- --- > data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) --- --- > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) +{- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. + + Example usage, with defaultBridge: + + > data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) + + > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) +-} bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript bridgeSumType br (SumType t cs is) = SumType (br t) (map (second (bridgeConstructor br)) cs) $ bridgeInstance <$> (is <> extraInstances) - where + where bridgeInstance (Custom CustomInstance {..}) = Custom $ CustomInstance @@ -141,19 +325,23 @@ bridgeSumType br (SumType t cs is) = bridgeInstance Generic = Generic bridgeInstance Newtype = Newtype bridgeInstance HasConstrIndex = HasConstrIndex + bridgeInstance ToData = ToData + bridgeInstance FromData = FromData + bridgeMember = over (memberDependencies . traversed) br extraInstances - | not (null cs) && all (isNullary . snd) cs = [Enum, Bounded] + | not (null cs) && all (isNullary . snd) cs = [Enum, Bounded] | otherwise = [] isNullary (DataConstructor _ args) = args == Nullary --- | Default bridge for mapping primitive/common types: --- You can append your own bridges like this: --- --- > defaultBridge <|> myBridge1 <|> myBridge2 --- --- Find examples for bridge definitions in "Language.PureScript.Bridge.Primitives" and --- "Language.PureScript.Bridge.Tuple". +{- | Default bridge for mapping primitive/common types: + You can append your own bridges like this: + + > defaultBridge <|> myBridge1 <|> myBridge2 + + Find examples for bridge definitions in "Language.PureScript.Bridge.Primitives" and + "Language.PureScript.Bridge.Tuple". +-} defaultBridge :: BridgePart defaultBridge = textBridge diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index eb8bcd08..7054a5e8 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -5,80 +5,89 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens. --- --- Bridges can be built within the 'BridgeBuilder' monad. --- You can check properties of the to-be-bridged 'HaskellType' with '^==' or 'doCheck', --- you have choice ('<|>'), you can fail ('empty') and you can return a translated --- 'PSType' ('return'). The 'HaskellType' can be accessed with: --- --- > view haskType --- --- Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" -module Language.PureScript.Bridge.Builder - ( BridgeBuilder, - BridgePart, - FixUpBuilder, - FixUpBridge, - BridgeData, - fullBridge, - (^==), - doCheck, - (<|>), - psTypeParameters, - FullBridge, - buildBridge, - clearPackageFixUp, - errorFixUp, - buildBridgeWithCustomFixUp, - ) -where - -import Control.Applicative -import Control.Lens + +{- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens. + + Bridges can be built within the 'BridgeBuilder' monad. + You can check properties of the to-be-bridged 'HaskellType' with '^==' or 'doCheck', + you have choice ('<|>'), you can fail ('empty') and you can return a translated + 'PSType' ('return'). The 'HaskellType' can be accessed with: + + > view haskType + + Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" +-} +module Language.PureScript.Bridge.Builder ( + BridgeBuilder, + BridgePart, + FixUpBuilder, + FixUpBridge, + BridgeData, + fullBridge, + (^==), + doCheck, + (<|>), + psTypeParameters, + FullBridge, + buildBridge, + clearPackageFixUp, + errorFixUp, + buildBridgeWithCustomFixUp, +) where + +import Control.Applicative (Alternative (empty, (<|>))) +import Control.Lens (Getter, Lens', to, view, views, (^.)) import Control.Monad (MonadPlus, guard, mplus, mzero) -import Control.Monad.Reader.Class +import Control.Monad.Reader.Class (MonadReader) import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Language.PureScript.Bridge.TypeInfo +import Data.Text qualified as T +import Language.PureScript.Bridge.TypeInfo ( + HasHaskType (..), + HaskellType, + PSType, + TypeInfo (..), + typeModule, + typeName, + typePackage, + typeParameters, + ) newtype BridgeBuilder a = BridgeBuilder (ReaderT BridgeData Maybe a) - deriving (Functor, Applicative, Monad, MonadReader BridgeData) + deriving newtype (Functor, Applicative, Monad, MonadReader BridgeData) type BridgePart = BridgeBuilder PSType --- | Bridges to use when a 'BridgePart' returns 'Nothing' (See 'buildBridgeWithCustomFixUp'). --- --- It is similar to BridgeBuilder but does not offer choice or failure. It is used for constructing fallbacks --- if a 'BridgePart' evaluates to 'Nothing'. --- --- For type definitions you should use the more generic ('MonadReader' 'BridgeData' m) constraint. This way your code will work --- in both 'FixUpBuilder' and 'BridgeBuilder': --- --- > {-# LANGUAGE FlexibleContexts #-} --- > --- > import Control.Monad.Reader.Class --- > import Language.PureScript.Bridge.TypeInfo --- > --- > psEither :: MonadReader BridgeData m => m PSType --- > psEither = .... --- --- instead of: --- --- > psEither :: BridgePart --- > psEither = .... --- --- or --- --- > psEither :: FixUpBridge --- > psEither = .... +{- | Bridges to use when a 'BridgePart' returns 'Nothing' (See 'buildBridgeWithCustomFixUp'). + + It is similar to BridgeBuilder but does not offer choice or failure. It is used for constructing fallbacks + if a 'BridgePart' evaluates to 'Nothing'. + + For type definitions you should use the more generic ('MonadReader' 'BridgeData' m) constraint. This way your code will work + in both 'FixUpBuilder' and 'BridgeBuilder': + + > {\-# LANGUAGE FlexibleContexts #-\} + > + > import Control.Monad.Reader.Class + > import Language.PureScript.Bridge.TypeInfo + > + > psEither :: MonadReader BridgeData m => m PSType + > psEither = .... + + instead of: + + > psEither :: BridgePart + > psEither = .... + + or + + > psEither :: FixUpBridge + > psEither = .... +-} newtype FixUpBuilder a = FixUpBuilder (Reader BridgeData a) - deriving (Functor, Applicative, Monad, MonadReader BridgeData) + deriving newtype (Functor, Applicative, Monad, MonadReader BridgeData) type FixUpBridge = FixUpBuilder PSType @@ -86,64 +95,68 @@ type FullBridge = HaskellType -> PSType data BridgeData = BridgeData { -- | The Haskell type to translate. - _haskType :: HaskellType, - -- | Reference to the bridge itself, needed for translation of type constructors. + _haskType :: HaskellType + , -- | Reference to the bridge itself, needed for translation of type constructors. _fullBridge :: FullBridge } --- | By implementing the 'haskType' lens in the HasHaskType class, we are able --- to use it for both 'BridgeData' and a plain 'HaskellType', therefore --- you can use it with 'doCheck' and '^==' for checks on the complete 'HaskellType' --- value. --- --- Example: --- --- > stringBridge :: BridgePart --- > stringBridge = do --- > -- Note: we are using the HaskellType instance here: --- > haskType ^== mkTypeInfo @String --- > return psString +{- | By implementing the 'haskType' lens in the HasHaskType class, we are able + to use it for both 'BridgeData' and a plain 'HaskellType', therefore + you can use it with 'doCheck' and '^==' for checks on the complete 'HaskellType' + value. + + Example: + + > stringBridge :: BridgePart + > stringBridge = do + > -- Note: we are using the HaskellType instance here: + > haskType ^== mkTypeInfo @String + > return psString +-} instance HasHaskType BridgeData where haskType inj (BridgeData iT fB) = flip BridgeData fB <$> inj iT --- | Lens for access to the complete bridge from within our Reader monad. --- --- This is used for example for implementing 'psTypeParameters'. +{- | Lens for access to the complete bridge from within our Reader monad. + + This is used for example for implementing 'psTypeParameters'. +-} fullBridge :: Lens' BridgeData FullBridge fullBridge inj (BridgeData iT fB) = BridgeData iT <$> inj fB --- | Bridge to PureScript by simply clearing out the '_typePackage' field. --- This bridge is used by default as 'FixUpBridge' by 'buildBridge': --- --- > buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp --- --- Thus, if no bridge matches a type, it gets optimistically translated to a PureScript type --- which is idential to the Haskell type. Only the '_typePackage' field gets cleared, --- as it is very unlikely that the PureScript package is called the same as the Haskell package. --- --- Alternatively, if you are not that optimistic, you can use errorFixUp --- - which simply calls 'error' when used. --- --- > buildBridgeWithCustomFixUp errorFixUp yourBridge --- --- Of course you can also write your own 'FixUpBridge'. It works the same --- as for 'BridgePart', but you can not have choice ('<|>') or failure ('empty'). +{- | Bridge to PureScript by simply clearing out the '_typePackage' field. + This bridge is used by default as 'FixUpBridge' by 'buildBridge': + + > buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp + + Thus, if no bridge matches a type, it gets optimistically translated to a PureScript type + which is idential to the Haskell type. Only the '_typePackage' field gets cleared, + as it is very unlikely that the PureScript package is called the same as the Haskell package. + + Alternatively, if you are not that optimistic, you can use errorFixUp + - which simply calls 'error' when used. + + > buildBridgeWithCustomFixUp errorFixUp yourBridge + + Of course you can also write your own 'FixUpBridge'. It works the same + as for 'BridgePart', but you can not have choice ('<|>') or failure ('empty'). +-} clearPackageFixUp :: MonadReader BridgeData m => m PSType clearPackageFixUp = do input <- view haskType psArgs <- psTypeParameters return TypeInfo - { _typePackage = "", - _typeModule = input ^. typeModule, - _typeName = input ^. typeName, - _typeParameters = psArgs + { _typePackage = "" + , _typeModule = input ^. typeModule + , _typeName = input ^. typeName + , _typeParameters = psArgs } --- | A 'FixUpBridge' which calles 'error' when used. --- Usage: --- --- > buildBridgeWithCustomFixUp errorFixUp yourBridge +{- | A 'FixUpBridge' which calles 'error' when used. + Usage: + + > buildBridgeWithCustomFixUp errorFixUp yourBridge +-} errorFixUp :: MonadReader BridgeData m => m PSType errorFixUp = do inType <- view haskType @@ -158,18 +171,20 @@ errorFixUp = do <> "'!" return $ error $ T.unpack message --- | Build a bridge. --- --- This is a convenience wrapper for 'buildBridgeWithCustomFixUp' and should normally be sufficient. --- --- Definition: --- --- > buildBridgeWithCustomFixUp clearPackageFixUp +{- | Build a bridge. + + This is a convenience wrapper for 'buildBridgeWithCustomFixUp' and should normally be sufficient. + + Definition: + + > buildBridgeWithCustomFixUp clearPackageFixUp +-} buildBridge :: BridgePart -> FullBridge buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp --- | Takes a constructed BridgePart and makes it a total function ('FullBridge') --- by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'. +{- | Takes a constructed BridgePart and makes it a total function ('FullBridge') + by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'. +-} buildBridgeWithCustomFixUp :: FixUpBridge -> BridgePart -> FullBridge buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = let mayBridge :: HaskellType -> Maybe PSType @@ -179,29 +194,31 @@ buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = fixTypeParameters $ fromMaybe (fixBridge inType) (mayBridge inType) in bridge --- | Translate types that come from any module named "Something.TypeParameters" to lower case: --- --- Also drop the 1 at the end if present. --- This method gets called by 'buildBridge' and buildBridgeWithCustomFixUp for you - you should not need to call it. --- --- It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details. +{- | Translate types that come from any module named "Something.TypeParameters" to lower case: + + Also drop the 1 at the end if present. + This method gets called by 'buildBridge' and buildBridgeWithCustomFixUp for you - you should not need to call it. + + It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details. +-} fixTypeParameters :: TypeInfo lang -> TypeInfo lang fixTypeParameters t = if "TypeParameters" `T.isSuffixOf` _typeModule t then t - { _typePackage = "", -- Don't suggest any packages - _typeModule = "", -- Don't import any modules - _typeName = t ^. typeName . to (stripNum . T.toLower) + { _typePackage = "" -- Don't suggest any packages + , _typeModule = "" -- Don't import any modules + , _typeName = t ^. typeName . to (stripNum . T.toLower) } else t where stripNum v = fromMaybe v (T.stripSuffix "1" v) --- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>', --- which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing --- the right-hand side is used, otherwise the left-hand side. --- For usage examples see "Language.PureScript.Bridge.Primitives". +{- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>', + which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing + the right-hand side is used, otherwise the left-hand side. + For usage examples see "Language.PureScript.Bridge.Primitives". +-} instance Alternative BridgeBuilder where empty = BridgeBuilder . ReaderT $ const Nothing BridgeBuilder a <|> BridgeBuilder b = @@ -218,20 +235,22 @@ instance MonadPlus BridgeBuilder where doCheck :: Getter HaskellType a -> (a -> Bool) -> BridgeBuilder () doCheck l check = guard =<< views (haskType . l) check --- | Check parts of 'haskType' for equality: --- --- > textBridge :: BridgePart --- > textBridge = do --- > typeName ^== "Text" --- > typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" --- > return psString +{- | Check parts of 'haskType' for equality: + + > textBridge :: BridgePart + > textBridge = do + > typeName ^== "Text" + > typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" + > return psString +-} (^==) :: Eq a => Getter HaskellType a -> a -> BridgeBuilder () l ^== a = doCheck l (== a) infix 4 ^== --- | Bridge 'haskType' 'typeParameters' over to PureScript types. --- --- To be used for bridging type constructors. +{- | Bridge 'haskType' 'typeParameters' over to PureScript types. + + To be used for bridging type constructors. +-} psTypeParameters :: MonadReader BridgeData m => m [PSType] psTypeParameters = map <$> view fullBridge <*> view (haskType . typeParameters) diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index edef1d1d..93589422 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,14 +1,13 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not -module Language.PureScript.Bridge.CodeGenSwitches - ( Settings (..), - defaultSettings, - Switch, - getSettings, - defaultSwitch, - noLenses, - genLenses, - ) -where +module Language.PureScript.Bridge.CodeGenSwitches ( + Settings (..), + defaultSettings, + Switch, + getSettings, + defaultSwitch, + noLenses, + genLenses, +) where import Data.Monoid (Endo (..)) @@ -17,7 +16,7 @@ newtype Settings = Settings { -- | use purescript-profunctor-lens for generated PS-types? generateLenses :: Bool } - deriving (Eq, Show) + deriving stock (Eq, Show) -- | Settings to generate Lenses defaultSettings :: Settings diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 97d3ae04..6bc81230 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -2,15 +2,29 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -- | PureScript types to be used for bridges, e.g. in "Language.PureScript.Bridge.Primitives". module Language.PureScript.Bridge.PSTypes where import Control.Lens (view) -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.TypeInfo +import Control.Monad.Reader.Class (MonadReader) +import Language.PureScript.Bridge.Builder ( + BridgeData, + fullBridge, + psTypeParameters, + ) +import Language.PureScript.Bridge.TypeInfo ( + HasHaskType (haskType), + PSType, + TypeInfo ( + TypeInfo, + _typeModule, + _typeName, + _typePackage, + _typeParameters + ), + typeParameters, + ) -- | Uses type parameters from 'haskType' (bridged). psArray :: MonadReader BridgeData m => m PSType @@ -19,10 +33,10 @@ psArray = TypeInfo "" "Prim" "Array" <$> psTypeParameters psBool :: PSType psBool = TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Boolean", - _typeParameters = [] + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Boolean" + , _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -33,19 +47,19 @@ psEither = psInt :: PSType psInt = TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Int", - _typeParameters = [] + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] } psNumber :: PSType psNumber = TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Number", - _typeParameters = [] + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Number" + , _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -55,10 +69,10 @@ psMaybe = TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" <$> psTypeParameters psString :: PSType psString = TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "String", - _typeParameters = [] + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "String" + , _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -75,10 +89,10 @@ psTuple = do psUnit :: PSType psUnit = TypeInfo - { _typePackage = "purescript-prelude", - _typeModule = "Prelude", - _typeName = "Unit", - _typeParameters = [] + { _typePackage = "purescript-prelude" + , _typeModule = "Prelude" + , _typeName = "Unit" + , _typeParameters = [] } psMap :: MonadReader BridgeData m => m PSType diff --git a/src/Language/PureScript/Bridge/Plutus.hs b/src/Language/PureScript/Bridge/Plutus.hs new file mode 100644 index 00000000..2ec0b2c5 --- /dev/null +++ b/src/Language/PureScript/Bridge/Plutus.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Language.PureScript.Bridge.Plutus ( + HasConstrIndices (..), + mkSumTypeIndexed, +) where + +import Data.Kind (Type) +import Data.Typeable (Typeable) +import GHC.Generics (Generic (Rep)) + +import Language.PureScript.Bridge.SumType (GDataConstructor, SumType) +import Language.PureScript.Bridge.SumType qualified as PB +import Language.PureScript.Bridge.TypeInfo (Language (Haskell)) +import PlutusTx.Aux (HasConstrIndices (getConstrIndices)) + +mkSumTypeIndexed :: + forall (t :: Type). + ( Generic t + , Typeable t + , GDataConstructor (Rep t) + , HasConstrIndices t + ) => + SumType 'Haskell +mkSumTypeIndexed = PB.mkSumTypeIndexed @HasConstrIndices @t (getConstrIndices @t) diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index 1ab112ea..506bd87d 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -5,10 +5,33 @@ module Language.PureScript.Bridge.Primitives where -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo +import Control.Monad.Reader.Class (MonadReader) +import Language.PureScript.Bridge.Builder ( + BridgeData, + BridgePart, + clearPackageFixUp, + (<|>), + (^==), + ) +import Language.PureScript.Bridge.PSTypes ( + psArray, + psBool, + psEither, + psInt, + psMap, + psMaybe, + psNumber, + psSet, + psString, + psUnit, + ) +import Language.PureScript.Bridge.TypeInfo ( + HasHaskType (haskType), + PSType, + mkTypeInfo, + typeModule, + typeName, + ) boolBridge :: BridgePart boolBridge = typeName ^== "Bool" >> return psBool diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 4b6d48fa..75cf6b81 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -3,8 +3,8 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Bridge.Printer where @@ -16,68 +16,118 @@ import Data.Char (isLower) import Data.Function (on, (&)) import Data.List (groupBy, nubBy, sortBy) import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Language.PureScript.Bridge.CodeGenSwitches qualified as Switches import Language.PureScript.Bridge.PSTypes (psUnit) -import Language.PureScript.Bridge.SumType - ( CustomInstance (..), - DataConstructor (..), - DataConstructorArgs (..), - ImportLine (..), - ImportLines, - Instance (..), - InstanceImplementation (..), - InstanceMember (..), - PSInstance, - RecordEntry (..), - SumType (SumType), - getUsedTypes, - importsFromList, - instanceToImportLines, - nootype, - recLabel, - recValue, - sigConstructor, - _recLabel, - ) -import Language.PureScript.Bridge.TypeInfo - ( Language (PureScript), - PSType, - TypeInfo (TypeInfo), - flattenTypeInfo, - typeName, - _typeModule, - _typeName, - _typePackage, - _typeParameters, - ) -import System.Directory - ( createDirectoryIfMissing, - doesDirectoryExist, - ) -import System.FilePath - ( joinPath, - takeDirectory, - (), - ) -import Text.PrettyPrint.Leijen.Text hiding ((),(<$>)) +import Language.PureScript.Bridge.SumType ( + CustomInstance ( + CustomInstance, + _customConstraints, + _customHead, + _customImplementation + ), + DataConstructor (DataConstructor, _sigValues), + DataConstructorArgs (..), + ImportLine (..), + ImportLines, + Instance ( + Bounded, + Custom, + Enum, + Eq, + Eq1, + FromData, + Functor, + Generic, + GenericShow, + HasConstrIndex, + Json, + Newtype, + Ord, + ToData + ), + InstanceImplementation (Derive, DeriveNewtype, Explicit), + InstanceMember (..), + PSInstance, + RecordEntry (..), + SumType (..), + getUsedTypes, + importsFromList, + instanceToImportLines, + nootype, + recLabel, + recValue, + sigConstructor, + ) +import Language.PureScript.Bridge.TypeInfo ( + Language (PureScript), + PSType, + TypeInfo (TypeInfo), + flattenTypeInfo, + typeName, + _typeModule, + _typeName, + _typePackage, + _typeParameters, + ) +import System.Directory ( + createDirectoryIfMissing, + doesDirectoryExist, + ) +import System.FilePath ( + joinPath, + takeDirectory, + (), + ) +import Text.PrettyPrint.Leijen.Text ( + Doc, + backslash, + brackets, + char, + colon, + comma, + displayTStrict, + dquotes, + hang, + hsep, + indent, + int, + isEmpty, + lbrace, + lbracket, + line, + linebreak, + lparen, + nest, + parens, + punctuate, + rbrace, + rbracket, + renderPretty, + rparen, + softline, + text, + textStrict, + vsep, + (<+>), + ) renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 data Module (lang :: Language) = PSModule - { psModuleName :: !Text, - psImportLines :: !ImportLines, - psQualifiedImports :: !(Map Text Text), - psTypes :: ![SumType lang] + { psModuleName :: !Text + , psImportLines :: !ImportLines + , psQualifiedImports :: !(Map Text Text) + , psTypes :: ![SumType lang] } deriving (Show) @@ -91,8 +141,8 @@ sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeT unionModules :: PSModule -> PSModule -> PSModule unionModules m1 m2 = m1 - { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2), - psTypes = psTypes m1 <> psTypes m2 + { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) + , psTypes = psTypes m1 <> psTypes m2 } sumTypeToModule :: SumType 'PureScript -> Modules @@ -100,17 +150,17 @@ sumTypeToModule st@(SumType t _ is) = Map.singleton (_typeModule t) $ PSModule - { psModuleName = _typeModule t, - psImportLines = + { psModuleName = _typeModule t + , psImportLines = dropEmpty $ dropPrelude $ dropPrim $ dropSelf $ unionImportLines (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is), - psQualifiedImports = instancesToQualifiedImports is, - psTypes = [st] + (instancesToImportLines is) + , psQualifiedImports = instancesToQualifiedImports is + , psTypes = [st] } where dropEmpty = Map.delete "" @@ -148,9 +198,9 @@ instancesToImportLines = instanceToQualifiedImports :: PSInstance -> Map Text Text instanceToQualifiedImports Json = Map.fromList - [ ("Data.Argonaut.Decode.Aeson", "D"), - ("Data.Argonaut.Encode.Aeson", "E"), - ("Data.Map", "Map") + [ ("Data.Argonaut.Decode.Aeson", "D") + , ("Data.Argonaut.Encode.Aeson", "E") + , ("Data.Map", "Map") ] instanceToQualifiedImports _ = Map.empty @@ -182,10 +232,10 @@ moduleToText settings m = flip mappend "\n" $ renderText $ vsep $ - [ "-- File auto generated by purescript-bridge! --", - "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak, - "import Prelude" <> linebreak, - vsep + [ "-- File auto generated by purescript-bridge! --" + , "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak + , "import Prelude" <> linebreak + , vsep ( (importLineToText <$> allImports) <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) ) @@ -206,15 +256,15 @@ genericsImports = lensImports :: Switches.Settings -> [ImportLine] lensImports settings | Switches.generateLenses settings = - [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"], - ImportLine "Data.Lens" $ - Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'"], - ImportLine "Data.Lens.Record" $ Set.fromList ["prop"], - ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"], - ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(Nothing, Just)"] + , ImportLine "Data.Lens" $ + Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'"] + , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] + , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] + , ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] ] | otherwise = - [ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]] + [ImportLine "Data.Maybe" $ Set.fromList ["Maybe(Nothing, Just)"]] qualifiedImportToText :: Text -> Text -> Doc qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] @@ -244,10 +294,10 @@ sumTypeToTypeDecls st@(SumType t cs _) = vsep $ punctuate line $ typeDecl : instances st where typeDecl - | isJust (nootype . map snd $ cs) = mkTypeDecl "newtype" + | isJust (nootype . map snd $ cs) = mkTypeDecl "newtype" | otherwise = mkTypeDecl "data" mkTypeDecl keyword = - keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc . snd <$> cs) + keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc . snd <$> cs) typeInfoToDecl :: PSType -> Doc typeInfoToDecl (TypeInfo _ _ name params) = @@ -265,8 +315,9 @@ constructorToDoc (DataConstructor n args) = Normal ts -> NE.toList $ typeInfoToDoc <$> ts Record rs -> [vrecord $ fieldSignatures rs] --- | Given a Purescript type, generate instances for typeclass --- instances it claims to have. +{- | Given a Purescript type, generate instances for typeclass + instances it claims to have. +-} instances :: SumType 'PureScript -> [Doc] instances st@(SumType t cs is) = go <$> is where @@ -277,21 +328,21 @@ instances st@(SumType t cs is) = go <$> is mkInstance instanceHead getConstraints methods = vsep [ hsep - [ "instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead], - "where" - ], - indent 2 $ vsep methods + [ "instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + , "where" + ] + , indent 2 $ vsep methods ] mkDerivedInstance instanceHead getConstraints = hsep - [ "derive instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + [ "derive instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] ] mkDerivedNewtypeInstance instanceHead getConstraints = hsep - [ "derive newtype instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + [ "derive newtype instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] ] toKind1 (TypeInfo p m n []) = TypeInfo p m n [] toKind1 (TypeInfo p m n ps) = TypeInfo p m n $ init ps @@ -300,38 +351,47 @@ instances st@(SumType t cs is) = go <$> is Derive -> mkDerivedInstance _customHead (const _customConstraints) DeriveNewtype -> mkDerivedNewtypeInstance _customHead (const _customConstraints) Explicit members -> mkInstance _customHead (const _customConstraints) $ memberToMethod <$> members - + go ToData = + mkInstance + (mkType "ToData" [t]) + (const []) + ["toData x = genericToData x"] + go FromData = + mkInstance + (mkType "FromData" [t]) + (const []) + ["fromData pd = genericFromData pd"] go HasConstrIndex = mkInstance (mkType "HasConstrIndices" [t]) (const []) ["constrIndices _ = fromConstr2Index " <> prettyIndices cs] - where - prettyIndices :: [(Int,DataConstructor 'PureScript)] -> Doc + where + prettyIndices :: [(Int, DataConstructor 'PureScript)] -> Doc prettyIndices [] = error "empty list of indices!" prettyIndices xs = listify (map mkIndex xs) where quote :: Text -> Doc - quote = dquotes . textStrict + quote = dquotes . textStrict listify :: [Doc] -> Doc listify txts = brackets $ foldr (\(x :: Doc) (acc :: Doc) -> if isEmpty acc then x else x <> "," <> acc) "" txts mkIndex :: forall lang. (Int, DataConstructor lang) -> Doc - mkIndex (i,DataConstructor name _) = text "Tuple" <+> quote name <+> int i + mkIndex (i, DataConstructor name _) = text "Tuple" <+> quote name <+> int i go Bounded = mkInstance (mkType "Bounded" [t]) (const []) - [ "bottom = genericBottom", - "top = genericTop" + [ "bottom = genericBottom" + , "top = genericTop" ] go Enum = mkInstance (mkType "Enum" [t]) (const []) - [ "succ = genericSucc", - "pred = genericPred" + [ "succ = genericSucc" + , "pred = genericPred" ] go Json = vsep $ @@ -340,8 +400,8 @@ instances st@(SumType t cs is) = go <$> is [ mkInstance (mkType "EncodeJson" [t]) encodeJsonConstraints - ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st], - mkInstance + ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st] + , mkInstance (mkType "DecodeJson" [t]) decodeJsonConstraints [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] @@ -358,8 +418,8 @@ memberToMethod :: InstanceMember 'PureScript -> Doc memberToMethod InstanceMember {..} = hang 2 $ hsep - [ hsep $ textStrict <$> _memberName : _memberBindings <> ["="], - vsep $ textStrict <$> T.lines _memberBody + [ hsep $ textStrict <$> _memberName : _memberBindings <> ["="] + , vsep $ textStrict <$> T.lines _memberBody ] constrainWith :: Text -> PSType -> [PSType] @@ -390,18 +450,18 @@ sumTypeToEncode (SumType _ cs _) case map snd cs of [dc@(DataConstructor _ args)] -> hsep - [ "E.encode $", - if isJust (nootype [dc]) + [ "E.encode $" + , if isJust (nootype [dc]) then "unwrap" - else parens $ case_of [(constructorPattern dc, constructor args)], - hang 2 $ ">$<" <+> nest 2 (argsToEncode args) + else parens $ case_of [(constructorPattern dc, constructor args)] + , hang 2 $ ">$<" <+> nest 2 (argsToEncode args) ] - _ -> case_of (constructorToEncode . snd <$> cs) + _ -> case_of (constructorToEncode . snd <$> cs) where constructorToEncode c@(DataConstructor name args) = - ( constructorPattern c, - case args of - Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> ", contents: jsonNull }" + ( constructorPattern c + , case args of + Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> " }" Normal as -> "E.encodeTagged" <+> dquotes (textStrict name) @@ -415,8 +475,8 @@ sumTypeToEncode (SumType _ cs _) <+> argsToEncode args | otherwise -> hsep - [ "encodeJson", - vrecord $ + [ "encodeJson" + , vrecord $ ("tag:" <+> dquotes (textStrict name)) : (recordFieldToJson <$> NE.toList rs) ] @@ -464,21 +524,21 @@ typeToEncode _ = "E.value" sumTypeToDecode :: SumType 'PureScript -> Doc sumTypeToDecode (SumType _ cs _) | isEnum (map snd cs) = "D.enum" -sumTypeToDecode (SumType _ [(_,c)] _) = "$" <+> constructorToDecode False c +sumTypeToDecode (SumType _ [(_, c)] _) = "$" <+> constructorToDecode False c sumTypeToDecode (SumType t cs _) = line <> hsep - [ "$ D.sumType", - t ^. typeName . to textStrict . to dquotes, - "$ Map.fromFoldable", - encloseVsep lbracket rbracket comma (constructorToTagged . snd <$> cs) + [ "$ D.sumType" + , t ^. typeName . to textStrict . to dquotes + , "$ Map.fromFoldable" + , encloseVsep lbracket rbracket comma (constructorToTagged . snd <$> cs) ] where constructorToTagged dc = hsep - [ dc ^. sigConstructor . to textStrict . to dquotes, - "/\\", - constructorToDecode True dc + [ dc ^. sigConstructor . to textStrict . to dquotes + , "/\\" + , constructorToDecode True dc ] constructorToDecode :: Bool -> DataConstructor 'PureScript -> Doc @@ -545,9 +605,8 @@ sumTypeToOptics st = constructorOptics :: SumType 'PureScript -> [Doc] constructorOptics (SumType t cs _) = constructorToOptic (length cs > 1) t . snd <$> cs - recordOptics :: SumType 'PureScript -> [Doc] -recordOptics st@(SumType _ [(_,DataConstructor _ (Record rs))] _) = +recordOptics st@(SumType _ [(_, DataConstructor _ (Record rs))] _) = recordEntryToLens st <$> filter hasUnderscore (NE.toList rs) recordOptics _ = [] @@ -576,7 +635,7 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = (Record rs, True) -> prism pName typeInfo (recordType rs) fromExpr toExpr cName where - fromExpr = parens $ pattern n toExpr + fromExpr = parens $ pattern' n toExpr toExpr = "a" where cName = textStrict n @@ -604,8 +663,8 @@ prism name fromType toType previewPattern previewExpr inject = (mkType "Prism'" [fromType, toType]) ( "prism'" <+> inject <+> case_of - [ (previewPattern, "Just" <+> previewExpr), - ("_", "Nothing") + [ (previewPattern, "Just" <+> previewExpr) + , ("_", "Nothing") ] ) @@ -623,8 +682,8 @@ recordEntryToLens (SumType t _ _) e = if hasUnderscore e then vsep - [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue], - lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) + [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue] + , lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) ] else mempty where @@ -651,7 +710,7 @@ nullaryExpr :: Doc nullaryExpr = "unit" normalPattern :: Text -> NonEmpty PSType -> Doc -normalPattern name = pattern name . hsep . normalLabels +normalPattern name = pattern' name . hsep . normalLabels normalExpr :: NonEmpty PSType -> Doc normalExpr (_ :| []) = "a" @@ -661,7 +720,7 @@ normalLabels :: NonEmpty PSType -> [Doc] normalLabels = fmap char . zipWith const ['a' ..] . NE.toList recordPattern :: Text -> NonEmpty (RecordEntry 'PureScript) -> Doc -recordPattern name = pattern name . hrecord . fields +recordPattern name = pattern' name . hrecord . fields vrecord :: [Doc] -> Doc vrecord = encloseVsep lbrace rbrace comma @@ -681,8 +740,8 @@ fieldSignatures = fmap fieldSignature . NE.toList fieldSignature :: RecordEntry 'PureScript -> Doc fieldSignature = uncurry signature' . (field &&& _recValue) -pattern :: Text -> Doc -> Doc -pattern name = (textStrict name <+>) +pattern' :: Text -> Doc -> Doc +pattern' name = (textStrict name <+>) case_of :: [(Doc, Doc)] -> Doc case_of = caseOf "_" @@ -721,8 +780,8 @@ signature topLevel name constraints params ret = def :: Doc -> [PSType] -> [(Doc, PSType)] -> PSType -> Doc -> Doc def name constraints params ret body = vsep - [ signature True name constraints (snd <$> params) ret, - hsep $ name : (fst <$> params) <> ["=", body] + [ signature True name constraints (snd <$> params) ret + , hsep $ name : (fst <$> params) <> ["=", body] ] mkType :: Text -> [PSType] -> PSType diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 8bd65e90..6d88616f 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,37 +7,56 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} module Language.PureScript.Bridge.SumType where -import Control.Lens hiding (from, to) +import Control.Lens (makeLenses, over) +import Data.Kind (Constraint, Type) import Data.List (nub) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map as M +import Data.Map qualified as M +import Data.Map qualified as Map import Data.Maybe (maybeToList) import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable -import Generics.Deriving -import Language.PureScript.Bridge.TypeInfo -import Data.Kind ( Type, Constraint ) +import Data.Text qualified as T +import Data.Typeable (Typeable) +import Generics.Deriving ( + C1, + Constructor (conName), + D1, + Datatype, + Generic (Rep, from), + K1, + M1 (M1), + R, + S1, + Selector (selName), + U1, + type (:*:), + type (:+:), + ) +import Language.PureScript.Bridge.TypeInfo ( + Language (..), + TypeInfo (TypeInfo), + flattenTypeInfo, + mkTypeInfo, + typeName, + ) data ImportLine = ImportLine - { importModule :: !Text, - importTypes :: !(Set Text) + { importModule :: !Text + , importTypes :: !(Set Text) } deriving (Eq, Ord, Show) @@ -44,7 +64,7 @@ type ImportLines = Map Text ImportLine -- | Generic representation of your Haskell types. data SumType (lang :: Language) - = SumType (TypeInfo lang) [(Int,DataConstructor lang)] [Instance lang] + = SumType (TypeInfo lang) [(Int, DataConstructor lang)] [Instance lang] deriving (Show, Eq) -- | TypeInfo lens for 'SumType'. @@ -58,44 +78,59 @@ sumTypeInfo inj (SumType info constrs is) = -- | DataConstructor lens for 'SumType'. sumTypeConstructors :: Applicative f => ([DataConstructor lang] -> f [DataConstructor lang]) -> SumType lang -> f (SumType lang) -sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) <$> inj' constrs +sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) <$> inj' constrs where - inj' = fmap (uncurry zip) . traverse inj . unzip - --- | Create a representation of your sum (and product) types, --- for doing type translations and writing it out to your PureScript modules. -mkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) - => SumType 'Haskell -mkSumType = SumType (mkTypeInfo @t) constructors (Generic : maybeToList (nootype . map snd $ constructors)) + inj' = fmap (uncurry zip) . traverse inj . unzip + +{- | Create a representation of your sum (and product) types, + for doing type translations and writing it out to your PureScript modules. +-} +mkSumType :: + forall t. + (Generic t, Typeable t, GDataConstructor (Rep t)) => + SumType 'Haskell +mkSumType = SumType (mkTypeInfo @t) constructors (Generic : maybeToList (nootype . map snd $ constructors)) where - constructors = zip [0..] $ gToConstructors (from (undefined :: t)) - --- | Variant of @mkSumType@ which generates a purescript HasConstrIndex instance using the default ordering of --- constructors *without* a corresponding Haskell HasConstrIndices class. This should only be used if: --- --- 1) You are certain the constructor order matches the "default" order --- --- 2) You are certain the order of constructors will not change --- --- 3) You are not able to generate a HasConstrIndices (or equivalent) instance, probably because the type you are --- trying to translate to purescript is defined in a plutus-tx library. -extremelyUnsafeMkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) - => SumType 'Haskell + constructors = zip [0 ..] $ gToConstructors (from (undefined :: t)) + +{- | Variant of @mkSumType@ which generates a purescript HasConstrIndex instance using the default ordering of + constructors *without* a corresponding Haskell HasConstrIndices class. This should only be used if: + + 1) You are certain the constructor order matches the "default" order + + 2) You are certain the order of constructors will not change + + 3) You are not able to generate a HasConstrIndices (or equivalent) instance, probably because the type you are + trying to translate to purescript is defined in a plutus-tx library. +-} +extremelyUnsafeMkSumType :: + forall t. + (Generic t, Typeable t, GDataConstructor (Rep t)) => + SumType 'Haskell extremelyUnsafeMkSumType = case mkSumType @t of - SumType tInfo constructors instances -> SumType tInfo constructors (instances <> [HasConstrIndex]) - --- | Variant of @mkSumType@ which constructs a SumType using a Haskell type class that can provide constructor --- index information. -mkSumTypeIndexed :: forall (c :: Type -> Constraint) t. (Generic t, Typeable t, c t, GDataConstructor (Rep t)) - => (forall x. c x => [(Int,String)]) - -> SumType 'Haskell -mkSumTypeIndexed f = SumType (mkTypeInfo @t) constructors (Generic : HasConstrIndex : maybeToList (nootype . map snd $ constructors)) + SumType tInfo constructors instances -> SumType tInfo constructors (instances <> [Generic, HasConstrIndex, ToData, FromData, Json]) + +{- | Variant of @mkSumType@ which constructs a SumType using a Haskell type class that can provide constructor + index information. +-} +mkSumTypeIndexed :: + forall (c :: Type -> Constraint) t. + (Generic t, Typeable t, c t, GDataConstructor (Rep t)) => + (forall x. c x => [(Int, String)]) -> + SumType 'Haskell +mkSumTypeIndexed f = SumType (mkTypeInfo @t) constructors (Generic : HasConstrIndex : ToData : FromData : Json : maybeToList (nootype . map snd $ constructors)) where - ixs = M.fromList . map (\(i,t) -> (T.pack t, i)) $ f @t - constructors = foldr (\dcon@(DataConstructor name _) acc -> case M.lookup name ixs of - -- we want to error here - Nothing -> error . T.unpack $ "Constructor \"" <> name <> "\" does not have a specified index!" - Just i -> (i,dcon) : acc) [] $ gToConstructors (from (undefined :: t)) + ixs = M.fromList . map (\(i, t) -> (T.pack t, i)) $ f @t + constructors = + foldr + ( \dcon@(DataConstructor name _) acc -> case M.lookup name ixs of + -- we want to error here + Nothing -> error . T.unpack $ "Constructor \"" <> name <> "\" does not have a specified index!" + Just i -> (i, dcon) : acc + ) + [] + $ gToConstructors (from (undefined :: t)) + -- | Purescript typeclass instances that can be generated for your Haskell types. data Instance (lang :: Language) = Generic @@ -109,17 +144,19 @@ data Instance (lang :: Language) | Enum | Bounded | HasConstrIndex + | ToData + | FromData | Custom (CustomInstance lang) deriving (Eq, Show) type PSInstance = Instance 'PureScript data InstanceMember (lang :: Language) = InstanceMember - { _memberName :: Text, - _memberBindings :: [Text], - _memberBody :: Text, - _memberDependencies :: [TypeInfo lang], - _memberImportLines :: ImportLines + { _memberName :: Text + , _memberBindings :: [Text] + , _memberBody :: Text + , _memberDependencies :: [TypeInfo lang] + , _memberImportLines :: ImportLines } deriving (Eq, Ord, Show) @@ -130,14 +167,15 @@ data InstanceImplementation (lang :: Language) deriving (Eq, Ord, Show) data CustomInstance (lang :: Language) = CustomInstance - { _customConstraints :: [TypeInfo lang], - _customHead :: TypeInfo lang, - _customImplementation :: InstanceImplementation lang + { _customConstraints :: [TypeInfo lang] + , _customHead :: TypeInfo lang + , _customImplementation :: InstanceImplementation lang } deriving (Eq, Ord, Show) --- | The Purescript typeclass `Newtype` might be derivable if the original --- Haskell type was a simple type wrapper. +{- | The Purescript typeclass `Newtype` might be derivable if the original + Haskell type was a simple type wrapper. +-} nootype :: [DataConstructor lang] -> Maybe (Instance lang) nootype [DataConstructor _ (Record _)] = Just Newtype nootype [DataConstructor _ (Normal [_])] = Just Newtype @@ -151,8 +189,9 @@ argonaut (SumType ti dc is) = SumType ti dc . nub $ Json : is genericShow :: SumType t -> SumType t genericShow (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is --- | Ensure that a functor instance is generated for your type. It it --- your responsibility to ensure your type is a functor. +{- | Ensure that a functor instance is generated for your type. It it + your responsibility to ensure your type is a functor. +-} functor :: SumType t -> SumType t functor (SumType ti dc is) = SumType ti dc . nub $ Functor : is @@ -170,8 +209,8 @@ order (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is data DataConstructor (lang :: Language) = DataConstructor { -- | e.g. `Left`/`Right` for `Either` - _sigConstructor :: !Text, - _sigValues :: !(DataConstructorArgs lang) + _sigConstructor :: !Text + , _sigValues :: !(DataConstructorArgs lang) } deriving (Show, Eq) @@ -194,8 +233,8 @@ instance Monoid (DataConstructorArgs lang) where data RecordEntry (lang :: Language) = RecordEntry { -- | e.g. `runState` for `State` - _recLabel :: !Text, - _recValue :: !(TypeInfo lang) + _recLabel :: !Text + , _recValue :: !(TypeInfo lang) } deriving (Show, Eq) @@ -231,10 +270,11 @@ instance (Selector a, Typeable t) => GDataConstructorArgs (S1 a (K1 R t)) where "" -> Normal [mkTypeInfo @t] name -> Record [RecordEntry (T.pack name) (mkTypeInfo @t)] --- | Get all used types in a sum type. --- --- This includes all types found at the right hand side of a sum type --- definition, not the type parameters of the sum type itself +{- | Get all used types in a sum type. + + This includes all types found at the right hand side of a sum type + definition, not the type parameters of the sum type itself +-} getUsedTypes :: SumType lang -> Set (TypeInfo lang) getUsedTypes (SumType _ cs is) = Set.fromList . concatMap flattenTypeInfo $ @@ -250,8 +290,8 @@ instanceToTypes Generic = pure $ constraintToType $ TypeInfo "purescript-prelude instanceToTypes GenericShow = pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Show" [] instanceToTypes Json = constraintToType - <$> [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [], - TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] + <$> [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] + , TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] ] instanceToTypes Newtype = pure $ constraintToType $ TypeInfo "purescript-newtype" "Data.Newtype" "Newtype" [] @@ -269,7 +309,11 @@ instanceToTypes Bounded = pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Bounded" [] -- fix this later (i don't think it matters now) instanceToTypes HasConstrIndex = - pure $ constraintToType $ TypeInfo "cardano-browser-tx" "ConstrIndices" "HasConstrIndices" [] + pure $ constraintToType $ TypeInfo "plutonomicon-cardano-transaction-lib" "ConstrIndices" "HasConstrIndices" [] +instanceToTypes ToData = + pure $ constraintToType $ TypeInfo "plutonomicon-cardano-transaction-lib" "ToData" "ToData" [] +instanceToTypes FromData = + pure $ constraintToType $ TypeInfo "plutonomicon-cardano-transaction-lib" "FromData" "FromData" [] instanceToTypes (Custom CustomInstance {..}) = constraintToType _customHead : (fmap constraintToType _customConstraints <> implementationToTypes _customImplementation) @@ -285,12 +329,14 @@ instanceToImportLines GenericShow = importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] instanceToImportLines Json = importsFromList - [ ImportLine "Control.Lazy" $ Set.singleton "defer", - ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"], - ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"], - ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"], - ImportLine "Data.Newtype" $ Set.singleton "unwrap", - ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" + [ ImportLine "Control.Lazy" $ Set.singleton "defer" + , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonNull"] + , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["encodeJson"] + , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["decodeJson"] + , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["null", "decode", "()", "()", "()"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["null", "encode", "(>$<)", "(>/\\<)"] + , ImportLine "Data.Newtype" $ Set.singleton "unwrap" + , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" ] instanceToImportLines Enum = importsFromList @@ -302,8 +348,16 @@ instanceToImportLines Bounded = ] instanceToImportLines HasConstrIndex = importsFromList - [ ImportLine "ConstrIndices" $ Set.fromList ["constrIndices", "fromConstr2Index"], - ImportLine "Data.Tuple" $ Set.fromList ["Tuple(..)"] + [ ImportLine "ConstrIndices" $ Set.fromList ["constrIndices", "fromConstr2Index"] + , ImportLine "Data.Tuple" $ Set.fromList ["Tuple(Tuple)"] + ] +instanceToImportLines ToData = + importsFromList + [ ImportLine "ToData" $ Set.fromList ["toData", "genericToData"] + ] +instanceToImportLines FromData = + importsFromList + [ ImportLine "FromData" $ Set.fromList ["fromData", "genericFromData"] ] instanceToImportLines (Custom CustomInstance {_customImplementation = Explicit members}) = importsFromList $ concatMap (Map.elems . _memberImportLines) members diff --git a/src/Language/PureScript/Bridge/Tuple.hs b/src/Language/PureScript/Bridge/Tuple.hs index efff3937..1211e8c0 100644 --- a/src/Language/PureScript/Bridge/Tuple.hs +++ b/src/Language/PureScript/Bridge/Tuple.hs @@ -1,12 +1,15 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Bridge.Tuple where -import qualified Data.Text as T -import Language.PureScript.Bridge.Builder +import Data.Text qualified as T +import Language.PureScript.Bridge.Builder (BridgePart, doCheck) import Language.PureScript.Bridge.PSTypes (psTuple) -import Language.PureScript.Bridge.TypeInfo +import Language.PureScript.Bridge.TypeInfo ( + HasHaskType (haskType), + HaskellType, + TypeInfo (_typeName), + ) tupleBridge :: BridgePart tupleBridge = doCheck haskType isTuple >> psTuple @@ -17,7 +20,7 @@ data TupleParserState | ColonFound | Tuple | NoTuple - deriving (Eq, Show) + deriving stock (Eq, Show) step :: TupleParserState -> Char -> TupleParserState step Start '(' = OpenFound diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index c6d84652..c5a6771d 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -7,30 +7,37 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Language.PureScript.Bridge.TypeInfo - ( TypeInfo (..), - PSType, - HaskellType, - mkTypeInfo, - mkTypeInfo', - Language (..), - typePackage, - typeModule, - typeName, - typeParameters, - HasHaskType, - haskType, - flattenTypeInfo, - ) -where +module Language.PureScript.Bridge.TypeInfo ( + TypeInfo (..), + PSType, + HaskellType, + mkTypeInfo, + mkTypeInfo', + Language (..), + typePackage, + typeModule, + typeName, + typeParameters, + HasHaskType, + haskType, + flattenTypeInfo, +) where -import Control.Lens -import Data.Proxy +import Control.Lens (Lens', makeLenses) +import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable +import Data.Text qualified as T +import Data.Typeable ( + TypeRep, + Typeable, + tyConModule, + tyConName, + tyConPackage, + typeRep, + typeRepArgs, + typeRepTyCon, + ) data Language = Haskell @@ -39,13 +46,13 @@ data Language -- | Basic info about a data type: data TypeInfo (lang :: Language) = TypeInfo { -- | Hackage package - _typePackage :: !Text, - -- | Full Module path - _typeModule :: !Text, - _typeName :: !Text, - _typeParameters :: ![TypeInfo lang] + _typePackage :: !Text + , -- | Full Module path + _typeModule :: !Text + , _typeName :: !Text + , _typeParameters :: ![TypeInfo lang] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) makeLenses ''TypeInfo @@ -70,10 +77,10 @@ mkTypeInfo' :: TypeRep -> HaskellType mkTypeInfo' rep = let con = typeRepTyCon rep in TypeInfo - { _typePackage = T.pack $ tyConPackage con, - _typeModule = T.pack $ tyConModule con, - _typeName = T.pack $ tyConName con, - _typeParameters = map mkTypeInfo' (typeRepArgs rep) + { _typePackage = T.pack $ tyConPackage con + , _typeModule = T.pack $ tyConModule con + , _typeName = T.pack $ tyConName con + , _typeParameters = map mkTypeInfo' (typeRepArgs rep) } -- | Put the TypeInfo in a list together with all its '_typeParameters' (recursively) diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index c9a4c8a0..0a6f4238 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -1,25 +1,26 @@ {-# LANGUAGE EmptyDataDeriving #-} --- | As we translate types and not type constructors, we have to pass dummy types --- to any type constructor. --- --- 'buildBridge' will translate all parameter types which --- come from a module TypeParameters (e.g. this one) to lower case. --- --- For translating something like Maybe: --- --- @ --- data Maybe' a = Nothing' | Just' a --- @ --- --- you would use: --- --- @ --- import "Language.PureScript.Bridge" --- import "Language.PureScript.Bridge.TypeParameters" --- --- st = mkSumType @(Maybe' A) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. --- @ +{- | As we translate types and not type constructors, we have to pass dummy types + to any type constructor. + + 'buildBridge' will translate all parameter types which + come from a module TypeParameters (e.g. this one) to lower case. + + For translating something like Maybe: + + @ + data Maybe' a = Nothing' | Just' a + @ + + you would use: + + @ + import "Language.PureScript.Bridge" + import "Language.PureScript.Bridge.TypeParameters" + + st = mkSumType @(Maybe' A) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. + @ +-} module Language.PureScript.Bridge.TypeParameters where data A deriving (Eq, Ord) @@ -74,10 +75,11 @@ data Y deriving (Eq, Ord) data Z deriving (Eq, Ord) --- | You can use those if your type parameters are actually type constructors as well: --- @ --- st = mkSumType @('ReaderT' R M1 A) --- @ +{- | You can use those if your type parameters are actually type constructors as well: + @ + st = mkSumType @('ReaderT' R M1 A) + @ +-} data A1 a data B1 a diff --git a/src/PlutusTx/Aux.hs b/src/PlutusTx/Aux.hs new file mode 100644 index 00000000..adc52dd7 --- /dev/null +++ b/src/PlutusTx/Aux.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module PlutusTx.Aux ( + defaultIndex, + makeHasConstrIndex, + unstableMakeIsData, + makeIsDataIndexed, + mkIndicesDefault, + HasConstrIndices (..), +) where + +import Data.Kind (Type) +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Datatype qualified as TH +import PlutusTx.IsData qualified as P +import Prelude (Int, Maybe (Just, Nothing), String, fromIntegral, map, pure, zip, ($), (.), (<$>), (<>)) + +class HasConstrIndices (a :: Type) where + getConstrIndices :: [(Int, String)] + +-- PlutusTx doesn't export this so we need to duplicate it here +defaultIndex :: TH.Name -> TH.Q [(TH.Name, Int)] +defaultIndex name = do + info <- TH.reifyDatatype name + pure $ zip (TH.constructorName <$> TH.datatypeCons info) [0 ..] + +makeHasConstrIndex :: TH.Name -> [(TH.Name, Int)] -> TH.Q [TH.Dec] +makeHasConstrIndex name indices = + pure [TH.InstanceD Nothing [] instanceType [getIndices]] + where + instanceType = TH.AppT classType (TH.ConT name) + + classType = TH.ConT $ TH.mkName "HasConstrIndices" + + getIndices :: TH.Dec + getIndices = TH.FunD (TH.mkName "getConstrIndices") [methodClause] + + methodClause :: TH.Clause + methodClause = TH.Clause [] methodBody [] + + methodBody :: TH.Body + methodBody = TH.NormalB indicesE + + indicesE :: TH.Exp + indicesE = + TH.ListE $ + map + ( \(n, i) -> + TH.TupE [Just (TH.LitE . TH.IntegerL . fromIntegral $ i), Just (TH.LitE . TH.StringL $ TH.nameBase n)] + ) + indices + +unstableMakeIsData :: TH.Name -> TH.Q [TH.Dec] +unstableMakeIsData name = do + indices <- defaultIndex name + hasConstrIndicesInstance <- makeHasConstrIndex name indices + decs <- P.unstableMakeIsData name + pure (hasConstrIndicesInstance <> decs) + +makeIsDataIndexed :: TH.Name -> [(TH.Name, Int)] -> TH.Q [TH.Dec] +makeIsDataIndexed name indices = do + hasConstrIndicesInstance <- makeHasConstrIndex name indices + decs <- P.makeIsDataIndexed name indices + pure (hasConstrIndicesInstance <> decs) + +mkIndicesDefault :: TH.Name -> TH.Q [TH.Dec] +mkIndicesDefault name = do + indices <- defaultIndex name + makeHasConstrIndex name indices diff --git a/stack-7.10.yaml b/stack-7.10.yaml deleted file mode 100644 index 4a394fa0..00000000 --- a/stack-7.10.yaml +++ /dev/null @@ -1,11 +0,0 @@ -resolver: lts-6.0 -packages: -- '.' -extra-deps: [] - -flags: {} - -extra-package-dbs: [] - -nix: - shell-file: stack.nix diff --git a/stack-8.0.nix b/stack-8.0.nix deleted file mode 100644 index 5e9abe7f..00000000 --- a/stack-8.0.nix +++ /dev/null @@ -1,12 +0,0 @@ -with (import {}); -let - #haskellPackages = haskellPackages; - ghc = haskellPackages.ghc; -in - haskell.lib.buildStackProject { - name = "myEnv"; - # buildInputs = [ gcc git zlib pkgconfig ghc glibcLocales ]; - buildInputs = [ zlib haskellPackages.ghc-mod postgresql ]; - ghc = ghc; - shellHook = "export SSL_CERT_FILE=/etc/ssl/certs/ca-bundle.crt"; -} diff --git a/stack-8.0.yaml b/stack-8.0.yaml deleted file mode 100644 index 601b3954..00000000 --- a/stack-8.0.yaml +++ /dev/null @@ -1,11 +0,0 @@ -resolver: nightly-2020-08-17 -packages: -- '.' -extra-deps: [] - -flags: {} - -extra-package-dbs: [] - -nix: - shell-file: stack-8.0.nix diff --git a/stack.nix b/stack.nix deleted file mode 100644 index 1f131d72..00000000 --- a/stack.nix +++ /dev/null @@ -1,12 +0,0 @@ -with (import {}); -let - haskellPackages = haskell.packages.lts-6_7; - ghc = haskellPackages.ghc; -in - haskell.lib.buildStackProject { - name = "myEnv"; - # buildInputs = [ gcc git zlib pkgconfig ghc glibcLocales ]; - buildInputs = [ zlib haskellPackages.ghc-mod postgresql ]; - ghc = ghc; - shellHook = "export SSL_CERT_FILE=/etc/ssl/certs/ca-bundle.crt"; -} diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index d0be4291..7782349c 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -1,29 +1,68 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -module RoundTrip.Spec where +module RoundTrip.Spec (roundtripSpec) where import Control.Exception (bracket) +import Control.Monad (guard, unless) import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) -import Data.ByteString.Lazy (hGetContents, stripSuffix) +import Data.ByteString.Lazy (hGetContents, hPutStr, putStr, stripSuffix) import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.Foldable (traverse_) import Data.List (isInfixOf) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Proxy (Proxy (Proxy)) import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonaut, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) +import Language.PureScript.Bridge ( + BridgePart, + Language (..), + SumType, + argonaut, + buildBridge, + defaultBridge, + defaultSwitch, + equal, + functor, + genericShow, + mkSumType, + order, + writePSTypes, + writePSTypesWith, + ) import Language.PureScript.Bridge.TypeParameters (A) -import RoundTrip.Types +import RoundTrip.Types ( + MyUnit, + TestData, + TestEnum, + TestMultiInlineRecords, + TestNewtype, + TestNewtypeRecord, + TestRecord, + TestRecursiveA, + TestRecursiveB, + TestSum, + TestTwoFields, + ) import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hFlush, hPutStrLn, hSetBuffering, stderr, stdout) -import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) +import System.IO (BufferMode (LineBuffering), Handle, hFlush, hGetLine, hPutStrLn, hSetBuffering, stderr, stdout) +import System.Process ( + CreateProcess (std_err, std_in, std_out), + StdStream (CreatePipe), + createProcess, + getProcessExitCode, + proc, + readProcessWithExitCode, + runInteractiveCommand, + runInteractiveProcess, + terminateProcess, + waitForProcess, + ) import Test.HUnit (assertBool, assertEqual) import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) -import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Expectations (shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (noShrinking, once, verbose, withMaxSuccess) import Test.QuickCheck.Property (Testable (property)) @@ -33,17 +72,17 @@ myBridge = defaultBridge myTypes :: [SumType 'Haskell] myTypes = - [ equal . genericShow . order . argonaut $ mkSumType @TestData, - equal . genericShow . order . argonaut $ mkSumType @TestSum, - equal . genericShow . order . argonaut $ mkSumType @TestRecursiveA, - equal . genericShow . order . argonaut $ mkSumType @TestRecursiveB, - functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), - equal . genericShow . order . argonaut $ mkSumType @TestNewtype, - equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, - equal . genericShow . order . argonaut $ mkSumType @TestMultiInlineRecords, - equal . genericShow . order . argonaut $ mkSumType @TestTwoFields, - equal . genericShow . order . argonaut $ mkSumType @TestEnum, - equal . genericShow . order . argonaut $ mkSumType @MyUnit + [ equal . genericShow . order . argonaut $ mkSumType @TestData + , equal . genericShow . order . argonaut $ mkSumType @TestSum + , equal . genericShow . order . argonaut $ mkSumType @TestRecursiveA + , equal . genericShow . order . argonaut $ mkSumType @TestRecursiveB + , functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A) + , equal . genericShow . order . argonaut $ mkSumType @TestNewtype + , equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord + , equal . genericShow . order . argonaut $ mkSumType @TestMultiInlineRecords + , equal . genericShow . order . argonaut $ mkSumType @TestTwoFields + , equal . genericShow . order . argonaut $ mkSumType @TestEnum + , equal . genericShow . order . argonaut $ mkSumType @MyUnit ] roundtripSpec :: Spec @@ -70,20 +109,17 @@ roundtripSpec = do where withApp = bracket runApp killApp runApp = do - (Just hin, Just hout, Just herr, hproc) <- - createProcess - (proc "spago" ["run"]) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - hSetBuffering hin LineBuffering - hSetBuffering hout LineBuffering - hSetBuffering herr LineBuffering - -- flush stderr output from build - _ <- hGetLine herr - -- wait for initial log message - _ <- hGetLine hout + runInteractiveCommand "spago build" + (hin, hout, herr, hproc) <- runInteractiveCommand "spago run" + mapM_ (`hSetBuffering` LineBuffering) [hin, hout, herr] + -- Wait until Spago is done with the build + let waitUntilBuildSucceded = do + l <- hGetLine herr + Control.Monad.unless (l == "[info] Build succeeded.") waitUntilBuildSucceded + waitUntilBuildSucceded + -- Wait for initial "ready" log message + l <- hGetLine hout + guard $ l == "ready" pure (hin, hout, herr, hproc) killApp (_, _, _, hproc) = terminateProcess hproc diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 31f15b99..0d7ebf04 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -1,15 +1,15 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} module RoundTrip.Types where import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) import Data.Map (Map) -import Data.Proxy (Proxy (..)) +import Data.Proxy (Proxy (Proxy)) import Data.Set (Set) import Data.Text (Text) import GHC.Generics (Generic) @@ -20,13 +20,13 @@ import System.Exit (ExitCode (ExitSuccess)) import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual) import Test.Hspec (Spec, aroundAll_, describe, it) -import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.Expectations (shouldBe) import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, sized) data TestData = Maybe (Maybe TestSum) | Either (Either (Maybe Int) (Maybe Bool)) - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestData @@ -35,8 +35,8 @@ instance ToJSON TestData instance Arbitrary TestData where arbitrary = oneof - [ Maybe <$> arbitrary, - Either <$> arbitrary + [ Maybe <$> arbitrary + , Either <$> arbitrary ] data TestSum @@ -63,7 +63,7 @@ data TestSum | QuadSimple Int Double Bool Double | Recursive TestRecursiveA | Enum TestEnum - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestSum @@ -72,31 +72,31 @@ instance ToJSON TestSum instance Arbitrary TestSum where arbitrary = oneof - [ pure Nullary, - Bool <$> arbitrary, - Int <$> arbitrary, - Number <$> arbitrary, - String <$> arbitrary, - Array <$> arbitrary, - InlineRecord <$> arbitrary <*> arbitrary, - MultiInlineRecords <$> arbitrary, - Record <$> arbitrary, - NestedRecord <$> arbitrary, - NT <$> arbitrary, - NTRecord <$> arbitrary, - Map <$> arbitrary, - Set <$> arbitrary, - TwoFields <$> arbitrary, - pure $ Unit (), - Pair <$> arbitrary, - Triple <$> arbitrary, - Quad <$> arbitrary, - QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary, - Enum <$> arbitrary + [ pure Nullary + , Bool <$> arbitrary + , Int <$> arbitrary + , Number <$> arbitrary + , String <$> arbitrary + , Array <$> arbitrary + , InlineRecord <$> arbitrary <*> arbitrary + , MultiInlineRecords <$> arbitrary + , Record <$> arbitrary + , NestedRecord <$> arbitrary + , NT <$> arbitrary + , NTRecord <$> arbitrary + , Map <$> arbitrary + , Set <$> arbitrary + , TwoFields <$> arbitrary + , pure $ Unit () + , Pair <$> arbitrary + , Triple <$> arbitrary + , Quad <$> arbitrary + , QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Enum <$> arbitrary ] data TestRecursiveA = Nil | Recurse TestRecursiveB - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestRecursiveA @@ -110,7 +110,8 @@ instance Arbitrary TestRecursiveA where | otherwise = pure Nil newtype TestRecursiveB = RecurseB TestRecursiveB - deriving (Show, Eq, Ord, Generic, Arbitrary) + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Arbitrary) instance FromJSON TestRecursiveB @@ -118,14 +119,14 @@ instance ToJSON TestRecursiveB data TestMultiInlineRecords = Foo - { _foo1 :: Maybe Int, - _foo2 :: () + { _foo1 :: Maybe Int + , _foo2 :: () } | Bar - { _bar1 :: String, - _bar2 :: Bool + { _bar1 :: String + , _bar2 :: Bool } - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestMultiInlineRecords @@ -134,15 +135,15 @@ instance ToJSON TestMultiInlineRecords instance Arbitrary TestMultiInlineRecords where arbitrary = oneof - [ Foo <$> arbitrary <*> arbitrary, - Bar <$> arbitrary <*> arbitrary + [ Foo <$> arbitrary <*> arbitrary + , Bar <$> arbitrary <*> arbitrary ] data TestRecord a = TestRecord - { _field1 :: Maybe Int, - _field2 :: a + { _field1 :: Maybe Int + , _field2 :: a } - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance (FromJSON a) => FromJSON (TestRecord a) @@ -152,7 +153,7 @@ instance (Arbitrary a) => Arbitrary (TestRecord a) where arbitrary = TestRecord <$> arbitrary <*> arbitrary data TestTwoFields = TestTwoFields Bool Int - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestTwoFields @@ -162,7 +163,7 @@ instance Arbitrary TestTwoFields where arbitrary = TestTwoFields <$> arbitrary <*> arbitrary newtype TestNewtype = TestNewtype (TestRecord Bool) - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestNewtype @@ -172,7 +173,7 @@ instance Arbitrary TestNewtype where arbitrary = TestNewtype <$> arbitrary newtype TestNewtypeRecord = TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} - deriving (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Ord, Generic) instance FromJSON TestNewtypeRecord @@ -189,7 +190,7 @@ data TestEnum | Fri | Sat | Sun - deriving (Show, Eq, Ord, Bounded, Enum, Generic) + deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) instance FromJSON TestEnum @@ -198,7 +199,7 @@ instance ToJSON TestEnum instance Arbitrary TestEnum where arbitrary = chooseEnum (minBound, maxBound) -data MyUnit = U deriving (Show, Eq, Ord, Bounded, Enum, Generic) +data MyUnit = U deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) instance FromJSON MyUnit diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index bac5b55b..80637a70 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -1,36 +1,38 @@ let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211005/packages.dhall sha256:2ec351f17be14b3f6421fbba36f4f01d1681e5c7f46e0c981465c4cf222de5be + https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211005/packages.dhall + sha256:2ec351f17be14b3f6421fbba36f4f01d1681e5c7f46e0c981465c4cf222de5be -in upstream // { - json-helpers = - { dependencies = - [ "aff" - , "argonaut-codecs" - , "argonaut-core" - , "arrays" - , "bifunctors" - , "contravariant" - , "control" - , "effect" - , "either" - , "enums" - , "foldable-traversable" - , "foreign-object" - , "maybe" - , "newtype" - , "ordered-collections" - , "prelude" - , "profunctor" - , "psci-support" - , "quickcheck" - , "record" - , "spec" - , "spec-quickcheck" - , "transformers" - , "tuples" - , "typelevel-prelude" - ] - , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" - } -} +in upstream + // { json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = + "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + } + } diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index d0a9eaec..f5dba5d7 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -14,7 +14,6 @@ , "ordered-collections" , "prelude" , "profunctor-lenses" - , "psci-support" , "tuples" ] , packages = ./packages.dhall diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 52c14eba..cfda5a79 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -5,7 +5,7 @@ import Prelude import Data.Argonaut.Core (stringify) import Data.Argonaut.Decode (JsonDecodeError, decodeJson, parseJson, printJsonDecodeError) import Data.Argonaut.Encode (encodeJson) -import Data.Either (Either(..)) +import Data.Either (Either(Left, Right)) import Effect (Effect) import Effect.Class.Console (error, log) import Node.ReadLine (createConsoleInterface, noCompletion, question) @@ -17,7 +17,7 @@ main = do log "ready" go interface where - go interface = + go interface = interface # question "" \input -> do let parsed :: Either JsonDecodeError TestData @@ -31,3 +31,4 @@ main = do error "" log $ stringify $ encodeJson testData go interface + diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index bf7ff685..f5e752c5 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -5,10 +5,10 @@ import Prelude import Control.Lazy (defer) import Data.Argonaut.Core (jsonNull) -import Data.Argonaut.Decode (class DecodeJson) -import Data.Argonaut.Decode.Aeson ((), (), ()) +import Data.Argonaut.Decode (class DecodeJson, decodeJson) +import Data.Argonaut.Decode.Aeson ((), (), (), decode, null) import Data.Argonaut.Encode (class EncodeJson, encodeJson) -import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) +import Data.Argonaut.Encode.Aeson ((>$<), (>/\<), encode, null) import Data.Bounded.Generic (genericBottom, genericTop) import Data.Either (Either) import Data.Enum (class Enum) @@ -18,7 +18,7 @@ import Data.Lens (Iso', Lens', Prism', iso, prism') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.Map (Map) -import Data.Maybe (Maybe(..)) +import Data.Maybe (Maybe, Maybe(Nothing, Just)) import Data.Newtype (class Newtype, unwrap) import Data.Set (Set) import Data.Show.Generic (genericShow) @@ -47,10 +47,11 @@ instance EncodeJson TestData where instance DecodeJson TestData where decodeJson = defer \_ -> D.decode - $ D.sumType "TestData" $ Map.fromFoldable - [ "Maybe" /\ D.content (Maybe <$> (D.maybe D.value)) - , "Either" /\ D.content (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) - ] + $ D.sumType "TestData" + $ Map.fromFoldable + [ "Maybe" /\ D.content (Maybe <$> (D.maybe D.value)) + , "Either" /\ D.content (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + ] derive instance Generic TestData _ @@ -76,9 +77,9 @@ data TestSum | String String | Array (Array Int) | InlineRecord - { why :: String - , wouldYouDoThis :: Int - } + { why :: String + , wouldYouDoThis :: Int + } | MultiInlineRecords TestMultiInlineRecords | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) @@ -105,13 +106,13 @@ derive instance Ord TestSum instance EncodeJson TestSum where encodeJson = defer \_ -> case _ of - Nullary -> encodeJson { tag: "Nullary", contents: jsonNull } + Nullary -> encodeJson { tag: "Nullary" } Bool a -> E.encodeTagged "Bool" a E.value Int a -> E.encodeTagged "Int" a E.value Number a -> E.encodeTagged "Number" a E.value String a -> E.encodeTagged "String" a E.value Array a -> E.encodeTagged "Array" a E.value - InlineRecord {why, wouldYouDoThis} -> encodeJson + InlineRecord { why, wouldYouDoThis } -> encodeJson { tag: "InlineRecord" , why: flip E.encode why E.value , wouldYouDoThis: flip E.encode wouldYouDoThis E.value @@ -135,34 +136,37 @@ instance EncodeJson TestSum where instance DecodeJson TestSum where decodeJson = defer \_ -> D.decode - $ D.sumType "TestSum" $ Map.fromFoldable - [ "Nullary" /\ pure Nullary - , "Bool" /\ D.content (Bool <$> D.value) - , "Int" /\ D.content (Int <$> D.value) - , "Number" /\ D.content (Number <$> D.value) - , "String" /\ D.content (String <$> D.value) - , "Array" /\ D.content (Array <$> D.value) - , "InlineRecord" /\ (InlineRecord <$> D.object "InlineRecord" - { why: D.value :: _ String - , wouldYouDoThis: D.value :: _ Int - }) - , "MultiInlineRecords" /\ D.content (MultiInlineRecords <$> D.value) - , "Record" /\ D.content (Record <$> D.value) - , "NestedRecord" /\ D.content (NestedRecord <$> D.value) - , "NT" /\ D.content (NT <$> D.value) - , "NTRecord" /\ D.content (NTRecord <$> D.value) - , "TwoFields" /\ D.content (TwoFields <$> D.value) - , "Set" /\ D.content (Set <$> D.value) - , "Map" /\ D.content (Map <$> (D.dictionary D.value D.value)) - , "Unit" /\ D.content (Unit <$> D.unit) - , "MyUnit" /\ D.content (MyUnit <$> D.value) - , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) - , "Triple" /\ D.content (Triple <$> (D.tuple (D.value D.unit D.value))) - , "Quad" /\ D.content (Quad <$> (D.tuple (D.value D.value D.value D.value))) - , "QuadSimple" /\ D.content (D.tuple $ QuadSimple D.value D.value D.value D.value) - , "Recursive" /\ D.content (Recursive <$> D.value) - , "Enum" /\ D.content (Enum <$> D.value) - ] + $ D.sumType "TestSum" + $ Map.fromFoldable + [ "Nullary" /\ pure Nullary + , "Bool" /\ D.content (Bool <$> D.value) + , "Int" /\ D.content (Int <$> D.value) + , "Number" /\ D.content (Number <$> D.value) + , "String" /\ D.content (String <$> D.value) + , "Array" /\ D.content (Array <$> D.value) + , "InlineRecord" /\ + ( InlineRecord <$> D.object "InlineRecord" + { why: D.value :: _ String + , wouldYouDoThis: D.value :: _ Int + } + ) + , "MultiInlineRecords" /\ D.content (MultiInlineRecords <$> D.value) + , "Record" /\ D.content (Record <$> D.value) + , "NestedRecord" /\ D.content (NestedRecord <$> D.value) + , "NT" /\ D.content (NT <$> D.value) + , "NTRecord" /\ D.content (NTRecord <$> D.value) + , "TwoFields" /\ D.content (TwoFields <$> D.value) + , "Set" /\ D.content (Set <$> D.value) + , "Map" /\ D.content (Map <$> (D.dictionary D.value D.value)) + , "Unit" /\ D.content (Unit <$> D.unit) + , "MyUnit" /\ D.content (MyUnit <$> D.value) + , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) + , "Triple" /\ D.content (Triple <$> (D.tuple (D.value D.unit D.value))) + , "Quad" /\ D.content (Quad <$> (D.tuple (D.value D.value D.value D.value))) + , "QuadSimple" /\ D.content (D.tuple $ QuadSimple D.value D.value D.value D.value) + , "Recursive" /\ D.content (Recursive <$> D.value) + , "Enum" /\ D.content (Enum <$> D.value) + ] derive instance Generic TestSum _ @@ -198,7 +202,7 @@ _Array = prism' Array case _ of (Array a) -> Just a _ -> Nothing -_InlineRecord :: Prism' TestSum {why :: String, wouldYouDoThis :: Int} +_InlineRecord :: Prism' TestSum { why :: String, wouldYouDoThis :: Int } _InlineRecord = prism' InlineRecord case _ of (InlineRecord a) -> Just a _ -> Nothing @@ -268,9 +272,9 @@ _Quad = prism' Quad case _ of (Quad a) -> Just a _ -> Nothing -_QuadSimple :: Prism' TestSum {a :: Int, b :: Number, c :: Boolean, d :: Number} -_QuadSimple = prism' (\{a, b, c, d} -> (QuadSimple a b c d)) case _ of - (QuadSimple a b c d) -> Just {a, b, c, d} +_QuadSimple :: Prism' TestSum { a :: Int, b :: Number, c :: Boolean, d :: Number } +_QuadSimple = prism' (\{ a, b, c, d } -> (QuadSimple a b c d)) case _ of + (QuadSimple a b c d) -> Just { a, b, c, d } _ -> Nothing _Recursive :: Prism' TestSum TestRecursiveA @@ -298,15 +302,16 @@ derive instance Ord TestRecursiveA instance EncodeJson TestRecursiveA where encodeJson = defer \_ -> case _ of - Nil -> encodeJson { tag: "Nil", contents: jsonNull } + Nil -> encodeJson { tag: "Nil" } Recurse a -> E.encodeTagged "Recurse" a E.value instance DecodeJson TestRecursiveA where decodeJson = defer \_ -> D.decode - $ D.sumType "TestRecursiveA" $ Map.fromFoldable - [ "Nil" /\ pure Nil - , "Recurse" /\ D.content (Recurse <$> D.value) - ] + $ D.sumType "TestRecursiveA" + $ Map.fromFoldable + [ "Nil" /\ pure Nil + , "Recurse" /\ D.content (Recurse <$> D.value) + ] derive instance Generic TestRecursiveA _ @@ -365,16 +370,20 @@ instance (Show a) => Show (TestRecord a) where derive instance (Ord a) => Ord (TestRecord a) instance (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record - { _field1: (E.maybe E.value) :: _ (Maybe Int) - , _field2: E.value :: _ a - }) + encodeJson = defer \_ -> E.encode $ unwrap >$< + ( E.record + { _field1: (E.maybe E.value) :: _ (Maybe Int) + , _field2: E.value :: _ a + } + ) instance (DecodeJson a) => DecodeJson (TestRecord a) where - decodeJson = defer \_ -> D.decode $ (TestRecord <$> D.record "TestRecord" - { _field1: (D.maybe D.value) :: _ (Maybe Int) - , _field2: D.value :: _ a - }) + decodeJson = defer \_ -> D.decode $ + ( TestRecord <$> D.record "TestRecord" + { _field1: (D.maybe D.value) :: _ (Maybe Int) + , _field2: D.value :: _ a + } + ) derive instance Generic (TestRecord a) _ @@ -382,14 +391,14 @@ derive instance Newtype (TestRecord a) _ -------------------------------------------------------------------------------- -_TestRecord :: forall a. Iso' (TestRecord a) {_field1 :: Maybe Int, _field2 :: a} +_TestRecord :: forall a. Iso' (TestRecord a) { _field1 :: Maybe Int, _field2 :: a } _TestRecord = _Newtype field1 :: forall a. Lens' (TestRecord a) (Maybe Int) -field1 = _Newtype <<< prop (Proxy :: _"_field1") +field1 = _Newtype <<< prop (Proxy :: _ "_field1") field2 :: forall a. Lens' (TestRecord a) a -field2 = _Newtype <<< prop (Proxy :: _"_field2") +field2 = _Newtype <<< prop (Proxy :: _ "_field2") -------------------------------------------------------------------------------- @@ -429,8 +438,10 @@ instance Show TestNewtypeRecord where derive instance Ord TestNewtypeRecord instance EncodeJson TestNewtypeRecord where - encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record - { unTestNewtypeRecord: E.value :: _ TestNewtype }) + encodeJson = defer \_ -> E.encode $ unwrap >$< + ( E.record + { unTestNewtypeRecord: E.value :: _ TestNewtype } + ) instance DecodeJson TestNewtypeRecord where decodeJson = defer \_ -> D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) @@ -441,64 +452,69 @@ derive instance Newtype TestNewtypeRecord _ -------------------------------------------------------------------------------- -_TestNewtypeRecord :: Iso' TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} +_TestNewtypeRecord :: Iso' TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } _TestNewtypeRecord = _Newtype -------------------------------------------------------------------------------- data TestMultiInlineRecords = Foo - { _foo1 :: Maybe Int - , _foo2 :: Unit - } + { _foo1 :: Maybe Int + , _foo2 :: Unit + } | Bar - { _bar1 :: String - , _bar2 :: Boolean - } + { _bar1 :: String + , _bar2 :: Boolean + } -derive instance eqTestMultiInlineRecords :: Eq TestMultiInlineRecords +derive instance Eq TestMultiInlineRecords -instance showTestMultiInlineRecords :: Show TestMultiInlineRecords where +instance Show TestMultiInlineRecords where show a = genericShow a -derive instance ordTestMultiInlineRecords :: Ord TestMultiInlineRecords +derive instance Ord TestMultiInlineRecords -instance encodeJsonTestMultiInlineRecords :: EncodeJson TestMultiInlineRecords where +instance EncodeJson TestMultiInlineRecords where encodeJson = defer \_ -> case _ of - Foo {_foo1, _foo2} -> encodeJson + Foo { _foo1, _foo2 } -> encodeJson { tag: "Foo" , _foo1: flip E.encode _foo1 (E.maybe E.value) , _foo2: flip E.encode _foo2 E.unit } - Bar {_bar1, _bar2} -> encodeJson + Bar { _bar1, _bar2 } -> encodeJson { tag: "Bar" , _bar1: flip E.encode _bar1 E.value , _bar2: flip E.encode _bar2 E.value } -instance decodeJsonTestMultiInlineRecords :: DecodeJson TestMultiInlineRecords where +instance DecodeJson TestMultiInlineRecords where decodeJson = defer \_ -> D.decode - $ D.sumType "TestMultiInlineRecords" $ Map.fromFoldable - [ "Foo" /\ (Foo <$> D.object "Foo" - { _foo1: (D.maybe D.value) :: _ (Maybe Int) - , _foo2: D.unit :: _ Unit - }) - , "Bar" /\ (Bar <$> D.object "Bar" - { _bar1: D.value :: _ String - , _bar2: D.value :: _ Boolean - }) - ] - -derive instance genericTestMultiInlineRecords :: Generic TestMultiInlineRecords _ + $ D.sumType "TestMultiInlineRecords" + $ Map.fromFoldable + [ "Foo" /\ + ( Foo <$> D.object "Foo" + { _foo1: (D.maybe D.value) :: _ (Maybe Int) + , _foo2: D.unit :: _ Unit + } + ) + , "Bar" /\ + ( Bar <$> D.object "Bar" + { _bar1: D.value :: _ String + , _bar2: D.value :: _ Boolean + } + ) + ] + +derive instance Generic TestMultiInlineRecords _ -------------------------------------------------------------------------------- -_Foo :: Prism' TestMultiInlineRecords {_foo1 :: Maybe Int, _foo2 :: Unit} +_Foo :: Prism' TestMultiInlineRecords { _foo1 :: Maybe Int, _foo2 :: Unit } _Foo = prism' Foo case _ of (Foo a) -> Just a _ -> Nothing -_Bar :: Prism' TestMultiInlineRecords {_bar1 :: String, _bar2 :: Boolean} +_Bar :: Prism' TestMultiInlineRecords { _bar1 :: String, _bar2 :: Boolean } _Bar = prism' Bar case _ of (Bar a) -> Just a _ -> Nothing @@ -518,14 +534,14 @@ instance EncodeJson TestTwoFields where encodeJson = defer \_ -> E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) >$< (E.tuple (E.value >/\< E.value)) instance DecodeJson TestTwoFields where - decodeJson = defer \_ -> D.decode $ (D.tuple $ TestTwoFields D.value D.value) + decodeJson = defer \_ -> D.decode $ (D.tuple $ TestTwoFields D.value D.value) derive instance Generic TestTwoFields _ -------------------------------------------------------------------------------- -_TestTwoFields :: Iso' TestTwoFields {a :: Boolean, b :: Int} -_TestTwoFields = iso (\(TestTwoFields a b) -> {a, b}) (\{a, b} -> (TestTwoFields a b)) +_TestTwoFields :: Iso' TestTwoFields { a :: Boolean, b :: Int } +_TestTwoFields = iso (\(TestTwoFields a b) -> { a, b }) (\{ a, b } -> (TestTwoFields a b)) -------------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs index e5749087..24fb01d7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -8,29 +9,65 @@ module Main where -import qualified Data.Map as Map +import Data.Map (empty) +import Data.Map qualified as Map import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T -import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches -import Language.PureScript.Bridge.TypeParameters +import Data.Text qualified as T +import Language.PureScript.Bridge ( + CustomInstance (CustomInstance), + Instance (Custom), + InstanceImplementation (Derive, DeriveNewtype, Explicit), + InstanceMember (InstanceMember), + Language (Haskell), + SumType (..), + TypeInfo (TypeInfo), + bridgeSumType, + buildBridge, + defaultBridge, + equal, + equal1, + functor, + genericShow, + mkSumType, + moduleToText, + noLenses, + order, + renderText, + sumTypeToDocs, + sumTypeToModule, + ) +import Language.PureScript.Bridge.CodeGenSwitches ( + getSettings, + noLenses, + ) +import Language.PureScript.Bridge.Plutus (mkSumTypeIndexed) +import Language.PureScript.Bridge.TypeParameters (A, B, C, M1) import RoundTrip.Spec (roundtripSpec) -import Test.Hspec - ( Spec, - describe, - hspec, - it, - ) -import Test.Hspec.Expectations.Pretty -import TestData -import Text.PrettyPrint.Leijen.Text - ( Doc, - cat, - linebreak, - punctuate, - vsep, - ) +import Test.Hspec ( + Spec, + describe, + hspec, + it, + ) +import Test.Hspec.Expectations (Expectation, shouldBe) +import TestData ( + Bar, + Foo, + Func, + SingleProduct, + SingleRecord, + SingleValueConstr, + SomeNewtype, + TwoRecords, + ) +import Text.PrettyPrint.Leijen.Text ( + Doc, + cat, + linebreak, + punctuate, + vsep, + ) main :: IO () main = hspec $ allTests *> roundtripSpec @@ -42,8 +79,8 @@ custom (SumType t cs is) = SumType t cs $ customInstance : is Custom $ CustomInstance [] (TypeInfo "" "Data.MyClass" "MyClass" [TypeInfo "" "" "Foo" []]) $ Explicit - [ InstanceMember "member1" ["foo", "bar"] "undefined" [], - InstanceMember "member2" [] "do\npure unit" [] + [ InstanceMember "member1" ["foo", "bar"] "undefined" [] empty + , InstanceMember "member2" [] "do\npure unit" [] empty ] customNewtypeDerived :: SumType 'Haskell -> SumType 'Haskell @@ -62,8 +99,8 @@ customDerived (SumType t cs is) = SumType t cs $ customInstance : is customInstance = Custom $ CustomInstance - [ TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []], - TypeInfo "" "" "Show" [TypeInfo "" "" "Foo" []] + [ TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []] + , TypeInfo "" "" "Show" [TypeInfo "" "" "Foo" []] ] (TypeInfo "" "Data.MyDClass" "MyDClass" [TypeInfo "" "" "Foo" []]) Derive @@ -80,21 +117,21 @@ allTests = do doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Foo", - " = Foo", - " | Bar Int", - " | FooBar Int String", - "", - "derive newtype instance (Eq Foo) => MyNTClass Foo", - "", - "derive instance (Eq Foo, Show Foo) => MyDClass Foo", - "", - "instance MyClass Foo where", - " member1 foo bar = undefined", - " member2 = do", - " pure unit", - "", - "derive instance Generic Foo _" + [ "data Foo" + , " = Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "derive newtype instance (Eq Foo) => MyNTClass Foo" + , "" + , "derive instance (Eq Foo, Show Foo) => MyDClass Foo" + , "" + , "instance MyClass Foo where" + , " member1 foo bar = undefined" + , " member2 = do" + , " pure unit" + , "" + , "derive instance Generic Foo _" ] in doc `shouldRender` txt it "tests generation of typeclasses for custom type Foo" $ @@ -105,19 +142,19 @@ allTests = do doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Foo", - " = Foo", - " | Bar Int", - " | FooBar Int String", - "", - "instance Show Foo where", - " show a = genericShow a", - "", - "derive instance Eq Foo", - "", - "derive instance Ord Foo", - "", - "derive instance Generic Foo _" + [ "data Foo" + , " = Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "instance Show Foo where" + , " show a = genericShow a" + , "" + , "derive instance Eq Foo" + , "" + , "derive instance Ord Foo" + , "" + , "derive instance Generic Foo _" ] in doc `shouldRender` txt it "tests generation of typeclasses for custom type Func" $ @@ -128,16 +165,16 @@ allTests = do doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Func a = Func Int a", - "", - "derive instance Eq1 Func", - "", - "derive instance Functor Func", - "", - "instance (Show a) => Show (Func a) where", - " show a = genericShow a", - "", - "derive instance Generic (Func a) _" + [ "data Func a = Func Int a" + , "" + , "derive instance Eq1 Func" + , "" + , "derive instance Functor Func" + , "" + , "instance (Show a) => Show (Func a) where" + , " show a = genericShow a" + , "" + , "derive instance Generic (Func a) _" ] in doc `shouldRender` txt it "tests the generation of a whole (dummy) module" $ @@ -149,22 +186,22 @@ allTests = do m = head . map (moduleToText settings) . Map.elems $ modules txt = T.unlines - [ "-- File auto generated by purescript-bridge! --", - "module TestData where", - "", - "import Prelude", - "", - "import Data.Either (Either)", - "import Data.Generic.Rep (class Generic)", - "import Data.Maybe (Maybe(..))", - "", - "data Bar a b m c", - " = Bar1 (Maybe a)", - " | Bar2 (Either a b)", - " | Bar3 a", - " | Bar4 { myMonadicResult :: m b }", - "", - "derive instance Generic (Bar a b m c) _" + [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Prelude" + , "" + , "import Data.Either (Either)" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Maybe (Maybe, Maybe(Nothing, Just))" + , "" + , "data Bar a b m c" + , " = Bar1 (Maybe a)" + , " | Bar2 (Either a b)" + , " | Bar3 a" + , " | Bar4 { myMonadicResult :: m b }" + , "" + , "derive instance Generic (Bar a b m c) _" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ @@ -175,15 +212,15 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt it "tests generation of newtypes for haskell newtype" $ @@ -194,11 +231,11 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SomeNewtype = SomeNewtype Int", - "", - "derive instance Generic SomeNewtype _", - "", - "derive instance Newtype SomeNewtype _" + [ "newtype SomeNewtype = SomeNewtype Int" + , "" + , "derive instance Generic SomeNewtype _" + , "" + , "derive instance Newtype SomeNewtype _" ] in doc `shouldRender` txt it "tests generation of newtypes for haskell data type with one argument" $ @@ -209,11 +246,11 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleValueConstr = SingleValueConstr Int", - "", - "derive instance Generic SingleValueConstr _", - "", - "derive instance Newtype SingleValueConstr _" + [ "newtype SingleValueConstr = SingleValueConstr Int" + , "" + , "derive instance Generic SingleValueConstr _" + , "" + , "derive instance Newtype SingleValueConstr _" ] in doc `shouldRender` txt it @@ -225,9 +262,9 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "data SingleProduct = SingleProduct String Int", - "", - "derive instance Generic SingleProduct _" + [ "data SingleProduct = SingleProduct String Int" + , "" + , "derive instance Generic SingleProduct _" ] in doc `shouldRender` txt it "tests generation Eq instances for polymorphic types" $ @@ -238,17 +275,17 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt it "tests generation of Ord instances for polymorphic types" $ @@ -259,21 +296,101 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", - "", - "derive instance (Ord a, Ord b) => Ord (SingleRecord a b)", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" + , "derive instance (Ord a, Ord b) => Ord (SingleRecord a b)" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt + it "tests the generation of a CTL HasConstrIndices/ToData/FromData" $ + let advanced' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumTypeIndexed @TwoRecords) + modules = sumTypeToModule advanced' + m = head . map (moduleToText settings) . Map.elems $ modules + txt = + T.unlines + [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Prelude" + , "" + , "import ConstrIndices (class HasConstrIndices, constrIndices, fromConstr2Index)" + , "import Control.Lazy (defer)" + , "import Data.Argonaut.Core (jsonNull)" + , "import Data.Argonaut.Decode (class DecodeJson, decodeJson)" + , "import Data.Argonaut.Decode.Aeson ((), (), (), decode, null)" + , "import Data.Argonaut.Encode (class EncodeJson, encodeJson)" + , "import Data.Argonaut.Encode.Aeson ((>$<), (>/\\<), encode, null)" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Maybe (Maybe(Nothing, Just))" + , "import Data.Newtype (unwrap)" + , "import Data.Tuple (Tuple(Tuple))" + , "import Data.Tuple.Nested ((/\\))" + , "import FromData (class FromData, fromData, genericFromData)" + , "import ToData (class ToData, genericToData, toData)" + , "import Data.Argonaut.Decode.Aeson as D" + , "import Data.Argonaut.Encode.Aeson as E" + , "import Data.Map as Map" + , "" + , "data TwoRecords" + , " = FirstRecord" + , " { _fra :: String" + , " , _frb :: Int" + , " }" + , " | SecondRecord" + , " { _src :: Int" + , " , _srd :: Array Int" + , " }" + , "" + , "derive instance Generic TwoRecords _" + , "" + , "instance HasConstrIndices TwoRecords where" + , " constrIndices _ = fromConstr2Index [Tuple \"FirstRecord\" 0,Tuple \"SecondRecord\" 1]" + , "" + , "instance ToData TwoRecords where" + , " toData x = genericToData x" + , "" + , "instance FromData TwoRecords where" + , " fromData pd = genericFromData pd" + , "" + , "instance EncodeJson TwoRecords where" + , " encodeJson = defer \\_ -> case _ of" + , " FirstRecord {_fra, _frb} -> encodeJson" + , " { tag: \"FirstRecord\"" + , " , _fra: flip E.encode _fra E.value" + , " , _frb: flip E.encode _frb E.value" + , " }" + , " SecondRecord {_src, _srd} -> encodeJson" + , " { tag: \"SecondRecord\"" + , " , _src: flip E.encode _src E.value" + , " , _srd: flip E.encode _srd E.value" + , " }" + , "" + , "instance DecodeJson TwoRecords where" + , " decodeJson = defer \\_ -> D.decode" + , " $ D.sumType \"TwoRecords\" $ Map.fromFoldable" + , " [ \"FirstRecord\" /\\ (FirstRecord <$> D.object \"FirstRecord\"" + , " { _fra: D.value :: _ String" + , " , _frb: D.value :: _ Int" + , " })" + , " , \"SecondRecord\" /\\ (SecondRecord <$> D.object \"SecondRecord\"" + , " { _src: D.value :: _ Int" + , " , _srd: D.value :: _ (Array Int)" + , " })" + , " ]" + ] + in m `shouldBe` txt shouldRender :: Doc -> Text -> Expectation shouldRender actual expected = renderText actual `shouldBe` T.stripEnd expected diff --git a/test/TestData.hs b/test/TestData.hs index c4020a02..8ce09b85 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -1,22 +1,47 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore SingleValueConstr #-} module TestData where import Data.Functor.Classes (Eq1 (liftEq)) -import Data.Proxy +import Data.Proxy () import Data.Text (Text) -import Data.Typeable +import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Language.PureScript.Bridge +import Language.PureScript.Bridge ( + BridgePart, + DataConstructor, + FullBridge, + HasHaskType (haskType), + HaskellType, + Language (Haskell, PureScript), + PSType, + SumType (..), + TypeInfo, + bridgeSumType, + buildBridge, + defaultBridge, + mkSumType, + mkTypeInfo, + typeModule, + typeName, + (<|>), + (^==), + ) import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) -import Language.PureScript.Bridge.PSTypes +import Language.PureScript.Bridge.PSTypes (psString) +import PlutusTx.Aux (HasConstrIndices (getConstrIndices), mkIndicesDefault) -- Check that examples compile: textBridge :: BridgePart @@ -34,10 +59,10 @@ data Foo = Foo | Bar Int | FooBar Int Text - deriving (Eq, Ord, Generic, Typeable, Show) + deriving stock (Eq, Ord, Generic, Typeable, Show) data Func a = Func Int a - deriving (Eq, Ord, Functor, Generic, Typeable, Show) + deriving stock (Eq, Ord, Functor, Generic, Typeable, Show) instance Eq1 Func where liftEq eq (Func n x) (Func m y) = n == m && x `eq` y @@ -46,41 +71,43 @@ data Test = TestIntInt Int Int | TestBool {bool :: Bool} | TestVoid - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) data Bar a b m c = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a | Bar4 {myMonadicResult :: m b} - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) data SingleRecord a b = SingleRecord - { _a :: a, - _b :: b, - c :: String + { _a :: a + , _b :: b + , c :: String } - deriving (Generic, Eq, Ord, Typeable, Show) + deriving stock (Generic, Eq, Ord, Typeable, Show) data TwoRecords = FirstRecord - { _fra :: String, - _frb :: Int + { _fra :: String + , _frb :: Int } | SecondRecord - { _src :: Int, - _srd :: [Int] + { _src :: Int + , _srd :: [Int] } - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) + +mkIndicesDefault ''TwoRecords newtype SomeNewtype = SomeNewtype Int - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) data SingleValueConstr = SingleValueConstr Int - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) data SingleProduct = SingleProduct Text Int - deriving (Generic, Typeable, Show) + deriving stock (Generic, Typeable, Show) a :: HaskellType a = mkTypeInfo @(Either String Int) @@ -95,6 +122,6 @@ b :: SumType 'Haskell b = mkSumType @(Either String Int) t :: TypeInfo 'PureScript -cs :: [DataConstructor 'PureScript] +cs :: [(Int, DataConstructor 'PureScript)] psB :: SumType 'PureScript psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) b