diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index f7f14d72b..bd51e3f9a 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -3,6 +3,10 @@ name: Build and publish application binaries on: workflow_dispatch: push: + paths: + - '**' + - '!.github/**' + - '.github/workflows/applications.yml' jobs: build: diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml new file mode 100644 index 000000000..108af0d7f --- /dev/null +++ b/.github/workflows/nix.yml @@ -0,0 +1,42 @@ +name: Build and cache with Nix + +on: + workflow_dispatch: + push: + paths: + - '**' + - '!.github/**' + - '.github/workflows/nix.yml' + +jobs: + build-and-cache: + runs-on: ${{ matrix.os }} + timeout-minutes: 740 + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest, macos-m1] + steps: + - name: Checkout repository + uses: actions/checkout@v3 + + - name: Set up Nix with caching + uses: kadena-io/setup-nix-with-cache/by-root@v3 + with: + cache_url: s3://nixcache.chainweb.com?region=us-east-1 + signing_private_key: ${{ secrets.NIX_CACHE_PRIVATE_KEY }} + + - name: Set up AWS credentials + uses: aws-actions/configure-aws-credentials@v2 + with: + aws-access-key-id: ${{ secrets.NIX_CACHE_AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.NIX_CACHE_AWS_SECRET_ACCESS_KEY }} + aws-region: us-east-1 + + - name: Give root user AWS credentials + uses: kadena-io/setup-nix-with-cache/copy-root-aws-credentials@v3 + + - name: Build and cache artifacts + run: | + echo Building the project and its devShell + nix build .#check --log-lines 500 --show-trace diff --git a/flake.lock b/flake.lock index d9d6efd1c..cfa63b023 100644 --- a/flake.lock +++ b/flake.lock @@ -16,21 +16,6 @@ "type": "github" } }, - "blank": { - "locked": { - "lastModified": 1625557891, - "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", - "owner": "divnix", - "repo": "blank", - "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "blank", - "type": "github" - } - }, "cabal-32": { "flake": false, "locked": { @@ -98,64 +83,6 @@ "type": "github" } }, - "devshell": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1663445644, - "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", - "owner": "numtide", - "repo": "devshell", - "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "devshell", - "type": "github" - } - }, - "dmerge": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1659548052, - "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", - "owner": "divnix", - "repo": "data-merge", - "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "data-merge", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -173,32 +100,16 @@ "type": "github" } }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1650374568, - "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b4a34015c698c7793d592d66adbab377907a2be8", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "inputs": { "systems": "systems" }, "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", + "lastModified": 1689068808, + "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", "owner": "numtide", "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", + "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", "type": "github" }, "original": { @@ -223,36 +134,6 @@ "type": "github" } }, - "flake-utils_3": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_4": { - "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, "ghc-8.6.5-iohk": { "flake": false, "locked": { @@ -270,33 +151,14 @@ "type": "github" } }, - "gomod2nix": { - "inputs": { - "nixpkgs": "nixpkgs_2", - "utils": "utils" - }, - "locked": { - "lastModified": 1655245309, - "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", - "owner": "tweag", - "repo": "gomod2nix", - "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", - "type": "github" - }, - "original": { - "owner": "tweag", - "repo": "gomod2nix", - "type": "github" - } - }, "hackage": { "flake": false, "locked": { - "lastModified": 1682555144, - "narHash": "sha256-A64bJ9MZhNplD74OQOOF+JZq4BaV2gAuYuIZC/6WA94=", + "lastModified": 1692318155, + "narHash": "sha256-e4npK3xeIIIzq1MDFYhpT3cR37DtEttOdGE7uFi71PQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "1cf7e1a3746cc285aeebb0f87fbed10e23aa6b70", + "rev": "0a259b13134e5ac7f9ca408365fd240bd4b42645", "type": "github" }, "original": { @@ -317,6 +179,7 @@ "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -329,17 +192,17 @@ "nixpkgs-2111": "nixpkgs-2111", "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage", - "tullia": "tullia" + "stackage": "stackage" }, "locked": { - "lastModified": 1682583633, - "narHash": "sha256-ws/1ZuZHboqMGzd2Zdfa7o5Sq1V2AgTUSZQkVY1N8pQ=", + "lastModified": 1692319830, + "narHash": "sha256-KD5SPPtJETa83lWr5WwhWWRbSelGhGSkeZ7cqweJfoc=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "6ab363fc7df582147a0629ba6df064ea96c500b0", + "rev": "90e45988f1ad35d55e890cef16d7b1a5de5e6196", "type": "github" }, "original": { @@ -365,6 +228,23 @@ "type": "github" } }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -404,37 +284,14 @@ "type": "indirect" } }, - "incl": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1669263024, - "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", - "owner": "divnix", - "repo": "incl", - "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "incl", - "type": "github" - } - }, "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1688517130, + "narHash": "sha256-hUqfxSlo+ffqVdkSZ1EDoB7/ILCL25eYkcCXW9/P3Wc=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "9151db2a9a61d7f5fe52ff8836f18bbd0fd8933c", + "revCount": 13, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -460,35 +317,6 @@ "type": "github" } }, - "n2c": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1665039323, - "narHash": "sha256-SAh3ZjFGsaCI8FRzXQyp56qcGdAqgKEfJWPCQ0Sr7tQ=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "b008fe329ffb59b67bf9e7b08ede6ee792f2741a", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, "nix": { "inputs": { "lowdown-src": "lowdown-src", @@ -510,95 +338,6 @@ "type": "github" } }, - "nix-nomad": { - "inputs": { - "flake-compat": "flake-compat_2", - "flake-utils": [ - "haskellNix", - "tullia", - "nix2container", - "flake-utils" - ], - "gomod2nix": "gomod2nix", - "nixpkgs": [ - "haskellNix", - "tullia", - "nixpkgs" - ], - "nixpkgs-lib": [ - "haskellNix", - "tullia", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1658277770, - "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", - "owner": "tristanpemble", - "repo": "nix-nomad", - "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", - "type": "github" - }, - "original": { - "owner": "tristanpemble", - "repo": "nix-nomad", - "type": "github" - } - }, - "nix2container": { - "inputs": { - "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_3" - }, - "locked": { - "lastModified": 1658567952, - "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nixago": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixago-exts": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1661824785, - "narHash": "sha256-/PnwdWoO/JugJZHtDUioQp3uRiWeXHUdgvoyNbXesz8=", - "owner": "nix-community", - "repo": "nixago", - "rev": "8c1f9e5f1578d4b2ea989f618588d62a335083c3", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "nixago", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1657693803, @@ -665,11 +404,11 @@ }, "nixpkgs-2205": { "locked": { - "lastModified": 1672580127, - "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0874168639713f547c05947c76124f78441ea46c", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", "type": "github" }, "original": { @@ -681,11 +420,11 @@ }, "nixpkgs-2211": { "locked": { - "lastModified": 1675730325, - "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", "type": "github" }, "original": { @@ -695,86 +434,55 @@ "type": "github" } }, - "nixpkgs-regression": { - "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - } - }, - "nixpkgs-unstable": { + "nixpkgs-2305": { "locked": { - "lastModified": 1675758091, - "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", + "lastModified": 1690680713, + "narHash": "sha256-NXCWA8N+GfSQyoN7ZNiOgq/nDJKOp5/BHEpiZP8sUZw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", + "rev": "b81af66deb21f73a70c67e5ea189568af53b1e8c", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_2": { + "nixpkgs-regression": { "locked": { - "lastModified": 1653581809, - "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, - "nixpkgs_3": { + "nixpkgs-unstable": { "locked": { - "lastModified": 1654807842, - "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", + "lastModified": 1690720142, + "narHash": "sha256-GywuiZjBKfFkntQwpNQfL+Ksa2iGjPprBGL0/psgRZM=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", + "rev": "3acb5c4264c490e7714d503c7166a3fde0c51324", "type": "github" }, "original": { "owner": "NixOS", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_4": { - "locked": { - "lastModified": 1665087388, - "narHash": "sha256-FZFPuW9NWHJteATOf79rZfwfRn5fE0wi9kRzvGfDHPA=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "95fda953f6db2e9496d2682c4fc7b82f959878f7", - "type": "github" - }, - "original": { - "owner": "nixos", "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_5": { + "nixpkgs_2": { "locked": { "lastModified": 1669833724, "narHash": "sha256-/HEZNyGbnQecrgJnfE8d0WC5c1xuPSD2LUpB6YXlg4c=", @@ -790,21 +498,6 @@ "type": "github" } }, - "nosys": { - "locked": { - "lastModified": 1667881534, - "narHash": "sha256-FhwJ15uPLRsvaxtt/bNuqE/ykMpNAPF0upozFKhTtXM=", - "owner": "divnix", - "repo": "nosys", - "rev": "2d0d5207f6a230e9d0f660903f8db9807b54814f", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "nosys", - "type": "github" - } - }, "old-ghc-nix": { "flake": false, "locked": { @@ -826,17 +519,17 @@ "inputs": { "flake-utils": "flake-utils", "haskellNix": "haskellNix", - "nixpkgs": "nixpkgs_5" + "nixpkgs": "nixpkgs_2" } }, "stackage": { "flake": false, "locked": { - "lastModified": 1682467738, - "narHash": "sha256-zV/OwQDZt2rignAWhEEL3fa3+pMd9q1+2zRoNtDJi4s=", + "lastModified": 1692317324, + "narHash": "sha256-AofEuurJHrfMljrCAkMKTWBC5xGluhBZiAfHQ73224Y=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "fafaa2484ec29531796569f85d20ff30c363e8fc", + "rev": "4812a420235589a74f9278cca81f6dbf74ffb42f", "type": "github" }, "original": { @@ -845,51 +538,6 @@ "type": "github" } }, - "std": { - "inputs": { - "arion": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "blank": "blank", - "devshell": "devshell", - "dmerge": "dmerge", - "flake-utils": "flake-utils_4", - "incl": "incl", - "makes": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "microvm": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "n2c": "n2c", - "nixago": "nixago", - "nixpkgs": "nixpkgs_4", - "nosys": "nosys", - "yants": "yants" - }, - "locked": { - "lastModified": 1674526466, - "narHash": "sha256-tMTaS0bqLx6VJ+K+ZT6xqsXNpzvSXJTmogkraBGzymg=", - "owner": "divnix", - "repo": "std", - "rev": "516387e3d8d059b50e742a2ff1909ed3c8f82826", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "std", - "type": "github" - } - }, "systems": { "locked": { "lastModified": 1681028828, @@ -904,68 +552,6 @@ "repo": "default", "type": "github" } - }, - "tullia": { - "inputs": { - "nix-nomad": "nix-nomad", - "nix2container": "nix2container", - "nixpkgs": [ - "haskellNix", - "nixpkgs" - ], - "std": "std" - }, - "locked": { - "lastModified": 1675695930, - "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", - "owner": "input-output-hk", - "repo": "tullia", - "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "tullia", - "type": "github" - } - }, - "utils": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "yants": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1667096281, - "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", - "owner": "divnix", - "repo": "yants", - "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "yants", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index ea80a4e13..f2f30690d 100644 --- a/flake.nix +++ b/flake.nix @@ -24,10 +24,10 @@ pact-core = final.haskell-nix.project' { src = ./.; - compiler-nix-name = "ghc8107"; + compiler-nix-name = "ghc962"; shell.tools = { cabal = {}; - # haskell-language-server = {}; + haskell-language-server = {}; }; shell.buildInputs = with pkgs; [ zlib @@ -37,7 +37,14 @@ }; }) ]; - in flake // { + # This package depends on other packages at buildtime, but its output does not + # depend on them. This way, we don't have to download the entire closure to verify + # that those packages build. + mkCheck = name: package: pkgs.runCommand ("check-"+name) {} '' + echo ${name}: ${package} + echo works > $out + ''; + in flake // rec { packages.default = flake.packages."pact-core:exe:repl"; devShell = pkgs.haskellPackages.shellFor { @@ -46,9 +53,15 @@ buildInputs = with pkgs.haskellPackages; [ cabal-install + haskell-language-server ]; withHoogle = true; }; + packages.check = pkgs.runCommand "check" {} '' + echo ${mkCheck "pact-core" packages.default} + echo ${mkCheck "devShell" flake.devShell} + echo works > $out + ''; }); } diff --git a/pact-core.cabal b/pact-core.cabal index ffb3f0c74..e80e02a97 100644 --- a/pact-core.cabal +++ b/pact-core.cabal @@ -145,19 +145,11 @@ library typed-core Pact.Core.IR.Typecheck -- Typed core modules + Pact.Core.Typed.Type Pact.Core.Typed.Typecheck Pact.Core.Typed.Term Pact.Core.Typed.Overload - -- Untyped core - Pact.Core.Untyped.Term - Pact.Core.Untyped.Eval.Runtime - Pact.Core.Untyped.Eval.CEK - Pact.Core.Untyped.Eval.Runtime.CoreBuiltin - Pact.Core.Untyped.Eval.Runtime.RawBuiltin - Pact.Core.Untyped.Utils - - executable repl main-is: pact-core/Pact/Core/Repl.hs diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index 524ec31f4..1ead0d7f5 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -189,17 +189,7 @@ instance Pretty DesugarError where ExpectedFreeVariable t -> Pretty.hsep ["Expected free variable in expression, found locally bound: ", pretty t] --- data TypecheckError --- = UnificationError (Type Text) (Type Text) --- | ContextReductionError (Pred Text) --- | UnsupportedTypeclassGeneralization [Pred Text] --- | UnsupportedImpredicativity --- | OccursCheckFailure (Type Text) --- | TCInvariantFailure Text --- | TCUnboundTermVariable Text --- | TCUnboundFreeVariable ModuleName Text --- | DisabledGeneralization Text --- deriving Show + -- instance RenderError TypecheckError where -- renderError = \case diff --git a/pact-core/Pact/Core/IR/Term.hs b/pact-core/Pact/Core/IR/Term.hs index 267027f80..9fb2d058b 100644 --- a/pact-core/Pact/Core/IR/Term.hs +++ b/pact-core/Pact/Core/IR/Term.hs @@ -21,7 +21,7 @@ module Pact.Core.IR.Term where import Control.Lens -import Data.Foldable(fold) +import Data.Foldable(fold, find) import Data.Text(Text) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict(Map) @@ -367,6 +367,10 @@ instance Plated (Term name ty builtin info) where -- pure (DynInvoke n t i) Error e i -> pure (Error e i) +findIfDef :: Text -> Interface name ty builtin info -> Maybe (IfDef name ty builtin info) +findIfDef f iface = + find ((== f) . ifDefName) (_ifDefns iface) + -- Todo: qualify all of these makeLenses ''Module makeLenses ''Interface diff --git a/pact-core/Pact/Core/Persistence.hs b/pact-core/Pact/Core/Persistence.hs index 1ee569291..d2a06630b 100644 --- a/pact-core/Pact/Core/Persistence.hs +++ b/pact-core/Pact/Core/Persistence.hs @@ -311,7 +311,7 @@ mockPactDb = do createUsrTable :: IORef (Map TableName (Map RowKey RowData)) - -> _ + -> IORef (Map TableName (Map TxId [TxLog RowData])) -> TableName -> ModuleName -> IO () diff --git a/pact-core/Pact/Core/Type.hs b/pact-core/Pact/Core/Type.hs index ad9d8dce1..d424797f9 100644 --- a/pact-core/Pact/Core/Type.hs +++ b/pact-core/Pact/Core/Type.hs @@ -19,9 +19,9 @@ module Pact.Core.Type , pattern TyUnit , pattern TyGuard , typeOfLit + , BuiltinTC(..) + , Pred(..) , literalPrim --- , BuiltinTC(..) --- , Pred(..) -- , renderType -- , renderPred -- , TypeOfDef(..) @@ -118,30 +118,30 @@ pattern TyGuard = TyPrim PrimGuard -- Built in typeclasses --- data BuiltinTC --- = Eq --- | Ord --- | Show --- | Add --- | Num --- | ListLike --- | Fractional --- deriving (Show, Eq, Ord) - --- instance Pretty BuiltinTC where --- pretty = \case --- Eq -> "Eq" --- Ord -> "Ord" --- Show -> "Show" --- Add -> "Add" --- Num -> "Num" --- ListLike -> "ListLike" --- Fractional -> "Fractional" +data BuiltinTC + = Eq + | Ord + | Show + | Add + | Num + | ListLike + | Fractional + deriving (Show, Eq, Ord) + +instance Pretty BuiltinTC where + pretty = \case + Eq -> "Eq" + Ord -> "Ord" + Show -> "Show" + Add -> "Add" + Num -> "Num" + ListLike -> "ListLike" + Fractional -> "Fractional" -- -- Note, no superclasses, for now --- data Pred tv --- = Pred BuiltinTC (Type tv) --- deriving (Show, Eq, Functor, Foldable, Traversable) +data Pred + = Pred BuiltinTC Type + deriving (Show, Eq) -- data TypeScheme tv = -- TypeScheme [tv] [Pred tv] (Type tv) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index fb85f8fe4..8457c6fc1 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -42,10 +42,10 @@ import Control.Monad.Except import Data.Void -- import Data.Dynamic (Typeable) import Data.RAList(RAList) -import Data.Foldable(traverse_, foldlM) +import Data.Foldable(traverse_, foldlM, toList) import Data.Functor(($>)) import Data.STRef -import Data.Maybe(mapMaybe) +import Data.Maybe(fromMaybe) import Data.Map(Map) import Data.Text(Text) import Data.List.NonEmpty(NonEmpty(..)) @@ -57,14 +57,16 @@ import qualified Data.RAList as RAList import qualified Data.Set as Set import Pact.Core.Builtin -import Pact.Core.Type +import Pact.Core.Hash (ModuleHash) +import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..), BuiltinTC(..)) +import Pact.Core.Typed.Type import Pact.Core.Names -import Pact.Core.Errors -import Pact.Core.Persistence +import Pact.Core.Persistence hiding (loaded) import Pact.Core.Capabilities +import qualified Pact.Core.Type as IR import qualified Pact.Core.IR.Term as IR import qualified Pact.Core.Typed.Term as Typed -import qualified Pact.Core.Untyped.Term as U +import qualified Pact.Core.Typed.Type as Typed -- inference based on https://okmij.org/ftp/ML/generalization.html -- Note: Type inference levels in the types @@ -76,6 +78,18 @@ import qualified Pact.Core.Untyped.Term as U type UniqueSupply s = STRef s Unique type Level = Int +data TypecheckError + = UnificationError (Type Text) (Type Text) + | ContextReductionError (Pred Text) + | UnsupportedTypeclassGeneralization [Pred Text] + | UnsupportedImpredicativity + | OccursCheckFailure (Type Text) + | TCInvariantFailure Text + | TCUnboundTermVariable Text + | TCUnboundFreeVariable ModuleName Text + | DisabledGeneralization Text + deriving Show + data Tv s = Unbound !Text !Unique !Level | Bound !Text !Unique @@ -95,7 +109,7 @@ data TCEnv s b i , _tcVarEnv :: RAList (Type (TvRef s)) -- ^ Builtins map, that uses the enum instance -- , _tcFree :: Map ModuleName (Map Text (Type Void)) - , _tcFree :: Map FullyQualifiedName (Def Name) + , _tcLoaded :: Loaded b i -- ^ Free variables , _tcLevel :: STRef s Level -- ^ Type Variable "Region" @@ -104,13 +118,14 @@ data TCEnv s b i makeLenses ''TCEnv -type TCType s = Type (TvRef s) -type TCPred s = Pred (TvRef s) +type TCType s = Typed.Type (TvRef s) +type TCPred s = Typed.Pred (TvRef s) -- | Term emitted by desugar -type IRTerm b i = IR.Term Name b i -type IRModule b i = IR.Module Name b i -type IRInterface b i = IR.Interface Name b i +type IRType = IR.Type +type IRTerm b i = IR.Term Name IRType b i +type IRModule b i = IR.Module Name IRType b i +type IRInterface b i = IR.Interface Name IRType b i -- | Term emitted by the typechecker prior to final generalization/unification. type TCTerm s b i = Typed.Term Name (TvRef s) (b, [TCType s], [TCPred s]) i @@ -142,12 +157,12 @@ type TypedInterface b i = Typed.OverloadedInterface NamedDeBruijn b i -- | Our inference monad, where we can plumb through generalization "regions", -- our variable environment and our "supply" of unique names newtype InferM s b i a = - InferT (ExceptT (PactError i) (ReaderT (TCEnv s b i) (ST s)) a) + InferT (ExceptT TypecheckError (ReaderT (TCEnv s b i) (ST s)) a) deriving ( Functor, Applicative, Monad , MonadReader (TCEnv s b i) - , MonadError (PactError i)) - via (ExceptT (PactError i) (ReaderT (TCEnv s b i) (ST s))) + , MonadError TypecheckError) + via (ExceptT TypecheckError (ReaderT (TCEnv s b i) (ST s))) class TypeOfBuiltin b where typeOfBuiltin :: b -> TypeScheme NamedDeBruijn @@ -323,7 +338,7 @@ instance TypeOfBuiltin RawBuiltin where -- RawCreateUserGuard -> let -- a = nd "a" 0 -- in TypeScheme [a] [] ((TyUnit :~> TyVar a) :~> TyGuard) - RawListAccess -> let + RawAt -> let a = nd "a" 0 in TypeScheme [a] [] (TyInt :~> TyList (TyVar a) :~> TyVar a) RawMakeList -> let @@ -335,6 +350,44 @@ instance TypeOfBuiltin RawBuiltin where TypeScheme [] [] (TyString :~> TyString) RawStrToList -> TypeScheme [] [] (TyString :~> TyList TyString) + RawSort -> let + aVar = nd "a" 0 + a = TyVar aVar + in TypeScheme [aVar] [Pred Ord a] (TyList a :~> TyList a) + RawSortObject -> error "sort object TODO" -- TODO + RawContains -> error "contains TODO" -- TODO + RawRemove -> error "remove TODO" -- TODO + RawStrToIntBase -> error "strtoint base" + RawBind -> error "bind" + RawRequireCapability -> error "require cap" + RawComposeCapability -> error "compose cap" + RawInstallCapability -> error "install cap" + RawEmitEvent -> error "emit event" + RawCreateCapabilityGuard -> error "create cap guard" + RawCreateModuleGuard -> error "create mod guard" + RawCreateTable -> error "create table" + RawDescribeKeyset -> error "descr keyset" + RawDescribeModule -> error "descr module" + RawDescribeTable -> error "descr table" + RawDefineKeySet -> error "define keyset" + RawDefineKeysetData -> error "define keyset data" + RawFoldDb -> error "fold db" + RawInsert -> error "insert" + RawKeyLog -> error "keylog" + RawKeys -> error "keys" + RawRead -> error "read" + RawSelect -> error "select" + RawUpdate -> error "update" + RawWithDefaultRead -> error "with default read" + RawWithRead -> error "with read" + RawWrite -> error "write" + RawTxIds -> error "txids" + RawTxLog -> error "txlog" + RawAndQ -> error "andq" + RawOrQ -> error "orq" + RawWhere -> error "where" + RawNotQ -> error "notq" + RawHash -> error "hash" where nd b a = NamedDeBruijn a b unaryNumType = @@ -375,8 +428,8 @@ instance TypeOfBuiltin RawBuiltin where in TypeScheme [aVar] [Pred ListLike a] (TyInt :~> a :~> a) instance TypeOfBuiltin b => TypeOfBuiltin (ReplBuiltin b) where - typeOfBuiltin = \case - RBuiltinWrap b -> typeOfBuiltin b + typeOfBuiltin (RBuiltinWrap b) = typeOfBuiltin b + typeOfBuiltin (RBuiltinRepl rb) = case rb of RExpect -> let aVar = nd "a" 0 aTv = TyVar aVar @@ -393,6 +446,7 @@ instance TypeOfBuiltin b => TypeOfBuiltin (ReplBuiltin b) where aVar = nd "a" 0 aTv = TyVar aVar in TypeScheme [aVar] [Pred Show aTv] (aTv :~> TyUnit) + r -> error $ "TODO repl builtin " <> show r where nd b a = NamedDeBruijn a b @@ -400,7 +454,7 @@ liftST :: ST s a -> InferM s b i a liftST action = InferT (ExceptT (Right <$> ReaderT (const action))) throwTypecheckError :: TypecheckError -> i -> InferM s b i a -throwTypecheckError te = throwError . PETypecheckError te +throwTypecheckError te _i = throwError te _dbgTypedTerm :: TCTerm s b i @@ -416,8 +470,8 @@ _dbgTypedTerm = \case Typed.Let n e1 e2 i -> Typed.Let n <$> _dbgTypedTerm e1 <*> _dbgTypedTerm e2 <*> pure i Typed.Builtin (b, tys, preds) i -> do - tys' <- traverse _dbgType tys - preds' <- traverse _dbgPred preds + tys' <- traverse _dbgTCType tys + preds' <- traverse _dbgTCPred preds pure (Typed.Builtin (b, tys', preds') i) Typed.Constant l i -> pure (Typed.Constant l i) Typed.TyApp t nelty i -> @@ -466,10 +520,25 @@ _dbgTvRef tv = readTvRef tv >>= \case ty' <- _dbgType ty pure $ "linked type<" <> T.pack (show ty') <> ">" -_dbgPred :: TCPred s -> InferM s b i (Pred Text) -_dbgPred (Pred i t) = Pred i <$> _dbgType t +_dbgTCPred :: TCPred s -> InferM s b i (Pred Text) +_dbgTCPred = error "dbgPred" -- TODO predicates -_dbgType :: TCType s -> InferM s b i (Type Text) +_dbgTCType :: TCType s -> InferM s b i (Type Text) +_dbgTCType = \case + TyVar tv -> readTvRef tv >>= \case + Unbound u l _ -> pure (TyVar ("unbound" <> T.pack (show (u, l)))) + Bound u l -> pure (TyVar ("bound" <> T.pack (show (u, l)))) + Link ty -> _dbgType ty + TyFun l r -> TyFun <$> _dbgType l <*> _dbgType r + TyList t -> TyList <$> _dbgType t + TyPrim p -> pure (TyPrim p) + TyModRef mr -> pure (TyModRef mr) + TyForall {} -> error "impredicative" + +_dbgPred :: Pred (TvRef s) -> InferM s b i (Pred Text) +_dbgPred (Pred b t) = Pred b <$> _dbgType t + +_dbgType :: Type (TvRef s) -> InferM s b i (Type Text) _dbgType = \case TyVar tv -> readTvRef tv >>= \case Unbound u l _ -> pure (TyVar ("unbound" <> T.pack (show (u, l)))) @@ -927,7 +996,7 @@ generalizeWithTerm' ty pp term = do TyVar rv -> readTvRef rv >>= \case Link tl -> nubPreds' (Pred tc tl :xs) elems _ -> - if elem p elems + if p `elem` elems then nubPreds' xs elems else nubPreds' xs (Pred tc x:elems) _ -> nubPreds' xs elems @@ -958,8 +1027,56 @@ generalizeWithTerm' ty pp term = do gen' (TyModRef mr) = pure ([], TyModRef mr) gen' t@TyForall{} = pure ([], t) -liftType :: Type Void -> Type a -liftType = fmap absurd +liftNoFreeVars :: Type Void -> Type a +liftNoFreeVars = fmap absurd + +liftType :: IR.Type -> Type a +liftType = \case + IR.TyPrim prim -> TyPrim prim + IR.TyList ty -> TyList $ liftType ty + IR.TyModRef modName -> TyModRef modName + IR.TyObject _schema -> error "TODO" -- TyObject schema + IR.TyTable _schema -> error "TODO" -- TyTable schema + +toTypedArg :: Arg ty -> TypedArg ty +toTypedArg (Arg n (Just ty)) = TypedArg n ty +toTypedArg (Arg _ Nothing) = error "toTypedArg TODO must have type" + +unifyFunArgs + :: Traversable f + => [TCType s] + -> f (Arg IR.Type) + -> i + -> InferM s b i () +unifyFunArgs tys irArgs info + | Just irTys <- traverse _argType irArgs = do + when (length tys /= length irTys) $ error "Arguments mismatch" + let zipped = zip (toList irTys) tys + traverse_ (\(irTy, ty) -> unify (liftType irTy) ty info) zipped + | otherwise = error "unspecified arg types" + +unifyFun + :: Traversable f + => TCType s + -> f (Arg IR.Type) + -> Maybe IR.Type + -> i + -> InferM s b i () +unifyFun funty irArgs (Just irRet) info = do + unifyFunArgs tys irArgs info + unify ret (liftType irRet) info + where + (tys, ret) = tyFunToArgList funty +unifyFun _ _ Nothing _ = error "unannotated return type" + +getTopLevelDef + :: MonadReader (TCEnv s b i) m + => Text + -> ModuleName + -> ModuleHash + -> m (Maybe (IR.Def Name IR.Type b i)) +getTopLevelDef name modname modhash = + view (tcLoaded . loAllLoaded . at (FullyQualifiedName modname name modhash)) checkTermType :: (TypeOfBuiltin b) @@ -976,15 +1093,13 @@ checkTermType checkty = \case pure (ty, v', []) Nothing -> throwTypecheckError (TCUnboundTermVariable n) i - NTopLevel mn _mh -> - view (tcFree . at (FullyQualifiedName mn n _mh)) >>= \case - Just (DefunType nty) -> do - let newVar = Typed.Var irn i - rty = liftType nty - unify rty checkty i - pure (rty, newVar, []) - _ -> - throwTypecheckError (TCUnboundFreeVariable mn n) i + NTopLevel mn mh -> + getTopLevelDef n mn mh >>= \case + Just (IR.Dfun df) -> do + unifyFun checkty (IR._dfunArgs df) (IR._dfunRType df) i + let rty = snd $ tyFunToArgList checkty + pure (rty, Typed.Var irn i, []) + _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case checkty of TyModRef mn -> do let newVar = Typed.Var irn i @@ -998,35 +1113,20 @@ checkTermType checkty = \case pure (TyModRef iface, Typed.Var irn i, []) _ -> error "incorrect type" _ -> error "checking modref against incorrect type" - IR.Lam ne te i -> - case tyFunToArgList checkty of - (tl, ret) -> do - when (length tl /= NE.length ne) $ error "Arguments mismatch" - let zipped = NE.zip ne (NE.fromList tl) - traverse_ (uncurry unifyArg) zipped - let args = RAList.fromList $ reverse tl - (_, te', preds) <- locally tcVarEnv (args RAList.++) $ checkTermType ret te - let ne' = over _1 fst <$> zipped - pure (checkty, Typed.Lam ne' te' i, preds) - where - unifyArg (_, Just tl) tr = unify (liftType tl) tr i - unifyArg _ _ = pure () - IR.Let txt m_ty e1 e2 i -> - case m_ty of - Just lty -> do - (_, e1', pe1) <- checkTermType (liftType lty) e1 - (_, e2', pe2) <- - locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 - let term' = Typed.Let txt e1' e2' i - pure (checkty, term', pe1 ++ pe2) - Nothing -> do - enterLevel - (te1, e1', pe1) <- inferTerm e1 - leaveLevel - (_, e2', pe2) <- - locally tcVarEnv (RAList.cons te1) $ checkTermType checkty e2 - let term' = Typed.Let txt e1' e2' i - pure (checkty, term', pe1 ++ pe2) + IR.Lam _info irArgs te i -> do + let (tl, ret) = tyFunToArgList checkty + unifyFunArgs tl irArgs i + let args = RAList.fromList $ reverse tl + (_, te', preds) <- locally tcVarEnv (args RAList.++) $ checkTermType ret te + let ne' = over _1 _argName <$> NE.zip irArgs (NE.fromList tl) + pure (checkty, Typed.Lam ne' te' i, preds) + IR.Let (Arg name mlty) e1 e2 i + | Just lty <- mlty -> do + (_, e1', pe1) <- checkTermType (liftType lty) e1 + (_, e2', pe2) <- locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 + let term' = Typed.Let name e1' e2' i + pure (checkty, term', pe1 ++ pe2) + | otherwise -> error "must have the type" IR.App te (h :| hs) i -> do (tapp, te', pe1) <- inferTerm te (rty, xs, ps) <- foldlM inferFunctionArgs (tapp, [], []) (h:hs) @@ -1071,6 +1171,7 @@ checkTermType checkty = \case (tes', p1) <- checkCapArgs na tes (ty', te', p2) <- checkTermType checkty te pure (ty', WithCapability na tes' te', p1 ++ p2) + {- TODO commented out in IR RequireCapability na tes -> do unify checkty TyUnit i (tes', p1) <- checkCapArgs na tes @@ -1087,19 +1188,23 @@ checkTermType checkty = \case unify checkty TyUnit i (tes', p1) <- checkCapArgs na tes pure (TyUnit, EmitEvent na tes', p1) + -} -- TODO: Enforce `na` is a name of a dfun and not a dcap -- as a matter of fact, the whole above block needs the same enforcement just -- for dfuns CreateUserGuard na tes -> case _nKind na of - NTopLevel mn mh -> - view (tcFree . at (FullyQualifiedName mn (_nName na) mh)) >>= \case - Just (DefunType fty) -> do - let (args, r) = tyFunToArgList fty - unify (liftType r) TyUnit i - when (length args /= length tes) $ error "invariant broken" - vs <- zipWithM (checkTermType . liftType) args tes - let tes' = view _2 <$> vs - pure (TyGuard, CreateUserGuard na tes', concat (view _3 <$> vs)) + NTopLevel modname modhash -> + getTopLevelDef (_nName na) modname modhash >>= \case + Just (IR.Dfun (IR.Defun _name mirArgs mrty _term _info)) + | Just rty <- mrty + , Just irArgs <- traverse _argType mirArgs -> do + let args = liftType <$> irArgs + unify (liftType rty) TyUnit i + when (length args /= length tes) $ error "invariant broken" + vs <- zipWithM checkTermType args tes + let tes' = view _2 <$> vs + pure (TyGuard, CreateUserGuard na tes', concatMap (view _3) vs) + | otherwise -> error "unannotated types" _ -> error "boom" _ -> error "invariant broken, must refer to a top level name" @@ -1113,7 +1218,7 @@ checkTermType checkty = \case IR.ListLit tes i -> case checkty of TyList ty -> do liTup <- traverse (checkTermType ty) tes - let preds = concat (view _3 <$> liTup) + let preds = concatMap (view _3) liTup term' = Typed.ListLit ty (view _2 <$> liTup) i pure (TyList ty, term', preds) _ -> do @@ -1124,18 +1229,8 @@ checkTermType checkty = \case (_, err', p1) <- checkTermType checkty errcase (_, body', p2) <- checkTermType checkty bodycase pure (checkty, Typed.Try err' body' i, p1 ++ p2) - IR.DynInvoke mref fn i -> do - (tmref, mref', preds) <- inferTerm mref - case tmref of - TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case U.findIfDef fn iface of - Just (U.IfDfun df) -> do - unify (liftType (U._ifdType df)) checkty i - pure (checkty, Typed.DynInvoke mref' fn i, preds) - _ -> error "boom" - _ -> error "boom" - _ -> error "boom" IR.Error txt i -> pure (checkty, Typed.Error checkty txt i, []) + IR.ObjectLit{} -> error "TODO" -- TODO new ctor checkCapArgs @@ -1145,14 +1240,26 @@ checkCapArgs -> InferM s reso i ([TCTerm s raw i], [TCPred s]) checkCapArgs na tes = case _nKind na of NTopLevel mn mh -> - view (tcFree . at (FullyQualifiedName mn (_nName na) mh)) >>= \case - Just (DefcapType dcargs _) -> do - when (length dcargs /= length tes) $ error "invariant broken dcap args" - vs <- zipWithM (checkTermType . liftType) dcargs tes - pure (view _2 <$> vs, concat (view _3 <$> vs)) + getTopLevelDef (_nName na) mn mh >>= \case + Just (IR.DCap dc) + | Just dcargs <- traverse IR._argType $ IR._dcapArgs dc -> do + when (length dcargs /= length tes) $ error "invariant broken dcap args" + vs <- zipWithM (checkTermType . liftType) dcargs tes + pure (view _2 <$> vs, concatMap (view _3) vs) + | otherwise -> error "unannotated types" _ -> error "invariant broken" _ -> error "invariant broken" +irFunToTc + :: [Arg IR.Type] + -> Maybe IR.Type + -> InferM s b i ([Type a], Type a) +irFunToTc irMArgs (Just irRet) + | Just irArgs <- traverse IR._argType irMArgs = do + pure (liftType <$> irArgs, liftType irRet) + | otherwise = error "unannotated arguments" +irFunToTc _ Nothing = error "unannotated return type" + -- Todo: bidirectionality inferTerm :: (TypeOfBuiltin b) @@ -1167,21 +1274,21 @@ inferTerm = \case pure (ty, v', []) Nothing -> throwTypecheckError (TCUnboundTermVariable n) i - NTopLevel mn _mh -> - view (tcFree . at (FullyQualifiedName mn n _mh)) >>= \case - Just (DefunType ty) -> do + NTopLevel mn mh -> + getTopLevelDef n mn mh >>= \case + Just (IR.Dfun df) -> do + (args, ret) <- irFunToTc (IR._dfunArgs df) (IR._dfunRType df) let newVar = Typed.Var irn i - pure (liftType ty, newVar, []) - _ -> - throwTypecheckError (TCUnboundFreeVariable mn n) i + pure (argListToTyFun args ret, newVar, []) + _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case ifs of [iface] -> do let v' = Typed.Var irn i pure (TyModRef iface, v', []) [] -> error "Module reference does not implement any interfaces" _ -> error "Cannot infer module reference " - IR.Lam nts e i -> do - let names = fst <$> nts + IR.Lam _info nts e i -> do + let names = _argName <$> nts ntys <- traverse withTypeInfo nts -- Todo: bidirectionality -- let m = IntMap.fromList $ NE.toList $ NE.zipWith (\n t -> (_irUnique n, t)) names ntys @@ -1191,7 +1298,7 @@ inferTerm = \case rty = foldr TyFun ty ntys pure (rty, Typed.Lam nts' e' i, preds) where - withTypeInfo p = case snd p of + withTypeInfo p = case _argType p of Just ty -> pure (liftType ty) Nothing -> TyVar <$> newTvRef IR.App te (h :| hs) i -> do @@ -1213,16 +1320,16 @@ inferTerm = \case -- preds' = concat (pte : NE.toList (view _3 <$> as)) -- unify te (foldr TyFun tv1 tys) i -- pure (tv1, Typed.App e' args' i, preds') - IR.Let n mty e1 e2 i -> do - enterLevel - (te1, e1', pe1) <- case mty of - Nothing -> inferTerm e1 - Just ty -> checkTermType (liftType ty) e1 - leaveLevel - -- Note: generalization is turned off. - -- (ts, e1Qual, deferred) <- generalizeWithTerm te1 pe1 e1Unqual - (te2, e2', pe2) <- locally tcVarEnv (RAList.cons te1) $ inferTerm e2 - pure (te2, Typed.Let n e1' e2' i, pe1 ++ pe2) + IR.Let (Arg name mlty) e1 e2 i + | Just lty <- mlty -> do + enterLevel + (te1, e1', pe1) <- checkTermType (liftType lty) e1 + leaveLevel + -- Note: generalization is turned off. + -- (ts, e1Qual, deferred) <- generalizeWithTerm te1 pe1 e1Unqual + (te2, e2', pe2) <- locally tcVarEnv (RAList.cons te1) $ inferTerm e2 + pure (te2, Typed.Let name e1' e2' i, pe1 ++ pe2) + | otherwise -> error "must have the type annotated here" IR.Sequence e1 e2 i -> do (_, e1', pe1) <- inferTerm e1 (te2, e2', pe2) <- inferTerm e2 @@ -1233,6 +1340,7 @@ inferTerm = \case (tes', p1) <- checkCapArgs na tes (ty', te', p2) <- inferTerm te pure (ty', WithCapability na tes' te', p1 ++ p2) + {- TODO commented out in IR RequireCapability na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyUnit, RequireCapability na tes', p1) @@ -1245,6 +1353,7 @@ inferTerm = \case EmitEvent na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyUnit, EmitEvent na tes', p1) + -} CreateUserGuard na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyGuard, CreateUserGuard na tes', p1) @@ -1282,7 +1391,7 @@ inferTerm = \case IR.ListLit li i -> do tv <- TyVar <$> newTvRef liTup <- traverse inferTerm li - let preds = concat (view _3 <$> liTup) + let preds = concatMap (view _3) liTup traverse_ (\(t,_, _) -> unify tv t i) liTup pure (TyList tv, Typed.ListLit tv (view _2 <$> liTup) i, preds) IR.Try e1 e2 i -> do @@ -1290,41 +1399,36 @@ inferTerm = \case (te2, e2', p2)<- inferTerm e2 unify te1 te2 i pure (te1, Typed.Try e1' e2' i, p1 ++ p2) - IR.DynInvoke mref fn i -> do - (tmref, mref', preds) <- inferTerm mref - case tmref of - TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case U.findIfDef fn iface of - Just (U.IfDfun df) -> do - pure (liftType (U._ifdType df), Typed.DynInvoke mref' fn i, preds) - _ -> error "boom" - _ -> error "boom" - _ -> error "boom" IR.Error e i -> do ty <- TyVar <$> newTvRef pure (ty, Typed.Error ty e i, []) + IR.ObjectLit{} -> error "inferTerm TODO" -- TODO new ctor + +toTypedArgs :: [Arg ty] -> [Type Void] -> [TypedArg (Type a)] +toTypedArgs = zipWith (\irArg ty -> TypedArg (IR._argName irArg) (liftNoFreeVars ty)) -- Todo: generic types? -- We can't generalize yet since -- we're not allowing type schemes just yet. inferDefun :: TypeOfBuiltin b - => IR.Defun Name b i + => IR.Defun Name IRType b i -> InferM s b' i (TypedDefun b i) inferDefun (IR.Defun name dfargs dfRetType term info) = do enterLevel - let dfTy = foldr TyFun retType dfArgs' + (argTys, ret) <- irFunToTc dfargs dfRetType + let args = toTypedArgs dfargs argTys (termTy, term', preds) <- inferTerm term leaveLevel checkReducible preds (view IR.termInfo term) -- fail "typeclass constraints not supported in defun" - unify (liftType dfTy) termTy info + unify (liftNoFreeVars $ argListToTyFun argTys ret) termTy info fterm <- noTyVarsinTerm info term' - pure (Typed.Defun name (liftType dfTy) fterm info) + pure (Typed.Defun name args (liftNoFreeVars ret) fterm info) inferDefConst :: TypeOfBuiltin b - => IR.DefConst Name b i + => IR.DefConst Name IRType b i -> InferM s b' i (TypedDefConst b i) inferDefConst (IR.DefConst name dcTy term info) = do enterLevel @@ -1334,57 +1438,57 @@ inferDefConst (IR.DefConst name dcTy term info) = do fterm <- noTyVarsinTerm info term' let dcTy' = liftType <$> dcTy _ <- maybe (pure ()) (\dct -> unify dct termTy info) dcTy' - rty' <- ensureNoTyVars info (maybe termTy id dcTy') + rty' <- ensureNoTyVars info (fromMaybe termTy dcTy') pure (Typed.DefConst name rty' fterm info) inferDefCap :: TypeOfBuiltin b - => IR.DefCap Name b i + => IR.DefCap Name IRType b i -> InferM s b' i (TypedDefCap b i) -inferDefCap (IR.DefCap name arity argtys rty term meta i) = do - let ty = foldr TyFun rty argtys - (termTy, term', preds) <- checkTermType (liftType ty) term +inferDefCap (IR.DefCap name arity dcargs dcRetType term meta i) = do + (argtys, rty) <- irFunToTc dcargs dcRetType + let ty = liftNoFreeVars $ argListToTyFun argtys rty + args = toTypedArgs dcargs argtys + (termTy, term', preds) <- checkTermType ty term checkReducible preds i - unify (liftType ty) (termTy) i + unify ty termTy i fterm <- noTyVarsinTerm i term' - pure (Typed.DefCap name arity argtys rty fterm meta i) + pure (Typed.DefCap name arity args (liftNoFreeVars rty) fterm meta i) inferDef :: TypeOfBuiltin b - => IR.Def Name b i + => IR.Def Name IRType b i -> InferM s b' i (TypedDef b i) inferDef = \case IR.Dfun d -> Typed.Dfun <$> inferDefun d IR.DConst d -> Typed.DConst <$> inferDefConst d IR.DCap dc -> Typed.DCap <$> inferDefCap dc + IR.DSchema {} -> error "TODO infer defs" -- TODO + IR.DTable {} -> error "TODO infer tables" -- TODO inferIfDef :: TypeOfBuiltin b - => IR.IfDef Name b i + => IR.IfDef Name IRType b i -> InferM s b' i (TypedIfDef b i) inferIfDef = \case - IR.IfDfun ifd -> - pure (Typed.IfDfun (Typed.IfDefun (IR._ifdName ifd) (IR._ifdType ifd) (IR._ifdInfo ifd))) + IR.IfDfun ifd -> do + let irArgs = IR._ifdArgs ifd + (argtys, rty) <- irFunToTc irArgs (IR._ifdRType ifd) + let args = toTypedArgs irArgs argtys + pure (Typed.IfDfun (Typed.IfDefun (IR._ifdName ifd) args rty (IR._ifdInfo ifd))) IR.IfDConst dc -> Typed.IfDConst <$> inferDefConst dc - IR.IfDCap (IR.IfDefCap n argtys rty i) -> + IR.IfDCap (IR.IfDefCap n irArgs irRty i) -> do + (argtys, rty) <- irFunToTc irArgs irRty pure $ Typed.IfDCap (Typed.IfDefCap n argtys rty i) inferModule :: TypeOfBuiltin b - => IR.Module Name b i + => IR.Module Name IRType b i -> InferM s b' i (TypedModule b i) inferModule (IR.Module mname mgov defs blessed imports impl mh info) = do - fv <- view tcFree - (defs', _) <- foldlM infer' ([], fv) defs - pure (Typed.Module mname mgov (reverse defs') blessed imports impl mh info) - where - infer' (xs, m) d = do - def' <- local (set tcFree m) (inferDef d) - let name' = FullyQualifiedName mname (Typed.defName def') mh - dty = fmap absurd (Typed.defType def') - m' = M.insert name' dty m - pure (def':xs, m') + defs' <- traverse inferDef defs + pure (Typed.Module mname mgov defs' blessed imports impl mh info) inferInterface :: TypeOfBuiltin b @@ -1426,56 +1530,24 @@ inferTermGen term = do inferTopLevel :: TypeOfBuiltin b - => Loaded reso i - -> IR.TopLevel Name b i - -> InferM s reso i (TypedTopLevel b i, Loaded reso i) -inferTopLevel loaded = \case - IR.TLModule m -> do - tcm <- inferModule m - let toFqn df = FullyQualifiedName (Typed._mName tcm) (Typed.defName df) (Typed._mHash tcm) - newTLs = M.fromList $ (\df -> (toFqn df, Typed.defType df)) <$> Typed._mDefs tcm - loaded' = over loAllTyped (M.union newTLs) loaded - pure (Typed.TLModule tcm, loaded') - IR.TLTerm m -> (, loaded) . Typed.TLTerm . snd <$> inferTermNonGen m - IR.TLInterface i -> do - tci <- inferInterface i - let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) - newTLs = M.fromList $ fmap (\df -> (toFqn df, DefunType (Typed._dcType df))) $ mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) - loaded' = over loAllTyped (M.union newTLs) loaded - pure (Typed.TLInterface tci, loaded') + => IR.TopLevel Name IRType b i + -> InferM s reso i (TypedTopLevel b i) +inferTopLevel = \case + IR.TLModule m -> Typed.TLModule <$> inferModule m + IR.TLTerm m -> Typed.TLTerm . snd <$> inferTermNonGen m + IR.TLInterface i -> Typed.TLInterface <$> inferInterface i + IR.TLUse u -> pure $ Typed.TLUse u inferReplTopLevel :: TypeOfBuiltin b - => Loaded reso i - -> IR.ReplTopLevel Name b i - -> InferM s reso i (TypedReplTopLevel b i, Loaded reso i) -inferReplTopLevel loaded = \case - IR.RTLModule m -> do - tcm <- inferModule m - let toFqn df = FullyQualifiedName (Typed._mName tcm) (Typed.defName df) (Typed._mHash tcm) - newTLs = M.fromList $ (\df -> (toFqn df, Typed.defType df)) <$> Typed._mDefs tcm - loaded' = over loAllTyped (M.union newTLs) loaded - pure (Typed.RTLModule tcm, loaded') - IR.RTLTerm m -> (, loaded) . Typed.RTLTerm . snd <$> inferTermNonGen m + => IR.ReplTopLevel Name IRType b i + -> InferM s reso i (TypedReplTopLevel b i) +inferReplTopLevel = \case -- Todo: if we don't update the module hash to update linking, -- repl defuns and defconsts will break invariants about - IR.RTLDefun dfn -> do - dfn' <- inferDefun dfn - let newFqn = FullyQualifiedName replModuleName (Typed._dfunName dfn') replModuleHash - let loaded' = over loAllTyped (M.insert newFqn (DefunType (Typed._dfunType dfn'))) loaded - pure (Typed.RTLDefun dfn', loaded') - IR.RTLDefConst dconst -> do - dc <- inferDefConst dconst - let newFqn = FullyQualifiedName replModuleName (Typed._dcName dc) replModuleHash - let loaded' = over loAllTyped (M.insert newFqn (DefunType (Typed._dcType dc))) loaded - pure (Typed.RTLDefConst dc, loaded') - IR.RTLInterface i -> do - tci <- inferInterface i - let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) - newTLs = M.fromList $ fmap (\df -> (toFqn df, DefunType (Typed._dcType df))) $ mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) - loaded' = over loAllTyped (M.union newTLs) loaded - pure (Typed.RTLInterface tci, loaded') - + IR.RTLDefun dfn -> Typed.RTLDefun <$> inferDefun dfn + IR.RTLDefConst dconst -> Typed.RTLDefConst <$> inferDefConst dconst + IR.RTLTopLevel tl -> Typed.RTLTopLevel <$> inferTopLevel tl -- | Transform types into their debruijn-indexed version -- Essentially: Start at depth 0: @@ -1585,6 +1657,8 @@ ensureNoTyVarsPred -> InferM s b i (Pred NamedDeBruijn) ensureNoTyVarsPred i (Pred tc ty) = Pred tc <$> ensureNoTyVars i ty +-- TODO here and in ensure* functions, +-- is it really needed, or can we do the same trick as with `Type Void`? noTyVarsinTerm :: i -> TCTerm s b' i @@ -1700,18 +1774,18 @@ dbjTyp i env depth = \case runInfer :: Loaded b i -> InferM s b i a - -> ST s (Either (PactError i) a) + -> ST s (Either TypecheckError a) runInfer loaded (InferT act) = do uref <- newSTRef 0 lref <- newSTRef 1 - let tcs = TCState uref mempty (_loAllTyped loaded) lref (_loModules loaded) + let tcs = TCState uref mempty loaded lref (_loModules loaded) runReaderT (runExceptT act) tcs runInferTerm :: TypeOfBuiltin b => Loaded b' i -> IRTerm b i - -> Either (PactError i) (TypeScheme NamedDeBruijn, TypedGenTerm b i) + -> Either TypecheckError (TypeScheme NamedDeBruijn, TypedGenTerm b i) runInferTerm loaded term0 = runST $ runInfer loaded $ inferTermGen term0 @@ -1719,7 +1793,7 @@ runInferTermNonGen :: TypeOfBuiltin b => Loaded b' i -> IRTerm b i - -> Either (PactError i) (TypeScheme NamedDeBruijn, TypedTerm b i) + -> Either TypecheckError (TypeScheme NamedDeBruijn, TypedTerm b i) runInferTermNonGen loaded term0 = runST $ runInfer loaded $ inferTermNonGen term0 @@ -1727,23 +1801,23 @@ runInferModule :: TypeOfBuiltin b => Loaded b' i -> IRModule b i - -> Either (PactError i) (TypedModule b i) + -> Either TypecheckError (TypedModule b i) runInferModule loaded term0 = runST $ runInfer loaded (inferModule term0) runInferTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.TopLevel Name b i - -> Either (PactError i) (TypedTopLevel b i, Loaded reso i) + -> IR.TopLevel Name IRType b i + -> Either TypecheckError (TypedTopLevel b i) runInferTopLevel l tl = - runST $ runInfer l (inferTopLevel l tl) + runST $ runInfer l (inferTopLevel tl) runInferReplTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.ReplTopLevel Name b i - -> Either (PactError i) (TypedReplTopLevel b i, Loaded reso i) + -> IR.ReplTopLevel Name IRType b i + -> Either TypecheckError (TypedReplTopLevel b i) runInferReplTopLevel l tl = - runST $ runInfer l (inferReplTopLevel l tl) + runST $ runInfer l (inferReplTopLevel tl) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 2443d199b..acef2897b 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -23,9 +23,10 @@ import Control.Monad.Except import Data.Text(Text) import Data.List.NonEmpty(NonEmpty(..)) -import qualified Data.Text as T +-- import qualified Data.Text as T -import Pact.Core.Type +import Pact.Core.Type (BuiltinTC(..)) +import Pact.Core.Typed.Type import Pact.Core.Names import Pact.Core.Builtin import Pact.Core.Typed.Term @@ -40,8 +41,9 @@ newtype OverloadM info a = , MonadError (PactError info)) via (Either (PactError info)) +-- Todo: proper overload error throwOverloadError :: String -> i -> OverloadM i a -throwOverloadError e = throwError . PEOverloadError (OverloadError (T.pack e)) +throwOverloadError e _ = error e class SolveOverload raw resolved | raw -> resolved where solveOverload @@ -101,24 +103,27 @@ instance SolveOverload RawBuiltin CoreBuiltin where liftRaw = id instance (SolveOverload raw resolved) => SolveOverload (ReplBuiltin raw) (ReplBuiltin resolved) where - solveOverload i b tys preds = case b of - RBuiltinWrap raw -> over termBuiltin RBuiltinWrap <$> solveOverload i raw tys preds + solveOverload i (RBuiltinWrap raw) tys preds = over termBuiltin RBuiltinWrap <$> solveOverload i raw tys preds + solveOverload i (RBuiltinRepl b) tys preds = case b of RExpect -> case preds of [Pred Eq t1, Pred Show t2] -> do pEq <- solveOverload i (liftRaw RawEq :: ReplBuiltin raw) tys [Pred Eq t1] pShow <- solveOverload i (liftRaw RawShow :: ReplBuiltin raw) tys [Pred Show t2] - let bApp = withTyApps (Builtin RExpect i) tys + let bApp = withTyApps (builtin RExpect i) tys pure (App bApp (pEq :| [pShow]) i) _ -> throwOverloadError "Expect" i - RExpectFailure -> pure $ withTyApps (Builtin RExpectFailure i) tys - RExpectThat -> pure $ withTyApps (Builtin RExpectThat i) tys + RExpectFailure -> pure $ withTyApps (builtin RExpectFailure i) tys + RExpectThat -> pure $ withTyApps (builtin RExpectThat i) tys RPrint -> case preds of [Pred Show t1] -> do eqT <- solveOverload i (liftRaw RawShow :: ReplBuiltin raw) tys [Pred Show t1] - let bApp = withTyApps (Builtin RPrint i) tys + let bApp = withTyApps (builtin RPrint i) tys pure (App bApp (pure eqT) i) _ -> throwOverloadError "Print" i + _ -> error "TODO builtin repls" + where + builtin = Builtin . RBuiltinRepl liftRaw r = RBuiltinWrap (liftRaw r) @@ -350,7 +355,7 @@ solveCoreOverload i b tys preds = case b of pure (Builtin ReadDecimal i) RawReadString -> pure (Builtin ReadString i) - RawListAccess -> + RawAt -> pure (Builtin ListAccess i) RawMakeList -> pure (Builtin MakeList i) @@ -363,6 +368,41 @@ solveCoreOverload i b tys preds = case b of RawReadKeyset -> pure (Builtin ReadKeyset i) RawEnforceGuard -> pure (Builtin EnforceGuard i) RawKeysetRefGuard -> pure (Builtin KeysetRefGuard i) + RawContains -> error "contains" -- TODO + RawSort -> error "sort" -- TODO + RawSortObject -> error "sortObject" -- TODO + RawRemove -> error "remove" -- TODO + RawStrToIntBase -> error "strtointbase" -- TODO + RawBind -> error "bind" -- TODO + RawRequireCapability -> error "require cap" + RawComposeCapability -> error "compose cap" + RawInstallCapability -> error "install cap" + RawEmitEvent -> error "emit event" + RawCreateCapabilityGuard -> error "create cap guard" + RawCreateModuleGuard -> error "create mod guard" + RawCreateTable -> error "create table" + RawDescribeKeyset -> error "descr keyset" + RawDescribeModule -> error "descr module" + RawDescribeTable -> error "descr table" + RawDefineKeySet -> error "define keyset" + RawDefineKeysetData -> error "define keyset data" + RawFoldDb -> error "fold db" + RawInsert -> error "insert" + RawKeyLog -> error "keylog" + RawKeys -> error "keys" + RawRead -> error "read" + RawSelect -> error "select" + RawUpdate -> error "update" + RawWithDefaultRead -> error "with default read" + RawWithRead -> error "with read" + RawWrite -> error "write" + RawTxIds -> error "txids" + RawTxLog -> error "txlog" + RawAndQ -> error "andq" + RawOrQ -> error "orq" + RawWhere -> error "where" + RawNotQ -> error "notq" + RawHash -> error "hash" singlePred :: [t] -> i -> (t -> OverloadM i a) -> String -> OverloadM i a singlePred preds i f msg = case preds of @@ -373,9 +413,9 @@ resolveDefun :: SolveOverload raw reso => OverloadedDefun tyname raw info -> OverloadM info (Defun Name tyname reso info) -resolveDefun (Defun dname ty term info) = do +resolveDefun (Defun dname args rty term info) = do term' <- resolveTerm term - pure (Defun dname ty term' info) + pure (Defun dname args rty term' info) resolveDefConst :: SolveOverload raw reso diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index e0c09d624..186eef802 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -40,8 +40,8 @@ module Pact.Core.Typed.Term , CoreEvalTopLevel , CoreEvalReplTopLevel , defName - , defType , defTerm + , defType -- Prisms and lenses , _IfDfun , _IfDConst @@ -57,7 +57,8 @@ import qualified Data.List.NonEmpty as NE import Pact.Core.Builtin import Pact.Core.Literal import Pact.Core.Names -import Pact.Core.Type +import Pact.Core.Type hiding (Pred, Type) +import Pact.Core.Typed.Type import Pact.Core.Imports import Pact.Core.Hash import Pact.Core.Guards @@ -66,13 +67,21 @@ import Pact.Core.Pretty(Pretty(..), pretty, (<+>)) import qualified Pact.Core.Pretty as Pretty +-- data Defun name tyname builtin info +-- = Defun +-- { _dfunName :: Text +-- , _dfunType :: Type Void +-- , _dfunTerm :: Term name tyname builtin info +-- , _dfunInfo :: info +-- } deriving Show data Defun name tyname builtin info = Defun { _dfunName :: Text - , _dfunType :: Type Void + , _dfunArgs :: [TypedArg (Type tyname)] + , _dfunRType :: Type tyname , _dfunTerm :: Term name tyname builtin info , _dfunInfo :: info - } deriving Show + } deriving (Show, Functor) data DefConst name tyname builtin info = DefConst @@ -86,12 +95,12 @@ data DefCap name tyname builtin info = DefCap { _dcapName :: Text , _dcapAppArity :: Int - , _dcapArgTypes :: [Type Void] - , _dcapRType :: Type Void + , _dcapArgs :: [TypedArg (Type tyname)] + , _dcapRType :: Type tyname , _dcapTerm :: Term name tyname builtin info , _dcapMeta :: Maybe (DefCapMeta name) , _dcapInfo :: info - } deriving Show + } deriving (Show, Functor) data Def name tyname builtin info @@ -105,11 +114,11 @@ data Def name tyname builtin info -- DPact (DefPact name builtin info) -- DSchema (DefSchema name info) -- DTable (DefTable name info) -defType :: Def name tyname builtin info -> TypeOfDef Void -defType = \case - Dfun d -> DefunType (_dfunType d) - DConst d -> DefunType (_dcType d) - DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) +-- defType :: Def name tyname builtin info -> TypeOfDef Void +-- defType = \case +-- Dfun d -> DefunType (_dfunType d) +-- DConst d -> DefunType (_dcType d) +-- DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) defName :: Def name tyname builtin i -> Text defName = \case @@ -123,6 +132,12 @@ defTerm = \case DConst d -> _dcTerm d DCap d -> _dcapTerm d +defType :: Def name tyname builtin info -> Type tyname +defType = \case + Dfun d -> argListToTyFun (_targType <$> _dfunArgs d) (_dfunRType d) + DConst d -> absurd <$> _dcType d + DCap d -> argListToTyFun (_targType <$> _dcapArgs d) (_dcapRType d) + data Module name tyname builtin info = Module { _mName :: ModuleName @@ -146,7 +161,8 @@ data Interface name tyname builtin info data IfDefun info = IfDefun { _ifdName :: Text - , _ifdType :: Type Void + , _ifdArgs :: [TypedArg (Type Void)] + , _ifdRType :: Type Void , _ifdInfo :: info } deriving Show @@ -168,14 +184,13 @@ data TopLevel name tyname builtin info = TLModule (Module name tyname builtin info) | TLInterface (Interface name tyname builtin info) | TLTerm (Term name tyname builtin info) + | TLUse Import deriving Show data ReplTopLevel name tyname builtin info - = RTLModule (Module name tyname builtin info) - | RTLInterface (Interface name tyname builtin info) + = RTLTopLevel (TopLevel name tyname builtin info) | RTLDefun (Defun name tyname builtin info) | RTLDefConst (DefConst name tyname builtin info) - | RTLTerm (Term name tyname builtin info) deriving Show -- | Typed pact core terms diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs new file mode 100644 index 000000000..c13fae999 --- /dev/null +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveTraversable #-} + + +module Pact.Core.Typed.Type where + +import Data.List.NonEmpty(NonEmpty) +import Data.Map.Strict(Map) + +import Pact.Core.Literal +import Pact.Core.Type(PrimType(..), BuiltinTC) +import Pact.Core.Names +import Pact.Core.Pretty + +data Type n + = TyVar n + -- ^ type variables + | TyPrim PrimType + -- ^ Built-in types + | TyFun (Type n) (Type n) + -- ^ Type n + | TyList (Type n) + -- ^ List aka [a] + | TyModRef ModuleName + -- ^ Module references + -- | TyObject Schema + -- ^ Objects + | TyForall (NonEmpty n) (Type n) + -- | TyTable Schema + -- ^ Tables + deriving (Eq, Show, Functor, Foldable, Traversable) + +pattern TyInt :: Type n +pattern TyInt = TyPrim PrimInt + +pattern TyDecimal :: Type n +pattern TyDecimal = TyPrim PrimDecimal + +-- pattern TyTime :: Type n +-- pattern TyTime = TyPrim PrimTime + +pattern TyBool :: Type n +pattern TyBool = TyPrim PrimBool + +pattern TyString :: Type n +pattern TyString = TyPrim PrimString + +pattern TyUnit :: Type n +pattern TyUnit = TyPrim PrimUnit + +pattern TyGuard :: Type n +pattern TyGuard = TyPrim PrimGuard + +pattern (:~>) :: Type n -> Type n -> Type n +pattern (:~>) l r = TyFun l r + +typeOfLit :: Literal -> Type n +typeOfLit = \case + LString{} -> TyString + LInteger{} -> TyDecimal + LUnit -> TyUnit + LDecimal{} -> TyDecimal + LBool{} -> TyBool + +instance Pretty (Type n) where + pretty _ty = error "todo" + +-- Note, no superclasses, for now +data Pred tv + = Pred BuiltinTC (Type tv) + deriving (Show, Eq, Functor, Foldable, Traversable) + +data TypeScheme tv = + TypeScheme [tv] [Pred tv] (Type tv) + deriving Show + + +newtype Schema tv + = Schema { _schema :: Map Field (Type tv) } + deriving (Eq, Show) + +tyFunToArgList :: Type n -> ([Type n], Type n) +tyFunToArgList (TyFun l r) = + unFun [l] r + where + unFun args (TyFun l' r') = unFun (l':args) r' + unFun args ret = (reverse args, ret) +tyFunToArgList r = ([], r) + +argListToTyFun :: [Type n] -> Type n -> Type n +argListToTyFun args ret = foldr TyFun ret args diff --git a/typed-core/Pact/Core/Typed/Typecheck.hs b/typed-core/Pact/Core/Typed/Typecheck.hs index 40e7379b0..9c9da5f6c 100644 --- a/typed-core/Pact/Core/Typed/Typecheck.hs +++ b/typed-core/Pact/Core/Typed/Typecheck.hs @@ -10,7 +10,7 @@ module Pact.Core.Typed.Typecheck where import Control.Monad import Control.Lens import Control.Monad.Reader -import Control.Monad.Except +import Control.Monad.Except ( MonadError(throwError) ) import Data.Foldable(foldlM) import Data.List.NonEmpty(NonEmpty(..)) import Data.Map.Strict(Map) @@ -22,7 +22,7 @@ import qualified Data.RAList as RAList import Pact.Core.Builtin import Pact.Core.Typed.Term import Pact.Core.Names -import Pact.Core.Type +import Pact.Core.Typed.Type data TCEnv tyname builtin = TCEnv diff --git a/typed-core/Pact/Core/Untyped/Eval/CEK.hs b/typed-core/Pact/Core/Untyped/Eval/CEK.hs deleted file mode 100644 index 4dd5728fb..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/CEK.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core. --- - -module Pact.Core.Untyped.Eval.CEK - ( eval - , evalCEK - , returnCEK - , returnCEKValue - , failInvariant - , throwExecutionError' - , unsafeApplyOne - , unsafeApplyTwo - ) where - -import Control.Lens -import Control.Monad.Except -import Data.Default -import Data.Text(Text) -import qualified Data.Map.Strict as M -import qualified Data.RAList as RAList -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Set as S - -import Pact.Core.Builtin -import Pact.Core.Names -import Pact.Core.Errors -import Pact.Core.Gas -import Pact.Core.Literal -import Pact.Core.PactValue -import Pact.Core.Capabilities - -import Pact.Core.Untyped.Term -import Pact.Core.Untyped.Eval.Runtime - --- chargeGas :: MonadEval b i m => Gas -> m () --- chargeGas g = do - -- ref <- view cekGas - -- gCurr <- liftIO (readIORef ref) - -- gLimit <- view (cekGasModel . geGasLimit) - -- let gUsed = g + gCurr - -- msg = "Gas Limit (" <> T.pack (show gLimit) <> ") exceeeded: " <> T.pack (show gUsed) - -- when (gUsed > gLimit) $ throwM (GasExceeded msg) - -chargeNodeGas :: MonadEval b i m => NodeType -> m () -chargeNodeGas nt = do - gm <- view (cekGasModel . geGasModel . gmNodes) <$> cekReadEnv - cekChargeGas (gm nt) - -- gm <- view (cekGasModel . geGasModel . gmNodes) - -- chargeGas (gm nt) - -chargeNative :: MonadEval b i m => b -> m () -chargeNative native = do - gm <- view (cekGasModel . geGasModel . gmNatives) <$> cekReadEnv - cekChargeGas (gm native) - -- gm <- view (cekGasModel . geGasModel . gmNatives) - -- chargeGas (gm native) - --- Todo: exception handling? do we want labels --- Todo: `traverse` usage should be perf tested. --- It might be worth making `Arg` frames incremental, as opposed to a traverse call -eval - :: forall b i m. (MonadEval b i m) - => CEKEnv b i m - -> EvalTerm b i - -> m (EvalResult b i m) -eval = evalCEK Mt CEKNoHandler - -evalCEK - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CEKEnv b i m - -> EvalTerm b i - -> m (EvalResult b i m) -evalCEK cont handler env (Var n info) = do - chargeNodeGas VarNode - case _nKind n of - NBound i -> case RAList.lookup env i of - Just v -> returnCEKValue cont handler v - Nothing -> failInvariant' ("unbound identifier" <> T.pack (show n)) info - -- Top level names are not closures, so we wipe the env - NTopLevel mname mh -> do - let fqn = FullyQualifiedName mname (_nName n) mh - cekReadEnv >>= \renv -> case M.lookup fqn (view cekLoaded renv) of - Just (Dfun d) -> evalCEK cont handler RAList.Nil (_dfunTerm d) - Just _ -> failInvariant' "invalid call" info - Nothing -> failInvariant' ("top level name " <> T.pack (show fqn) <> " not in scope") info - NModRef m ifs -> - returnCEKValue cont handler (VModRef m ifs) -evalCEK cont handler _env (Constant l _) = do - chargeNodeGas ConstantNode - returnCEKValue cont handler (VLiteral l) -evalCEK cont handler env (App fn arg _) = do - chargeNodeGas AppNode - evalCEK (Arg env arg cont) handler env fn -evalCEK cont handler env (Lam body _) = do - chargeNodeGas LamNode - returnCEKValue cont handler (VClosure body env) -evalCEK cont handler _env (Builtin b _) = do - chargeNodeGas BuiltinNode - builtins <- view cekBuiltins <$> cekReadEnv - returnCEKValue cont handler (VNative (builtins b)) -evalCEK cont handler env (Sequence e1 e2 _) = do - chargeNodeGas SeqNode - evalCEK (SeqC env e2 cont) handler env e1 -evalCEK cont handler env (Conditional c _) = case c of - CAnd te te' -> - evalCEK (CondC env (AndFrame te') cont) handler env te - COr te te' -> - evalCEK (CondC env (OrFrame te') cont) handler env te - CIf cond e1 e2 -> - evalCEK (CondC env (IfFrame e1 e2) cont) handler env cond -evalCEK cont handler env (CapabilityForm cf _) = do - fqn <- nameToFQN (view capFormName cf) - case cf of - WithCapability _ args body -> case args of - x:xs -> let - capFrame = WithCapFrame fqn body - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - [] -> evalCap cont handler env (CapToken fqn []) body - RequireCapability _ args -> case args of - [] -> requireCap cont handler (CapToken fqn []) - x:xs -> let - capFrame = RequireCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - ComposeCapability _ args -> case args of - [] -> composeCap cont handler (CapToken fqn []) - x:xs -> let - capFrame = ComposeCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - InstallCapability _ args -> case args of - [] -> installCap cont handler env (CapToken fqn []) - x : xs -> let - capFrame = InstallCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - EmitEvent _ args -> case args of - [] -> emitEvent cont handler (CapToken fqn []) - x : xs -> let - capFrame = EmitEventFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - CreateUserGuard{} -> error "implement" -evalCEK cont handler env (ListLit ts _) = do - chargeNodeGas ListNode - case ts of - [] -> returnCEKValue cont handler (VList mempty) - x:xs -> evalCEK (ListC env xs [] cont) handler env x -evalCEK cont handler env (Try e1 rest _) = do - caps <- useCekState (esCaps . csSlots) - let handler' = CEKHandler env e1 cont caps handler - evalCEK Mt handler' env rest -evalCEK cont handler env (DynInvoke n fn _) = - evalCEK (DynInvokeC env fn cont) handler env n --- Error terms ignore the current cont -evalCEK _ handler _ (Error e _) = - returnCEK Mt handler (VError e) - --- Todo: fail invariant -nameToFQN :: Applicative f => Name -> f FullyQualifiedName -nameToFQN (Name n nk) = case nk of - NTopLevel mn mh -> pure (FullyQualifiedName mn n mh) - NBound{} -> error "expected fully resolve FQ name" - NModRef{} -> error "expected non-modref" - --- Todo: fail invariants -cekToPactValue :: Applicative f => CEKValue b i m -> f PactValue -cekToPactValue = \case - VLiteral lit -> pure (PLiteral lit) - VList vec -> PList <$> traverse cekToPactValue vec - VClosure{} -> error "closure is not a pact value" - VNative{} -> error "Native is not a pact value" - VModRef mn mns -> pure (PModRef mn mns) - VGuard gu -> pure (PGuard gu) - --- Todo: managed -evalCap - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CEKEnv b i m - -> CapToken - -> EvalTerm b i - -> m (EvalResult b i m) -evalCap cont handler env ct@(CapToken fqn args) contbody = do - cekReadEnv >>= \renv -> case M.lookup fqn (view cekLoaded renv) of - Just (DCap d) -> do - modifyCEKState (esCaps . csSlots) (CapSlot ct []:) - let (env', capBody) = applyCapBody mempty args (_dcapTerm d) - cont' = CapBodyC env contbody cont - evalCEK cont' handler env' capBody - Just {} -> error "was not defcap, invariant violated" - Nothing -> error "No such def" - where - applyCapBody e (x:xs) (Lam b _) = - applyCapBody (RAList.cons (pactToCEKValue x) e) xs b - applyCapBody e _ b = (e, b) - - -requireCap - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -requireCap cont handler ct = do - caps <- useCekState (esCaps.csSlots) - let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs)) - capSet = foldMap csToSet caps - if S.member ct capSet then returnCEKValue cont handler VUnit - else throwExecutionError' (CapNotInScope "ovuvue") - -composeCap - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -composeCap cont handler ct@(CapToken fqn args) = do - cekReadEnv >>= \renv -> case M.lookup fqn (view cekLoaded renv) of - Just (DCap d) -> do - modifyCEKState (esCaps . csSlots) (CapSlot ct []:) - let (env', capBody) = applyCapBody mempty args (_dcapTerm d) - cont' = CapPopC PopCapComposed cont - evalCEK cont' handler env' capBody - Just {} -> error "was not defcap, invariant violated" - Nothing -> error "No such def" - where - applyCapBody e (x:xs) (Lam b _) = - applyCapBody (RAList.cons (pactToCEKValue x) e) xs b - applyCapBody e _ b = (e, b) - -installCap :: a -installCap = undefined - -emitEvent - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -emitEvent cont handler ct@(CapToken fqn _) = do - let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) - modifyCEKState esEvents (pactEvent:) - returnCEKValue cont handler VUnit - - -returnCEK :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> EvalResult b i m - -> m (EvalResult b i m) -returnCEK Mt handler v = - case handler of - CEKNoHandler -> return v - CEKHandler env term cont' caps handler' -> case v of - VError{} -> do - setCekState (esCaps . csSlots) caps - evalCEK cont' handler' env term - EvalValue v' -> - returnCEKValue cont' handler' v' -returnCEK cont handler v = case v of - VError{} -> returnCEK Mt handler v - EvalValue v' -> returnCEKValue cont handler v' - -returnCEKValue - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CEKValue b i m - -> m (EvalResult b i m) -returnCEKValue Mt handler v = - case handler of - CEKNoHandler -> return (EvalValue v) - -- Assuming no error, the caps will have been popped naturally - CEKHandler _env _term cont' _ handler' -> returnCEKValue cont' handler' v --- Error terms that don't simply returnt the empty continuation --- "Zero out" the continuation up to the latest handler --- returnCEKValue _cont handler v@VError{} = --- returnCEK Mt handler v -returnCEKValue (Arg env arg cont) handler fn = - evalCEK (Fn fn cont) handler env arg -returnCEKValue (Fn fn cont) handler arg = - applyLam fn arg cont handler -returnCEKValue (SeqC env e cont) handler _ = - evalCEK cont handler env e -returnCEKValue (CondC env frame cont) handler v = case v of - (VLiteral (LBool b)) -> case frame of - AndFrame te -> - if b then evalCEK cont handler env te - else returnCEKValue cont handler v - OrFrame te -> - if b then returnCEKValue cont handler v - else evalCEK cont handler env te - IfFrame ifExpr elseExpr -> - if b then evalCEK cont handler env ifExpr - else evalCEK cont handler env elseExpr - _ -> failInvariant "Evaluation of conditional expression yielded non-boolean value" -returnCEKValue (CapInvokeC env terms pvs cf cont) handler v = case terms of - x:xs -> do - pv <- cekToPactValue v - let cont' = CapInvokeC env xs (pv:pvs) cf cont - evalCEK cont' handler env x - [] -> case cf of - WithCapFrame fqn wcbody -> - evalCap cont handler env (CapToken fqn (reverse pvs)) wcbody - RequireCapFrame fqn -> - requireCap cont handler (CapToken fqn (reverse pvs)) - ComposeCapFrame fqn -> - composeCap cont handler (CapToken fqn (reverse pvs)) - InstallCapFrame{} -> error "todo" - EmitEventFrame fqn -> - emitEvent cont handler (CapToken fqn (reverse pvs)) -returnCEKValue (CapBodyC env term cont) handler _ = do - let cont' = CapPopC PopCapInvoke cont - evalCEK cont' handler env term -returnCEKValue (CapPopC st cont) handler v = case st of - PopCapInvoke -> do - -- todo: need safe tail here, but this should be fine given the invariant that `CapPopC` - -- will never show up otherwise - modifyCEKState (esCaps . csSlots) tail - returnCEKValue cont handler v - PopCapComposed -> do - caps <- useCekState (esCaps . csSlots) - let cs = head caps - csList = _csCap cs : _csComposed cs - caps' = over (_head . csComposed) (++ csList) (tail caps) - setCekState (esCaps . csSlots) caps' - returnCEKValue cont handler VUnit -returnCEKValue (ListC env args vals cont) handler v = do - case args of - [] -> - returnCEKValue cont handler (VList (V.fromList (reverse (v:vals)))) - e:es -> - evalCEK (ListC env es (v:vals) cont) handler env e --- Todo: note over here we might want to typecheck --- Todo: inline the variable lookup instead of calling EvalCEK directly, --- as we can provide a better error message this way. -returnCEKValue (DynInvokeC env fn cont) handler v = case v of - VModRef mn _ -> do - -- Todo: for when persistence is implemented - -- here is where we would incur module loading - cekReadEnv >>= \e -> case view (cekMHashes . at mn) e of - Just mh -> - evalCEK cont handler env (Var (Name fn (NTopLevel mn mh)) def) - Nothing -> failInvariant "No such module" - _ -> failInvariant "Not a modref" - -applyLam - :: (MonadEval b i m) - => CEKValue b i m - -> CEKValue b i m - -> Cont b i m - -> CEKErrorHandler b i m - -> m (EvalResult b i m) -applyLam (VClosure body env) arg cont handler = - evalCEK cont handler (RAList.cons arg env) body -applyLam (VNative (NativeFn b fn arity args)) arg cont handler - | arity - 1 == 0 = do - chargeNative b - fn cont handler (reverse (arg:args)) - | otherwise = returnCEKValue cont handler (VNative (NativeFn b fn (arity - 1) (arg:args))) -applyLam _ _ _ _ = failInvariant' "Applying value to non-function" def - -failInvariant :: MonadEval b i m => Text -> m a -failInvariant b = - let e = PEExecutionError (InvariantFailure b) def - in throwError e - -failInvariant' :: MonadEval b i m => Text -> i -> m a -failInvariant' b i = - let e = PEExecutionError (InvariantFailure b) i - in throwError e - -throwExecutionError' :: (MonadEval b i m) => EvalError -> m a -throwExecutionError' e = throwError (PEExecutionError e def) - -unsafeApplyOne - :: MonadEval b i m - => CEKValue b i m - -> CEKValue b i m - -> m (EvalResult b i m) -unsafeApplyOne (VClosure body env) arg = eval (RAList.cons arg env) body -unsafeApplyOne (VNative (NativeFn b fn arity args)) arg = - if arity - 1 <= 0 then fn Mt CEKNoHandler (reverse (arg:args)) - else pure (EvalValue (VNative (NativeFn b fn (arity - 1) (arg:args)))) -unsafeApplyOne _ _ = failInvariant "Applied argument to non-closure in native" - -unsafeApplyTwo - :: MonadEval b i m - => CEKValue b i m - -> CEKValue b i m - -> CEKValue b i m - -> m (EvalResult b i m) -unsafeApplyTwo (VClosure (Lam body _) env) arg1 arg2 = - eval (RAList.cons arg2 (RAList.cons arg1 env)) body -unsafeApplyTwo (VNative (NativeFn b fn arity args)) arg1 arg2 = - if arity - 2 <= 0 then fn Mt CEKNoHandler (reverse (arg1:arg2:args)) - else pure $ EvalValue $ VNative $ NativeFn b fn (arity - 2) (arg1:arg2:args) -unsafeApplyTwo _ _ _ = failInvariant "Applied argument to non-closure in native" diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime.hs deleted file mode 100644 index 6af7ab0e6..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE InstanceSigs #-} - - -module Pact.Core.Untyped.Eval.Runtime - ( CEKTLEnv - , CEKEnv - , EvalEnv(..) - , NativeFn(..) - , EvalT(..) - , runEvalT - , CEKValue(..) - , Cont(..) - , mkBuiltinFn - , cekBuiltins - , cekLoaded - , cekGasModel - , cekMHashes, cekMsgSigs - , fromPactValue - , checkPactValueType - , pactToCEKValue - , cfFQN - , CEKErrorHandler(..) - , MonadEvalEnv(..) - , MonadEvalState(..) - , CondFrame(..) - , MonadEval - , Closure(..) - , EvalResult(..) - , EvalEnv(..) - , EvalState(..) - , esCaps, esEvents, esInCap - , pattern VString - , pattern VInteger - , pattern VDecimal - , pattern VUnit - , pattern VBool - -- Capabilities - , CapToken(..) - , ctName, ctArgs - , CapSlot(..) - , csCap, csComposed - , CapFrame(..) - , CapState(..) - , csSlots, csManaged - , ManagedCap(..) - , mcCap, mcManaged - , ManagedCapType(..) - , PactEvent(..) - , CapPopState(..) - ) where - - -import Control.Lens -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.Except -import Control.Monad.State.Strict -import Data.Void -import Data.Text(Text) -import Data.Map.Strict(Map) -import Data.Default -import Data.Decimal(Decimal) --- import Data.Set(Set) -import Data.Vector(Vector) -import Data.RAList(RAList) -import Data.Set(Set) -import Data.IORef -import qualified Data.Vector as V - -import Pact.Core.Names -import Pact.Core.Guards -import Pact.Core.Pretty(Pretty(..), (<+>)) -import Pact.Core.Gas -import Pact.Core.PactValue -import Pact.Core.Errors -import Pact.Core.Builtin -import Pact.Core.Hash -import Pact.Core.Untyped.Term -import Pact.Core.Literal --- import Pact.Core.Persistence -import Pact.Core.Type -import qualified Pact.Core.Pretty as P - --- | The top level env map -type CEKTLEnv b i = Map FullyQualifiedName (EvalDef b i) - --- | Locally bound variables -type CEKEnv b i m = RAList (CEKValue b i m) - --- | List of builtins -type BuiltinEnv b i m = b -> NativeFn b i m - -data Closure b i m = - Closure !(EvalTerm b i) !(CEKEnv b i m) - deriving Show - --- | The type of our semantic runtime values -data CEKValue b i m - = VLiteral !Literal - | VList !(Vector (CEKValue b i m)) - | VClosure !(EvalTerm b i) !(CEKEnv b i m) - | VNative !(NativeFn b i m) - | VModRef ModuleName [ModuleName] - | VGuard !(Guard FullyQualifiedName PactValue) - -- deriving Show - -instance Show (CEKValue b i m) where - show = \case - VLiteral lit -> show lit - VList vec -> show vec - VClosure _ _ -> "closure<>" - VNative _ -> "native<>" - VModRef mn mns -> "modRef" <> show mn <> show mns - VGuard _ -> "guard<>" - -pactToCEKValue :: PactValue -> CEKValue b i m -pactToCEKValue = \case - PLiteral lit -> VLiteral lit - PList vec -> VList (pactToCEKValue <$> vec) - PGuard gu -> VGuard gu - PModRef mn ifs -> VModRef mn ifs - -pattern VString :: Text -> CEKValue b i m -pattern VString txt = VLiteral (LString txt) - -pattern VInteger :: Integer -> CEKValue b i m -pattern VInteger txt = VLiteral (LInteger txt) - -pattern VUnit :: CEKValue b i m -pattern VUnit = VLiteral LUnit - -pattern VBool :: Bool -> CEKValue b i m -pattern VBool b = VLiteral (LBool b) - -pattern VDecimal :: Decimal -> CEKValue b i m -pattern VDecimal d = VLiteral (LDecimal d) - --- | Result of an evaluation step, either a CEK value or an error. -data EvalResult b i m - = EvalValue (CEKValue b i m) - | VError Text - deriving Show - -data EvalState b i - = EvalState - { _esCaps :: CapState - , _esEvents :: [PactEvent b i] - , _esInCap :: Bool - } deriving Show - -type MonadEval b i m = (MonadEvalEnv b i m, MonadEvalState b i m, MonadError (PactError i) m, Default i) - -class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where - cekReadEnv :: m (EvalEnv b i m) - cekLogGas :: Text -> Gas -> m () - cekChargeGas :: Gas -> m () - -class Monad m => (MonadEvalState b i m) | m -> b, m -> i where - setCekState :: Lens' (EvalState b i) s -> s -> m () - modifyCEKState :: Lens' (EvalState b i) s -> (s -> s) -> m () - useCekState :: Lens' (EvalState b i) s -> m s - usesCekState :: Lens' (EvalState b i) s -> (s -> s') -> m s' - -data EvalEnv b i m - = EvalEnv - { _emRuntimeEnv :: EvalEnv b i (EvalT b i m) - , _emGas :: IORef Gas - , _emGasLog :: IORef (Maybe [(Text, Gas)]) - } - --- Todo: are we going to inject state as the reader monad here? -newtype EvalT b i m a = - EvalT (ReaderT (EvalEnv b i m) (StateT (EvalState b i) m) a) - deriving - ( Functor, Applicative, Monad - , MonadIO - , MonadThrow - , MonadCatch) - via (ReaderT (EvalEnv b i m) (StateT (EvalState b i) m)) - -runEvalT - :: EvalEnv b i m - -> EvalState b i - -> EvalT b i m a - -> m (a, EvalState b i) -runEvalT env st (EvalT action) = runStateT (runReaderT action env) st - -data NativeFn b i m - = NativeFn - { _native :: b - , _nativeFn :: Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m) - , _nativeArity :: {-# UNPACK #-} !Int - , _nativeAppliedArgs :: [CEKValue b i m] - } - -mkBuiltinFn - :: (BuiltinArity b) - => (Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m)) - -> b - -> NativeFn b i m -mkBuiltinFn fn b = - NativeFn b fn (builtinArity b) [] -{-# INLINE mkBuiltinFn #-} - -data ExecutionMode - = Transactional - | Local - deriving (Eq, Show, Bounded, Enum) - -data CondFrame b i - = AndFrame (EvalTerm b i) - | OrFrame (EvalTerm b i) - | IfFrame (EvalTerm b i) (EvalTerm b i) - deriving Show - -data CapToken - = CapToken - { _ctName :: FullyQualifiedName - , _ctArgs :: [PactValue] - } deriving (Show, Eq, Ord) - -data CapSlot - = CapSlot - { _csCap :: CapToken - , _csComposed :: [CapToken] - } deriving (Show, Eq) - -data PactEvent b i - = PactEvent - { _peToken :: CapToken - , _peModule :: ModuleName - , _peModuleHash :: ModuleHash - } deriving (Show, Eq) - -data ManagedCapType - = AutoManaged Bool - | ManagedParam FullyQualifiedName PactValue Int - -- ^ managed cap, with manager function, managed value - deriving Show - -data ManagedCap - = ManagedCap - { _mcCap :: CapToken - , _mcManaged :: ManagedCapType - } deriving (Show) - -instance Eq ManagedCap where - l == r = _mcCap l == _mcCap r - -instance Ord ManagedCap where - l `compare` r = _mcCap l `compare` _mcCap r - --- | The overall capability state -data CapState - = CapState - { _csSlots :: [CapSlot] - , _csManaged :: Set ManagedCap - } - deriving Show - -data CapFrame b i - = WithCapFrame FullyQualifiedName (EvalTerm b i) - | RequireCapFrame FullyQualifiedName - | ComposeCapFrame FullyQualifiedName - | InstallCapFrame FullyQualifiedName - | EmitEventFrame FullyQualifiedName - deriving Show - -cfFQN :: Lens' (CapFrame b i) FullyQualifiedName -cfFQN f = \case - WithCapFrame fqn b -> (`WithCapFrame` b) <$> f fqn - RequireCapFrame fqn -> RequireCapFrame <$> f fqn - ComposeCapFrame fqn -> ComposeCapFrame <$> f fqn - InstallCapFrame fqn -> InstallCapFrame <$> f fqn - EmitEventFrame fqn -> EmitEventFrame <$> f fqn - -data CapPopState - = PopCapComposed - | PopCapInvoke - deriving (Eq, Show) - -data Cont b i m - = Fn (CEKValue b i m) (Cont b i m) - | Arg (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | SeqC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | ListC (CEKEnv b i m) [EvalTerm b i] [CEKValue b i m] (Cont b i m) - | CondC (CEKEnv b i m) (CondFrame b i) (Cont b i m) - | DynInvokeC (CEKEnv b i m) Text (Cont b i m) - | CapInvokeC (CEKEnv b i m) [EvalTerm b i] [PactValue] (CapFrame b i) (Cont b i m) - | CapBodyC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | CapPopC CapPopState (Cont b i m) - | Mt - deriving Show - - -data CEKErrorHandler b i m - = CEKNoHandler - | CEKHandler (CEKEnv b i m) (EvalTerm b i) (Cont b i m) [CapSlot] (CEKErrorHandler b i m) - deriving Show - -data EvalEnv b i m - = EvalEnv - { _cekBuiltins :: BuiltinEnv b i m - , _cekGasModel :: GasEnv b - , _cekLoaded :: CEKTLEnv b i - , _cekMHashes :: Map ModuleName ModuleHash - , _cekMsgSigs :: Map PublicKeyText (Set CapToken) - -- _cekGas :: IORef Gas - -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)]) - -- , _ckeData :: EnvData PactValue - -- , _ckeTxHash :: Hash - -- , _ckeResolveName :: QualifiedName -> Maybe FullyQualifiedName - -- , _ckeSigs :: Set PublicKey - -- , _ckePactDb :: PactDb b i - } - -instance (Show i, Show b) => Show (NativeFn b i m) where - show (NativeFn b _ arity args) = unwords - ["(NativeFn" - , show b - , "#fn" - , show arity - , show args - , ")" - ] - -instance (Pretty b, Show i, Show b) => Pretty (NativeFn b i m) where - pretty = pretty . show - -instance (Show i, Show b, Pretty b) => Pretty (CEKValue b i m) where - pretty = \case - VLiteral i -> - pretty i - VList v -> - P.brackets $ P.hsep (P.punctuate P.comma (V.toList (pretty <$> v))) - VClosure{} -> - P.angles "closure#" - VNative b -> - P.angles $ "native" <+> pretty b - VGuard _ -> P.angles "guard#" - VModRef mn _ -> - "modref" <> P.braces (pretty mn) - -- VError e -> - -- ("error " <> pretty e) - -makeLenses ''EvalEnv - -fromPactValue :: PactValue -> CEKValue b i m -fromPactValue = \case - PLiteral lit -> VLiteral lit - PList vec -> VList (fromPactValue <$> vec) - PGuard gu -> - VGuard gu - PModRef mn ifs -> VModRef mn ifs - -checkPactValueType :: Type Void -> PactValue -> Bool -checkPactValueType ty = \case - PLiteral lit -> typeOfLit lit == ty - PList vec -> case ty of - TyList t -> V.null vec || all (checkPactValueType t) vec - _ -> False - PGuard _ -> ty == TyGuard - PModRef _ ifs -> case ty of - TyModRef m -> m `elem` ifs - _ -> False - -makeLenses ''EvalEnv -makeLenses ''EvalState -makeLenses ''CapState -makeLenses ''CapToken -makeLenses ''CapSlot -makeLenses ''ManagedCap - -instance (MonadIO m) => MonadEvalEnv b i (EvalT b i m) where - cekReadEnv = EvalT $ view emRuntimeEnv - cekLogGas msg g = do - r <- EvalT $ view emGasLog - liftIO $ modifyIORef' r (fmap ((msg, g):)) - cekChargeGas g = do - r <- EvalT $ view emGas - liftIO (modifyIORef' r (<> g)) - -instance Monad m => MonadEvalState b i (EvalT b i m) where - setCekState l s = EvalT $ l .= s - modifyCEKState l f = EvalT (l %= f) - useCekState l = EvalT (use l) - usesCekState l f = EvalT (uses l f) diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs deleted file mode 100644 index c7d839cfb..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs +++ /dev/null @@ -1,1180 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core using our RawBuiltins (aka untyped, no typechecking) --- - -module Pact.Core.Untyped.Eval.Runtime.CoreBuiltin - ( coreBuiltinRuntime - , coreBuiltinLiftedRuntime ) where - -import Control.Monad(when) - -import Data.Bits -import Data.Decimal(roundTo', Decimal) -import Data.Text(Text) -import Data.Vector(Vector) -import qualified Data.Vector as V --- import qualified Data.Primitive.Array as Array -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Errors -import Pact.Core.Hash - -import Pact.Core.Untyped.Eval.Runtime -import Pact.Core.Untyped.Eval.CEK - --- | Run our CEK interpreter --- for only our core builtins --- monomorphized version --- runCoreCEK - -- :: EvalEnv CoreBuiltin i - -- ^ Runtime environment - -- -> EvalTerm CoreBuiltin i - -- ^ Term to evaluate --- -> IO (CEKValue CoreBuiltin i) --- runCoreCEK = runCEK ----------------------------------------------------------------------- --- Our builtin definitions start here ----------------------------------------------------------------------- - --- -- Todo: runtime error -unaryIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer) -> b -> NativeFn b i m -unaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) - _ -> failInvariant "unary int function" -{-# INLINE unaryIntFn #-} - -unaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal) -> b -> NativeFn b i m -unaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LDecimal (op i))) - _ -> failInvariant "unary decimal function" -{-# INLINE unaryDecFn #-} - -binaryIntFn - :: (BuiltinArity b, MonadEval b i m) - => (Integer -> Integer -> Integer) - -> b - -> NativeFn b i m -binaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) - _ -> failInvariant "binary int function" -{-# INLINE binaryIntFn #-} - -binaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Decimal) -> b -> NativeFn b i m -binaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (op i i'))) - _ -> failInvariant "binary decimal function" -{-# INLINE binaryDecFn #-} - -binaryBoolFn :: (BuiltinArity b, MonadEval b i m) => (Bool -> Bool -> Bool) -> b -> NativeFn b i m -binaryBoolFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool l), VLiteral (LBool r)] -> returnCEKValue cont handler (VLiteral (LBool (op l r))) - _ -> failInvariant "binary bool function" -{-# INLINE binaryBoolFn #-} - -compareIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer -> Bool) -> b -> NativeFn b i m -compareIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "int cmp function" -{-# INLINE compareIntFn #-} - -compareDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Bool) -> b -> NativeFn b i m -compareDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "dec cmp function" -{-# INLINE compareDecFn #-} - -compareStrFn :: (BuiltinArity b, MonadEval b i m) => (Text -> Text -> Bool) -> b -> NativeFn b i m -compareStrFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "str cmp function" -{-# INLINE compareStrFn #-} - -roundingFn :: (BuiltinArity b, MonadEval b i m) => (Rational -> Integer) -> b -> NativeFn b i m -roundingFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 i)))) - _ -> failInvariant "rounding function" -{-# INLINE roundingFn #-} - ---------------------------------- --- integer ops ------------------------------- -addInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addInt = binaryIntFn (+) - -subInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -subInt = binaryIntFn (-) - -mulInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -mulInt = binaryIntFn (*) - -powInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -powInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> do - when (i' < 0) $ throwExecutionError' (ArithmeticException "negative exponent in integer power") - returnCEKValue cont handler (VLiteral (LInteger (i ^ i'))) - _ -> failInvariant "binary int function" - -logBaseInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -logBaseInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger base), VLiteral (LInteger n)] -> do - when (base < 0 || n <= 0) $ throwExecutionError' (ArithmeticException "Illegal log base") - let base' = fromIntegral base :: Double - n' = fromIntegral n - out = round (logBase base' n') - returnCEKValue cont handler (VLiteral (LInteger out)) - -- if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - -- else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - _ -> failInvariant "binary int function" - -divInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -divInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - _ -> failInvariant "binary int function" - -negateInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -negateInt = unaryIntFn negate - -modInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -modInt = binaryIntFn mod - -eqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqInt = compareIntFn (==) - -neqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqInt = compareIntFn (/=) - -gtInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtInt = compareIntFn (>) - -ltInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltInt = compareIntFn (<) - -geqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqInt = compareIntFn (>=) - -leqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqInt = compareIntFn (<=) - -bitAndInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitAndInt = binaryIntFn (.&.) - -bitOrInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitOrInt = binaryIntFn (.|.) - -bitComplementInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitComplementInt = unaryIntFn complement - -bitXorInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitXorInt = binaryIntFn xor - -bitShiftInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitShiftInt = binaryIntFn (\i s -> shift i (fromIntegral s)) - -absInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -absInt = unaryIntFn abs - -expInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -expInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = exp (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "expInt" - -lnInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lnInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = log (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "lnInt" - -sqrtInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -sqrtInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - when (i < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "sqrtInt" - -showInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - _ -> failInvariant "showInt" - --- ------------------------- --- double ops --- ------------------------- - -addDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addDec = binaryDecFn (+) - -subDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -subDec = binaryDecFn (-) - -mulDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -mulDec = binaryDecFn (*) - -guardNanOrInf :: MonadEval b i m => Double -> m () -guardNanOrInf a = - when (isNaN a || isInfinite a) $ throwExecutionError' (FloatingPointError "Floating operation resulted in Infinity or NaN") - -powDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -powDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal a), VLiteral (LDecimal b)] -> do - let result = dec2F a ** dec2F b - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -divDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -divDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero, decimal") - else returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) - _ -> failInvariant "binary decimal function" - -negateDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -negateDec = unaryDecFn negate - -absDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -absDec = unaryDecFn abs - -eqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqDec = compareDecFn (==) - -neqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqDec = compareDecFn (/=) - -gtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtDec = compareDecFn (>) - -geqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqDec = compareDecFn (>=) - -ltDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltDec = compareDecFn (<) - -leqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqDec = compareDecFn (<=) - -showDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - _ -> failInvariant "showDec" - -dec2F :: Decimal -> Double -dec2F = fromRational . toRational - -f2Dec :: Double -> Decimal -f2Dec = fromRational . toRational - -roundDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -roundDec = roundingFn round -floorDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -floorDec = roundingFn floor -ceilingDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ceilingDec = roundingFn ceiling - --- Todo: exp and ln, sqrt have similar failure conditions -expDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -expDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - let result = exp (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -- unaryDecFn (f2Dec . exp . dec2F) - -lnDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lnDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - let result = log (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -logBaseDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -logBaseDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do - when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") - let result = logBase (dec2F base) (dec2F arg) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - - -sqrtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -sqrtDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - - ---------------------------- --- bool ops ---------------------------- --- andBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- andBool = binaryBoolFn (&&) - --- orBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- orBool = binaryBoolFn (||) - -notBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -notBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) - _ -> failInvariant "notBool" - -eqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqBool = binaryBoolFn (==) - -neqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqBool = binaryBoolFn (/=) - -showBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> do - let out = if i then "true" else "false" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showBool" - ---------------------------- --- string ops ---------------------------- -eqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqStr = compareStrFn (==) - -neqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqStr = compareStrFn (/=) - -gtStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtStr = compareStrFn (>) - -geqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqStr = compareStrFn (>=) - -ltStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltStr = compareStrFn (<) - -leqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqStr = compareStrFn (<=) - -addStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> - returnCEKValue cont handler (VLiteral (LString (i <> i'))) - _ -> failInvariant "addStr" - -takeStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -takeStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - _ -> failInvariant "takeStr" - -dropStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -dropStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - _ -> failInvariant "dropStr" - -lengthStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (T.length t)))) - _ -> failInvariant "lengthStr" - -reverseStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -reverseStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LString (T.reverse t))) - _ -> failInvariant "reverseStr" - -showStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - let out = "\"" <> t <> "\"" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showStr" - -concatStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatStr = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asString li - returnCEKValue cont handler (VLiteral (LString (T.concat (V.toList li')))) - _ -> failInvariant "concatStr" - -strToList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -strToList = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> do - let v = (VList (V.fromList ((VLiteral . LString . T.singleton <$> T.unpack s)))) - returnCEKValue cont handler v - _ -> failInvariant "concatStr" - ---------------------------- --- Unit ops ---------------------------- - -eqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) - _ -> failInvariant "eqUnit" - -neqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) - _ -> failInvariant "neqUnit" - -showUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LString "()")) - _ -> failInvariant "showUnit" - ---------------------------- --- Object ops ---------------------------- - --- eqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeEqCEKValue l r))) --- _ -> failInvariant "eqObj" - --- neqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeNeqCEKValue l r))) --- _ -> failInvariant "neqObj" - - ------------------------------- ---- conversions + unsafe ops ------------------------------- --- asBool :: MonadEval b i m => CEKValue b i m -> m Bool --- asBool (VLiteral (LBool b)) = pure b --- asBool _ = failInvariant "asBool" - -asString :: MonadEval b i m => CEKValue b i m -> m Text -asString (VLiteral (LString b)) = pure b -asString _ = failInvariant "asString" - -asList :: MonadEval b i m => CEKValue b i m -> m (Vector (CEKValue b i m)) -asList (VList l) = pure l -asList _ = failInvariant "asList" - --- unsafeEqLiteral :: Literal -> Literal -> Bool --- unsafeEqLiteral (LString i) (LString i') = i == i' --- unsafeEqLiteral (LInteger i) (LInteger i') = i == i' --- unsafeEqLiteral (LDecimal i) (LDecimal i') = i == i' --- unsafeEqLiteral LUnit LUnit = True --- unsafeEqLiteral (LBool i) (LBool i') = i == i' --- unsafeEqLiteral (LTime i) (LTime i') = i == i' --- unsafeEqLiteral _ _ = --- throw (InvariantFailure "invariant failed in literal EQ") - --- unsafeNeqLiteral :: Literal -> Literal -> Bool --- unsafeNeqLiteral a b = not (unsafeEqLiteral a b) - --- unsafeEqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeEqCEKValue (VLiteral l) (VLiteral l') = unsafeEqLiteral l l' --- unsafeEqCEKValue (VObject o) (VObject o') = and (M.intersectionWith unsafeEqCEKValue o o') --- unsafeEqCEKValue (VList l) (VList l') = V.length l == V.length l' && and (V.zipWith unsafeEqCEKValue l l') --- unsafeEqCEKValue _ _ = throw (InvariantFailure "invariant failed in value Eq") - --- unsafeNeqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeNeqCEKValue a b = not (unsafeEqCEKValue a b) - ---------------------------- --- list ops ---------------------------- -eqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqList = mkBuiltinFn \cont handler -> \case - [eqClo, VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool False)) - else zip' (V.toList l) (V.toList r) [] - where - zip' [] _ acc = returnCEKValue cont handler (VLiteral (LBool (and acc))) - zip' _ [] acc = returnCEKValue cont handler (VLiteral (LBool (and acc))) - zip' (x:xs) (y:ys) acc = unsafeApplyTwo eqClo x y >>= \case - EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - _ -> failInvariant "eqList" - -neqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqList = mkBuiltinFn \cont handler -> \case - [neqClo, VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool True)) - else zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo neqClo x y >>= \case - EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - zip' _ _ acc = returnCEKValue cont handler (VLiteral (LBool (or acc))) - _ -> failInvariant "neqList" - -zipList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -zipList = mkBuiltinFn \cont handler -> \case - [clo, VList l, VList r] -> zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo clo x y >>= \case - EvalValue v -> zip' xs ys (v:acc) - v@VError{} -> returnCEK cont handler v - zip' _ _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "zipList" - -addList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addList = mkBuiltinFn \cont handler -> \case - [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) - _ -> failInvariant "addList" - -pcShowList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -pcShowList = mkBuiltinFn \cont handler -> \case - [showFn, VList l1] -> show' (V.toList l1) [] - where - show' (x:xs) acc = unsafeApplyOne showFn x >>= \case - EvalValue (VLiteral (LString b)) -> show' xs (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - show' _ acc = do - let out = "[" <> T.intercalate ", " (reverse acc) <> "]" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showList" - -coreMap :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreMap = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> map' (V.toList li) [] - where - map' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue cv -> map' xs (cv:acc) - v -> returnCEK cont handler v - map' _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "map" - -coreFilter :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFilter = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> filter' (V.toList li) [] - where - filter' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue (VLiteral (LBool b)) -> - if b then filter' xs (x:acc) else filter' xs acc - v@VError{} -> - returnCEK cont handler v - _ -> failInvariant "filter" - filter' [] acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "filter" - -coreFold :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFold = mkBuiltinFn \cont handler -> \case - [fn, initElem, VList li] -> - fold' initElem (V.toList li) - where - fold' e (x:xs) = unsafeApplyTwo fn e x >>= \case - EvalValue v -> fold' v xs - v -> returnCEK cont handler v - fold' e [] = returnCEKValue cont handler e - _ -> failInvariant "fold" - -lengthList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthList = mkBuiltinFn \cont handler -> \case - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthList" - -takeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -takeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.take clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.drop clamp li)) - _ -> failInvariant "takeList" - -dropList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -dropList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.drop clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.take clamp li)) - _ -> failInvariant "dropList" - -reverseList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -reverseList = mkBuiltinFn \cont handler -> \case - [VList li] -> - returnCEKValue cont handler (VList (V.reverse li)) - _ -> failInvariant "takeList" - -coreEnumerate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to)] -> do - v <- createEnumerateList from to (if from > to then -1 else 1) - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate" - -createEnumerateList - :: (MonadEval b i m) - => Integer - -- ^ from - -> Integer - -- ^ to - -> Integer - -- ^ Step - -> m (Vector Integer) -createEnumerateList from to inc - | from == to = pure (V.singleton from) - | inc == 0 = pure mempty - | from < to, from + inc < from = - throwExecutionError' (EnumerationError "enumerate: increment diverges below from interval bounds.") - | from > to, from + inc > from = - throwExecutionError' (EnumerationError "enumerate: increment diverges above from interval bounds.") - | otherwise = let - step = succ (abs (from - to) `div` abs inc) - in pure $ V.enumFromStepN from inc (fromIntegral step) - -coreEnumerateStepN :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerateStepN = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do - v <- createEnumerateList from to inc - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate-step" - -concatList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatList = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asList li - returnCEKValue cont handler (VList (V.concat (V.toList li'))) - _ -> failInvariant "takeList" - -makeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -makeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), v] -> do - returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) - _ -> failInvariant "makeList" - -listAccess :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -listAccess = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList vec] -> - case vec V.!? fromIntegral i of - Just v -> returnCEKValue cont handler v - _ -> throwExecutionError' (ArrayOutOfBoundsException (V.length vec) (fromIntegral i)) - _ -> failInvariant "list-access" - ------------------------------------ --- try-related ops ------------------------------------ - -coreEnforce :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnforce = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool b), VLiteral (LString s)] -> - if b then returnCEKValue cont handler (VLiteral LUnit) - else returnCEK cont handler (VError s) - _ -> failInvariant "enforce" - --- coreEnforceOne :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceOne = mkBuiltinFn \case --- [VList v, VLiteral (LString msg)] -> --- enforceFail msg (V.toList v) --- _ -> failInvariant "coreEnforceOne" --- where --- handler msg rest = \case --- EnforceException _ -> enforceFail msg rest --- e -> throwM e --- enforceClo _ [] = pure (VLiteral LUnit) --- enforceClo msg (x:xs) = catch (unsafeApplyOne x (VLiteral LUnit)) (handler msg xs) --- enforceFail msg [] = throwM (EnforceException msg) --- enforceFail msg as = enforceClo msg as ------------------------------------ --- Guards and reads ------------------------------------ - --- readError :: Text -> Text -> Text --- readError field expected = --- "invalid value at field " <> field <> " expected: " <> expected - --- coreReadInteger :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadInteger = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LInteger{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "integer")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-integer" - --- coreReadString :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadString = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv-> case pv of --- PLiteral l@LString{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "string")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-string" - --- coreReadDecimal :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadDecimal = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LDecimal{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-decimal" - --- coreReadObject :: CEKRuntime b i => Row Void -> CEKValue b i m -> EvalT b i (CEKValue b i m) --- coreReadObject ty = \case --- VLiteral (LString s) -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- t@PObject{} | checkPactValueType (TyRow ty) t -> pure (fromPactValue t) --- _ -> throwM (ReadException (readError s "object")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "readObject" - --- coreReadKeyset :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadKeyset = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PObject m -> case lookupKs m of --- Just ks -> pure (VGuard (GKeyset ks)) --- _ -> throwM (ReadException "Invalid keyset format") --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-keyset" --- where --- -- Todo: public key parsing. --- -- This is most certainly wrong, it needs more checks. --- lookupKs m = do --- ks <- M.lookup (Field "keys") m >>= \case --- PList v -> do --- o <- traverse (preview (_PLiteral . _LString)) v --- guard (all (T.all isHexDigit) o) --- pure $ Set.fromList $ V.toList (PublicKey . T.encodeUtf8 <$> o) --- _ -> Nothing --- kspred <- case M.lookup (Field "pred") m of --- (Just (PLiteral LString{})) -> pure KeysAll --- Just _ -> Nothing --- Nothing -> pure KeysAll --- pure (KeySet ks kspred) - - --- coreKeysetRefGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreKeysetRefGuard = mkBuiltinFn \case --- [VLiteral (LString s)] -> pure (VGuard (GKeySetRef (KeySetName s))) --- _ -> failInvariant "keyset-ref-guard" - --- coreEnforceGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceGuard = mkBuiltinFn \case --- [VGuard v] -> case v of --- GKeyset ks -> enforceKeySet ks --- GKeySetRef ksr -> enforceKeySetRef ksr --- GUserGuard ug -> enforceUserGuard ug --- _ -> failInvariant "enforceGuard" - --- enforceKeySet :: CEKRuntime b i => KeySet name -> EvalT b i (CEKValue b i m) --- enforceKeySet (KeySet keys p) = do --- let sigs = _ckeSigs ?cekRuntimeEnv --- matched = Set.size $ Set.filter (`Set.member` keys) sigs --- count = Set.size keys --- case p of --- KeysAll | matched == count -> pure (VLiteral LUnit) --- Keys2 | matched >= 2 -> pure (VLiteral LUnit) --- KeysAny | matched > 0 -> pure (VLiteral LUnit) --- _ -> throwM (EnforceException "cannot match keyset predicate") - --- enforceKeySetRef :: CEKRuntime b i => KeySetName -> EvalT b i (CEKValue b i m) --- enforceKeySetRef ksr = do --- let pactDb = _ckePactDb ?cekRuntimeEnv --- liftIO (_readKeyset pactDb ksr) >>= \case --- Just ks -> enforceKeySet ks --- Nothing -> throwM (EnforceException "no such keyset") - --- enforceUserGuard :: CEKRuntime b i => CEKValue b i m -> EvalT b i (CEKValue b i m) --- enforceUserGuard = \case --- v@VClosure{} -> unsafeApplyOne v (VLiteral LUnit) >>= \case --- VLiteral LUnit -> pure (VLiteral LUnit) --- _ -> failInvariant "expected a function returning unit" --- _ -> failInvariant "invalid type for user closure" - --- createUserGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- createUserGuard = mkBuiltinFn \case --- [v@VClosure{}] -> pure (VGuard (GUserGuard v)) --- _ -> failInvariant "create-user-guard" - ------------------------------------ --- Module references ------------------------------------ -eqModRef :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqModRef = mkBuiltinFn \cont handler -> \case - [VModRef m1 _, VModRef m2 _] -> - returnCEKValue cont handler $ VBool (m1 == m2) - vals -> failInvariant $ "base64-encode" <> T.pack (show vals) - -neqModRef :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqModRef = mkBuiltinFn \cont handler -> \case - [VModRef m1 _, VModRef m2 _] -> - returnCEKValue cont handler $ VBool (m1 /= m2) - _ -> failInvariant "base64-encode" - - ------------------------------------ --- Other Core forms ------------------------------------ - --- coreIf :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreIf = mkBuiltinFn \case --- [VLiteral (LBool b), VClosure tbody tenv, VClosure fbody fenv] -> --- if b then eval tenv tbody else eval fenv fbody --- _ -> failInvariant "if" - -coreB64Encode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Encode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString l)] -> - returnCEKValue cont handler $ VLiteral $ LString $ toB64UrlUnpaddedText $ T.encodeUtf8 l - _ -> failInvariant "base64-encode" - - -coreB64Decode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Decode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> case fromB64UrlUnpaddedText $ T.encodeUtf8 s of - Left{} -> throwExecutionError' (DecodeError "invalid b64 encoding") - Right txt -> returnCEKValue cont handler (VLiteral (LString txt)) - _ -> failInvariant "base64-encode" - - - ------------------------------------ --- Core definitions ------------------------------------ - -unimplemented :: NativeFn b i m -unimplemented = error "unimplemented" - -coreBuiltinRuntime :: MonadEval CoreBuiltin i m => CoreBuiltin -> NativeFn CoreBuiltin i m -coreBuiltinRuntime = \case - -- Int Add + num ops - AddInt -> addInt AddInt - SubInt -> subInt SubInt - DivInt -> divInt DivInt - MulInt -> mulInt MulInt - NegateInt -> negateInt NegateInt - AbsInt -> absInt AbsInt - PowInt -> powInt PowInt - -- Int fractional - ExpInt -> expInt ExpInt - LnInt -> lnInt LnInt - SqrtInt -> sqrtInt SqrtInt - LogBaseInt -> logBaseInt LogBaseInt - -- Geenral int ops - ModInt -> modInt ModInt - BitAndInt -> bitAndInt BitAndInt - BitOrInt -> bitOrInt BitOrInt - BitXorInt -> bitXorInt BitXorInt - BitShiftInt -> bitShiftInt BitShiftInt - BitComplementInt -> bitComplementInt BitComplementInt - -- Int Equality + Ord - EqInt -> eqInt EqInt - NeqInt -> neqInt NeqInt - GTInt -> gtInt GTInt - GEQInt -> geqInt GEQInt - LTInt -> ltInt LTInt - LEQInt -> leqInt LEQInt - -- IntShow inst - ShowInt -> showInt ShowInt - -- If - -- IfElse -> coreIf IfElse - -- Decimal ops - -- Add + Num - AddDec -> addDec AddDec - SubDec -> subDec SubDec - DivDec -> divDec DivDec - MulDec -> mulDec MulDec - PowDec -> powDec PowDec - NegateDec -> negateDec NegateDec - AbsDec -> absDec AbsDec - -- Decimal rounding ops - RoundDec -> roundDec RoundDec - CeilingDec -> ceilingDec CeilingDec - FloorDec -> floorDec FloorDec - -- Decimal fractional - ExpDec -> expDec ExpDec - LnDec -> lnDec LnDec - LogBaseDec -> logBaseDec LogBaseDec - SqrtDec -> sqrtDec SqrtDec - -- Decimal show - ShowDec -> showDec ShowDec - -- Decimal Equality + Ord - EqDec -> eqDec EqDec - NeqDec -> neqDec NeqDec - GTDec -> gtDec GTDec - GEQDec -> geqDec GEQDec - LTDec -> ltDec LTDec - LEQDec -> leqDec LEQDec - -- Bool Ops - -- AndBool -> andBool AndBool - -- OrBool -> orBool OrBool - NotBool -> notBool NotBool - -- Bool Equality - EqBool -> eqBool EqBool - NeqBool -> neqBool NeqBool - ShowBool -> showBool ShowBool - -- String Equality + Ord - EqStr -> eqStr EqStr - NeqStr -> neqStr NeqStr - GTStr -> gtStr GTStr - GEQStr -> geqStr GEQStr - LTStr -> ltStr LTStr - LEQStr -> leqStr LEQStr - -- String Ops - AddStr -> addStr AddStr - -- String listlike - ConcatStr -> concatStr ConcatStr - DropStr -> dropStr DropStr - TakeStr -> takeStr TakeStr - LengthStr -> lengthStr LengthStr - ReverseStr -> reverseStr ReverseStr - -- String show - ShowStr -> showStr ShowStr - -- Object equality - -- EqObj -> eqObj EqObj - -- NeqObj -> neqObj NeqObj - -- List Equality + Ord - EqList -> eqList EqList - NeqList -> neqList NeqList - GTList -> unimplemented - GEQList -> unimplemented - LTList -> unimplemented - LEQList -> unimplemented - -- List Show - ShowList -> pcShowList ShowList - -- ListAdd - AddList -> addList AddList - -- List ListlLike - TakeList -> takeList TakeList - DropList -> dropList DropList - LengthList -> lengthList LengthList - ConcatList -> concatList ConcatList - ReverseList -> reverseList ReverseList - -- misc list ops - FilterList -> coreFilter FilterList - DistinctList -> unimplemented - ZipList -> zipList ZipList - MapList -> coreMap MapList - FoldList -> coreFold FoldList - -- Unit ops - EqUnit -> eqUnit EqUnit - NeqUnit -> neqUnit NeqUnit - ShowUnit -> showUnit ShowUnit - EqModRef -> eqModRef EqModRef - NeqModRef -> neqModRef NeqModRef - Enforce -> coreEnforce Enforce - EnforceOne -> unimplemented - -- coreEnforceOne EnforceOne - Enumerate -> coreEnumerate Enumerate - EnumerateStepN -> coreEnumerateStepN EnumerateStepN - ReadInteger -> unimplemented - ReadDecimal -> unimplemented - ReadString -> unimplemented - -- ReadInteger -> coreReadInteger ReadInteger - -- ReadDecimal -> coreReadDecimal ReadDecimal - -- ReadString -> coreReadString ReadString - -- ReadKeyset -> coreReadKeyset ReadKeyset - -- EnforceGuard -> coreEnforceGuard EnforceGuard - -- KeysetRefGuard -> coreKeysetRefGuard KeysetRefGuard - ReadKeyset -> unimplemented - EnforceGuard -> unimplemented - KeysetRefGuard -> unimplemented - -- CreateUserGuard -> createUserGuard CreateUserGuard - ListAccess -> listAccess ListAccess - MakeList -> makeList MakeList - B64Encode -> coreB64Encode B64Encode - B64Decode -> coreB64Decode B64Decode - StrToList -> strToList StrToList - -coreBuiltinLiftedRuntime - :: (MonadEval b i m, BuiltinArity b) - => (CoreBuiltin -> b) - -> CoreBuiltin - -> NativeFn b i m -coreBuiltinLiftedRuntime f = \case - -- Int Add + num ops - AddInt -> addInt (f AddInt) - SubInt -> subInt (f SubInt) - DivInt -> divInt (f DivInt) - MulInt -> mulInt (f MulInt) - PowInt -> powInt (f PowInt) - NegateInt -> negateInt (f NegateInt) - AbsInt -> absInt (f AbsInt) - -- Int fractional - ExpInt -> expInt (f ExpInt) - LnInt -> lnInt (f LnInt) - SqrtInt -> sqrtInt (f SqrtInt) - LogBaseInt -> logBaseInt (f LogBaseInt) - -- Geenral int ops - ModInt -> modInt (f ModInt) - BitAndInt -> bitAndInt (f BitAndInt) - BitOrInt -> bitOrInt (f BitOrInt) - BitXorInt -> bitXorInt (f BitXorInt) - BitShiftInt -> bitShiftInt (f BitShiftInt) - BitComplementInt -> bitComplementInt (f BitComplementInt) - -- Int Equality + Ord - EqInt -> eqInt (f EqInt) - NeqInt -> neqInt (f NeqInt) - GTInt -> gtInt (f GTInt) - GEQInt -> geqInt (f GEQInt) - LTInt -> ltInt (f LTInt) - LEQInt -> leqInt (f LEQInt) - -- IntShow inst - ShowInt -> showInt (f ShowInt) - -- If - -- IfElse -> coreIf (f IfElse) - -- Decimal ops - -- Add + Num - AddDec -> addDec (f AddDec) - SubDec -> subDec (f SubDec) - DivDec -> divDec (f DivDec) - MulDec -> mulDec (f MulDec) - PowDec -> powDec (f PowDec) - NegateDec -> negateDec (f NegateDec) - AbsDec -> absDec (f AbsDec) - -- Decimal rounding ops - RoundDec -> roundDec (f RoundDec) - CeilingDec -> ceilingDec (f CeilingDec) - FloorDec -> floorDec (f FloorDec) - -- Decimal fractional - ExpDec -> expDec (f ExpDec) - LnDec -> lnDec (f LnDec) - LogBaseDec -> logBaseDec (f LogBaseDec) - SqrtDec -> sqrtDec (f SqrtDec) - -- Decimal show - ShowDec -> showDec (f ShowDec) - -- Decimal Equality + Ord - EqDec -> eqDec (f EqDec) - NeqDec -> neqDec (f NeqDec) - GTDec -> gtDec (f GTDec) - GEQDec -> geqDec (f GEQDec) - LTDec -> ltDec (f LTDec) - LEQDec -> leqDec (f LEQDec) - -- Bool Ops - -- AndBool -> andBool (f AndBool) - -- OrBool -> orBool (f OrBool) - NotBool -> notBool (f NotBool) - -- Bool Equality - EqBool -> eqBool (f EqBool) - NeqBool -> neqBool (f NeqBool) - ShowBool -> showBool (f ShowBool) - -- String Equality + Ord - EqStr -> eqStr (f EqStr) - NeqStr -> neqStr (f NeqStr) - GTStr -> gtStr (f GTStr) - GEQStr -> geqStr (f GEQStr) - LTStr -> ltStr (f LTStr) - LEQStr -> leqStr (f LEQStr) - -- String Ops - AddStr -> addStr (f AddStr) - -- String listlike - ConcatStr -> concatStr (f ConcatStr) - DropStr -> dropStr (f DropStr) - TakeStr -> takeStr (f TakeStr) - LengthStr -> lengthStr (f LengthStr) - ReverseStr -> reverseStr (f ReverseStr) - -- String show - ShowStr -> showStr (f ShowStr) - -- Object equality - -- EqObj -> eqObj EqObj - -- NeqObj -> neqObj NeqObj - -- List Equality + Ord - EqList -> eqList (f EqList) - NeqList -> neqList (f NeqList) - GTList -> unimplemented - GEQList -> unimplemented - LTList -> unimplemented - LEQList -> unimplemented - -- List Show - ShowList -> pcShowList (f ShowList) - -- ListAdd - AddList -> addList (f AddList) - -- List ListlLike - TakeList -> takeList (f TakeList) - DropList -> dropList (f DropList) - LengthList -> lengthList (f LengthList) - ConcatList -> concatList (f ConcatList) - ReverseList -> reverseList (f ReverseList) - -- misc list ops - FilterList -> coreFilter (f FilterList) - DistinctList -> unimplemented - ZipList -> zipList (f ZipList) - MapList -> coreMap (f MapList) - FoldList -> coreFold (f FoldList) - -- Unit ops - EqUnit -> eqUnit (f EqUnit) - NeqUnit -> neqUnit (f NeqUnit) - ShowUnit -> showUnit (f ShowUnit) - EqModRef -> eqModRef (f EqModRef) - NeqModRef -> neqModRef (f NeqModRef) - Enforce -> coreEnforce (f Enforce) - EnforceOne -> unimplemented - -- coreEnforceOne EnforceOne - Enumerate -> coreEnumerate (f Enumerate) - EnumerateStepN -> coreEnumerateStepN (f EnumerateStepN) - ReadInteger -> unimplemented - ReadDecimal -> unimplemented - ReadString -> unimplemented - -- ReadInteger -> coreReadInteger ReadInteger - -- ReadDecimal -> coreReadDecimal ReadDecimal - -- ReadString -> coreReadString ReadString - -- ReadKeyset -> coreReadKeyset ReadKeyset - -- EnforceGuard -> coreEnforceGuard EnforceGuard - -- KeysetRefGuard -> coreKeysetRefGuard KeysetRefGuard - ReadKeyset -> unimplemented - EnforceGuard -> unimplemented - KeysetRefGuard -> unimplemented - ListAccess -> listAccess (f ListAccess) - MakeList -> makeList (f MakeList) - B64Encode -> coreB64Encode (f B64Encode) - B64Decode -> coreB64Decode (f B64Decode) - StrToList -> strToList (f StrToList) diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs deleted file mode 100644 index 4c07479bb..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs +++ /dev/null @@ -1,1002 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core using our RawBuiltins (aka untyped, no typechecking) --- - -module Pact.Core.Untyped.Eval.Runtime.RawBuiltin where - -import Control.Monad(when) - -import Data.Bits -import Data.Decimal(roundTo', Decimal) -import Data.Text(Text) -import Data.Vector(Vector) -import Data.List(intersperse) -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Errors -import Pact.Core.Hash -import Pact.Core.Names -import Pact.Core.Pretty(pretty) - -import Pact.Core.Untyped.Eval.Runtime -import Pact.Core.Untyped.Eval.CEK - - ----------------------------------------------------------------------- --- Our builtin definitions start here ----------------------------------------------------------------------- - --- -- Todo: runtime error -unaryIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer) -> b -> NativeFn b i m -unaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) - _ -> failInvariant "unary int function" -{-# INLINE unaryIntFn #-} - -unaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal) -> b -> NativeFn b i m -unaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LDecimal (op i))) - _ -> failInvariant "unary decimal function" -{-# INLINE unaryDecFn #-} - -binaryIntFn - :: (BuiltinArity b, MonadEval b i m) - => (Integer -> Integer -> Integer) - -> b - -> NativeFn b i m -binaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) - _ -> failInvariant "binary int function" -{-# INLINE binaryIntFn #-} - -binaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Decimal) -> b -> NativeFn b i m -binaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (op i i'))) - _ -> failInvariant "binary decimal function" -{-# INLINE binaryDecFn #-} - -binaryBoolFn :: (BuiltinArity b, MonadEval b i m) => (Bool -> Bool -> Bool) -> b -> NativeFn b i m -binaryBoolFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool l), VLiteral (LBool r)] -> returnCEKValue cont handler (VLiteral (LBool (op l r))) - _ -> failInvariant "binary bool function" -{-# INLINE binaryBoolFn #-} - -compareIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer -> Bool) -> b -> NativeFn b i m -compareIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "int cmp function" -{-# INLINE compareIntFn #-} - -compareDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Bool) -> b -> NativeFn b i m -compareDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "dec cmp function" -{-# INLINE compareDecFn #-} - -compareStrFn :: (BuiltinArity b, MonadEval b i m) => (Text -> Text -> Bool) -> b -> NativeFn b i m -compareStrFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "str cmp function" -{-# INLINE compareStrFn #-} - -roundingFn :: (BuiltinArity b, MonadEval b i m) => (Rational -> Integer) -> b -> NativeFn b i m -roundingFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 i)))) - _ -> failInvariant "rounding function" -{-# INLINE roundingFn #-} - ---------------------------------- --- Arithmetic Ops ------------------------------- -rawAdd :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawAdd = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i + i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i + i'))) - [VLiteral (LString i), VLiteral (LString i')] -> - returnCEKValue cont handler (VLiteral (LString (i <> i'))) - [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) - _ -> failInvariant "add" - -rawSub :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawSub = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i - i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i - i'))) - _ -> failInvariant "subtract" - -rawMul :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawMul = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i * i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i * i'))) - _ -> failInvariant "multiply" - -rawPow :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawPow = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> do - when (i' < 0) $ throwExecutionError' (ArithmeticException "negative exponent in integer power") - returnCEKValue cont handler (VLiteral (LInteger (i ^ i'))) - [VLiteral (LDecimal a), VLiteral (LDecimal b)] -> do - let result = dec2F a ** dec2F b - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "pow" - -rawLogBase :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLogBase = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger base), VLiteral (LInteger n)] -> do - when (base < 0 || n <= 0) $ throwExecutionError' (ArithmeticException "Illegal log base") - let base' = fromIntegral base :: Double - n' = fromIntegral n - out = round (logBase base' n') - returnCEKValue cont handler (VLiteral (LInteger out)) - -- if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - -- else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do - when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") - let result = logBase (dec2F base) (dec2F arg) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "logBase" - -rawDiv :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawDiv = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero, decimal") - else returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) - _ -> failInvariant "div" - -rawNegate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawNegate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LInteger (negate i))) - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LDecimal (negate i))) - _ -> failInvariant "negate" - -rawMod :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawMod = binaryIntFn mod - -rawEq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawEq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LBool i), VLiteral (LBool i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) - [VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool False)) - else returnCEKValue cont handler (VBool (valueEq (VList l) (VList r))) - _ -> failInvariant "eq" - -modInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -modInt = binaryIntFn mod - -valueEq :: CEKValue b i m -> CEKValue b i m -> Bool -valueEq (VInteger i) (VInteger r) = i == r -valueEq (VDecimal l) (VDecimal r) = l == r -valueEq (VString l) (VString r) = l == r -valueEq VUnit VUnit = True -valueEq (VBool l) (VBool r) = l == r -valueEq (VList l) (VList r) = - V.length l == V.length r && all (uncurry valueEq) (V.zip l r) -valueEq _ _ = False - -prettyShowValue :: CEKValue b i m -> Text -prettyShowValue = \case - VLiteral lit -> T.pack (show (pretty lit)) - VList vec -> - "[" <> T.concat (intersperse ", " (prettyShowValue <$> V.toList vec)) <> "]" - VClosure _ _ -> "<#closure>" - VNative _ -> "<#nativefn>" - VGuard _ -> "<#guard>" - VModRef mn _ -> "modRef{" <> (_mnName mn) <> "}" - -rawNeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawNeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LBool i), VLiteral (LBool i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) - [VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool True)) - else returnCEKValue cont handler (VBool (not (valueEq (VList l) (VList r)))) - _ -> failInvariant "neq" - -rawGt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawGt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - _ -> failInvariant "int cmp function" - -rawLt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - _ -> failInvariant "int cmp function" - -rawGeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawGeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - _ -> failInvariant "int cmp function" - -rawLeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - _ -> failInvariant "int cmp function" - -bitAndInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitAndInt = binaryIntFn (.&.) - -bitOrInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitOrInt = binaryIntFn (.|.) - -bitComplementInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitComplementInt = unaryIntFn complement - -bitXorInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitXorInt = binaryIntFn xor - -bitShiftInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitShiftInt = binaryIntFn (\i s -> shift i (fromIntegral s)) - -rawAbs :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawAbs = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LInteger (abs i))) - [VLiteral (LDecimal e)] -> do - returnCEKValue cont handler (VLiteral (LDecimal (abs e))) - _ -> failInvariant "abs" - -rawExp :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawExp = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = exp (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - let result = exp (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "exe" - -rawLn :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLn = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = log (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - let result = log (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "lnInt" - -rawSqrt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawSqrt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - when (i < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "sqrtInt" - --- Todo: fix all show instances -rawShow :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawShow = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LString i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LBool i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral LUnit] -> - returnCEKValue cont handler (VLiteral (LString "()")) - _ -> failInvariant "showInt" - --- ------------------------- --- double ops --- ------------------------- - -guardNanOrInf :: MonadEval b i m => Double -> m () -guardNanOrInf a = - when (isNaN a || isInfinite a) $ throwExecutionError' (FloatingPointError "Floating operation resulted in Infinity or NaN") - -dec2F :: Decimal -> Double -dec2F = fromRational . toRational - -f2Dec :: Double -> Decimal -f2Dec = fromRational . toRational - -roundDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -roundDec = roundingFn round - -floorDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -floorDec = roundingFn floor - -ceilingDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ceilingDec = roundingFn ceiling - --- Todo: exp and ln, sqrt have similar failure conditions --- expDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- expDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- let result = exp (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" --- -- unaryDecFn (f2Dec . exp . dec2F) - --- lnDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- lnDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- let result = log (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - --- logBaseDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- logBaseDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do --- when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") --- let result = logBase (dec2F base) (dec2F arg) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - - --- sqrtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- sqrtDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") --- let result = sqrt (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - - ---------------------------- --- bool ops ---------------------------- -andBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -andBool = binaryBoolFn (&&) - -orBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -orBool = binaryBoolFn (||) - -notBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -notBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) - _ -> failInvariant "notBool" - --- eqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqBool = binaryBoolFn (==) - --- neqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqBool = binaryBoolFn (/=) - --- showBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showBool = mkBuiltinFn \cont handler -> \case --- [VLiteral (LBool i)] -> do --- let out = if i then "true" else "false" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showBool" - ---------------------------- --- string ops ---------------------------- --- eqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqStr = compareStrFn (==) - --- neqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqStr = compareStrFn (/=) - --- gtStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- gtStr = compareStrFn (>) - --- geqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- geqStr = compareStrFn (>=) - --- ltStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- ltStr = compareStrFn (<) - --- leqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- leqStr = compareStrFn (<=) - --- addStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- addStr = mkBuiltinFn \cont handler -> \case --- [VLiteral (LString i), VLiteral (LString i')] -> --- returnCEKValue cont handler (VLiteral (LString (i <> i'))) --- _ -> failInvariant "addStr" - -rawTake :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawTake = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.take clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.drop clamp li)) - _ -> failInvariant "takeStr" - -rawDrop :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawDrop = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.drop clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.take clamp li)) - _ -> failInvariant "dropStr" - -rawLength :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLength = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (T.length t)))) - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthStr" - -rawReverse :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawReverse = mkBuiltinFn \cont handler -> \case - [VList li] -> - returnCEKValue cont handler (VList (V.reverse li)) - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LString (T.reverse t))) - _ -> failInvariant "reverseStr" - --- showStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showStr = mkBuiltinFn \cont handler -> \case --- [VLiteral (LString t)] -> do --- let out = "\"" <> t <> "\"" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showStr" - -concatStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatStr = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asString li - returnCEKValue cont handler (VLiteral (LString (T.concat (V.toList li')))) - _ -> failInvariant "concatStr" - -strToList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -strToList = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> do - let v = VList (V.fromList (VLiteral . LString . T.singleton <$> T.unpack s)) - returnCEKValue cont handler v - _ -> failInvariant "concatStr" - ---------------------------- --- Unit ops ---------------------------- - --- eqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) --- _ -> failInvariant "eqUnit" - --- neqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) --- _ -> failInvariant "neqUnit" - --- showUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LString "()")) --- _ -> failInvariant "showUnit" - ---------------------------- --- Object ops ---------------------------- - --- eqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeEqCEKValue l r))) --- _ -> failInvariant "eqObj" - --- neqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeNeqCEKValue l r))) --- _ -> failInvariant "neqObj" - - ------------------------------- ---- conversions + unsafe ops ------------------------------- --- asBool :: MonadEval b i m => CEKValue b i m -> m Bool --- asBool (VLiteral (LBool b)) = pure b --- asBool _ = failInvariant "asBool" - -asString :: MonadEval b i m => CEKValue b i m -> m Text -asString (VLiteral (LString b)) = pure b -asString _ = failInvariant "asString" - -asList :: MonadEval b i m => CEKValue b i m -> m (Vector (CEKValue b i m)) -asList (VList l) = pure l -asList _ = failInvariant "asList" - --- unsafeEqLiteral :: Literal -> Literal -> Bool --- unsafeEqLiteral (LString i) (LString i') = i == i' --- unsafeEqLiteral (LInteger i) (LInteger i') = i == i' --- unsafeEqLiteral (LDecimal i) (LDecimal i') = i == i' --- unsafeEqLiteral LUnit LUnit = True --- unsafeEqLiteral (LBool i) (LBool i') = i == i' --- unsafeEqLiteral (LTime i) (LTime i') = i == i' --- unsafeEqLiteral _ _ = --- throw (InvariantFailure "invariant failed in literal EQ") - --- unsafeNeqLiteral :: Literal -> Literal -> Bool --- unsafeNeqLiteral a b = not (unsafeEqLiteral a b) - --- unsafeEqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeEqCEKValue (VLiteral l) (VLiteral l') = unsafeEqLiteral l l' --- unsafeEqCEKValue (VObject o) (VObject o') = and (M.intersectionWith unsafeEqCEKValue o o') --- unsafeEqCEKValue (VList l) (VList l') = V.length l == V.length l' && and (V.zipWith unsafeEqCEKValue l l') --- unsafeEqCEKValue _ _ = throw (InvariantFailure "invariant failed in value Eq") - --- unsafeNeqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeNeqCEKValue a b = not (unsafeEqCEKValue a b) - ---------------------------- --- list ops ---------------------------- - - --- neqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqList = mkBuiltinFn \cont handler -> \case --- [neqClo, VList l, VList r] -> --- if V.length l /= V.length r then --- returnCEKValue cont handler (VLiteral (LBool True)) --- else zip' (V.toList l) (V.toList r) [] --- where --- zip' (x:xs) (y:ys) acc = unsafeApplyTwo neqClo x y >>= \case --- EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) --- v@VError{} -> returnCEK cont handler v --- _ -> failInvariant "applying closure in list eq yielded incorrect type" --- zip' _ _ acc = returnCEKValue cont handler (VLiteral (LBool (or acc))) --- _ -> failInvariant "neqList" - -zipList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -zipList = mkBuiltinFn \cont handler -> \case - [clo, VList l, VList r] -> zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo clo x y >>= \case - EvalValue v -> zip' xs ys (v:acc) - v@VError{} -> returnCEK cont handler v - zip' _ _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "zipList" - --- addList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- addList = mkBuiltinFn \cont handler -> \case --- [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) --- _ -> failInvariant "addList" - --- pcShowList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- pcShowList = mkBuiltinFn \cont handler -> \case --- [showFn, VList l1] -> show' (V.toList l1) [] --- where --- show' (x:xs) acc = unsafeApplyOne showFn x >>= \case --- EvalValue (VLiteral (LString b)) -> show' xs (b:acc) --- v@VError{} -> returnCEK cont handler v --- _ -> failInvariant "applying closure in list eq yielded incorrect type" --- show' _ acc = do --- let out = "[" <> T.intercalate ", " (reverse acc) <> "]" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showList" - -coreMap :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreMap = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> map' (V.toList li) [] - where - map' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue cv -> map' xs (cv:acc) - v -> returnCEK cont handler v - map' _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "map" - -coreFilter :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFilter = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> filter' (V.toList li) [] - where - filter' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue (VLiteral (LBool b)) -> - if b then filter' xs (x:acc) else filter' xs acc - v@VError{} -> - returnCEK cont handler v - _ -> failInvariant "filter" - filter' [] acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "filter" - -coreFold :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFold = mkBuiltinFn \cont handler -> \case - [fn, initElem, VList li] -> - fold' initElem (V.toList li) - where - fold' e (x:xs) = unsafeApplyTwo fn e x >>= \case - EvalValue v -> fold' v xs - v -> returnCEK cont handler v - fold' e [] = returnCEKValue cont handler e - _ -> failInvariant "fold" - -lengthList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthList = mkBuiltinFn \cont handler -> \case - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthList" - --- takeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- takeList = mkBuiltinFn \cont handler -> \case --- [VLiteral (LInteger i), VList li] --- | i >= 0 -> do --- let clamp = fromIntegral $ min i (fromIntegral (V.length li)) --- returnCEKValue cont handler (VList (V.take clamp li)) --- | otherwise -> do --- let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 --- returnCEKValue cont handler (VList (V.drop clamp li)) --- _ -> failInvariant "takeList" - --- dropList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- dropList = mkBuiltinFn \cont handler -> \case --- [VLiteral (LInteger i), VList li] --- | i >= 0 -> do --- let clamp = fromIntegral $ min i (fromIntegral (V.length li)) --- returnCEKValue cont handler (VList (V.drop clamp li)) --- | otherwise -> do --- let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 --- returnCEKValue cont handler (VList (V.take clamp li)) --- _ -> failInvariant "dropList" - --- reverseList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- reverseList = mkBuiltinFn \cont handler -> \case --- [VList li] -> --- returnCEKValue cont handler (VList (V.reverse li)) --- _ -> failInvariant "takeList" - -coreEnumerate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to)] -> do - v <- createEnumerateList from to (if from > to then -1 else 1) - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate" - -createEnumerateList - :: (MonadEval b i m) - => Integer - -- ^ from - -> Integer - -- ^ to - -> Integer - -- ^ Step - -> m (Vector Integer) -createEnumerateList from to inc - | from == to = pure (V.singleton from) - | inc == 0 = pure mempty - | from < to, from + inc < from = - throwExecutionError' (EnumerationError "enumerate: increment diverges below from interval bounds.") - | from > to, from + inc > from = - throwExecutionError' (EnumerationError "enumerate: increment diverges above from interval bounds.") - | otherwise = let - step = succ (abs (from - to) `div` abs inc) - in pure $ V.enumFromStepN from inc (fromIntegral step) - -coreEnumerateStepN :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerateStepN = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do - v <- createEnumerateList from to inc - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate-step" - --- concatList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- concatList = mkBuiltinFn \cont handler -> \case --- [VList li] -> do --- li' <- traverse asList li --- returnCEKValue cont handler (VList (V.concat (V.toList li'))) --- _ -> failInvariant "takeList" - -makeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -makeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), v] -> do - returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) - _ -> failInvariant "makeList" - -listAccess :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -listAccess = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList vec] -> - case vec V.!? fromIntegral i of - Just v -> returnCEKValue cont handler v - _ -> throwExecutionError' (ArrayOutOfBoundsException (V.length vec) (fromIntegral i)) - _ -> failInvariant "list-access" - ------------------------------------ --- try-related ops ------------------------------------ - -coreEnforce :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnforce = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool b), VLiteral (LString s)] -> - if b then returnCEKValue cont handler (VLiteral LUnit) - else returnCEK cont handler (VError s) - _ -> failInvariant "enforce" - --- coreEnforceOne :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceOne = mkBuiltinFn \case --- [VList v, VLiteral (LString msg)] -> --- enforceFail msg (V.toList v) --- _ -> failInvariant "coreEnforceOne" --- where --- handler msg rest = \case --- EnforceException _ -> enforceFail msg rest --- e -> throwM e --- enforceClo _ [] = pure (VLiteral LUnit) --- enforceClo msg (x:xs) = catch (unsafeApplyOne x (VLiteral LUnit)) (handler msg xs) --- enforceFail msg [] = throwM (EnforceException msg) --- enforceFail msg as = enforceClo msg as ------------------------------------ --- Guards and reads ------------------------------------ - --- readError :: Text -> Text -> Text --- readError field expected = --- "invalid value at field " <> field <> " expected: " <> expected - --- coreReadInteger :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadInteger = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LInteger{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "integer")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-integer" - --- coreReadString :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadString = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv-> case pv of --- PLiteral l@LString{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "string")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-string" - --- coreReadDecimal :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadDecimal = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LDecimal{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-decimal" - --- coreReadObject :: CEKRuntime b i => Row Void -> CEKValue b i m -> EvalT b i (CEKValue b i m) --- coreReadObject ty = \case --- VLiteral (LString s) -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- t@PObject{} | checkPactValueType (TyRow ty) t -> pure (fromPactValue t) --- _ -> throwM (ReadException (readError s "object")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "readObject" - --- coreReadKeyset :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadKeyset = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PObject m -> case lookupKs m of --- Just ks -> pure (VGuard (GKeyset ks)) --- _ -> throwM (ReadException "Invalid keyset format") --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-keyset" --- where --- -- Todo: public key parsing. --- -- This is most certainly wrong, it needs more checks. --- lookupKs m = do --- ks <- M.lookup (Field "keys") m >>= \case --- PList v -> do --- o <- traverse (preview (_PLiteral . _LString)) v --- guard (all (T.all isHexDigit) o) --- pure $ Set.fromList $ V.toList (PublicKey . T.encodeUtf8 <$> o) --- _ -> Nothing --- kspred <- case M.lookup (Field "pred") m of --- (Just (PLiteral LString{})) -> pure KeysAll --- Just _ -> Nothing --- Nothing -> pure KeysAll --- pure (KeySet ks kspred) - - --- coreKeysetRefGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreKeysetRefGuard = mkBuiltinFn \case --- [VLiteral (LString s)] -> pure (VGuard (GKeySetRef (KeySetName s))) --- _ -> failInvariant "keyset-ref-guard" - --- coreEnforceGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceGuard = mkBuiltinFn \case --- [VGuard v] -> case v of --- GKeyset ks -> enforceKeySet ks --- GKeySetRef ksr -> enforceKeySetRef ksr --- GUserGuard ug -> enforceUserGuard ug --- _ -> failInvariant "enforceGuard" - --- enforceKeySet :: CEKRuntime b i => KeySet name -> EvalT b i (CEKValue b i m) --- enforceKeySet (KeySet keys p) = do --- let sigs = _ckeSigs ?cekRuntimeEnv --- matched = Set.size $ Set.filter (`Set.member` keys) sigs --- count = Set.size keys --- case p of --- KeysAll | matched == count -> pure (VLiteral LUnit) --- Keys2 | matched >= 2 -> pure (VLiteral LUnit) --- KeysAny | matched > 0 -> pure (VLiteral LUnit) --- _ -> throwM (EnforceException "cannot match keyset predicate") - --- enforceKeySetRef :: CEKRuntime b i => KeySetName -> EvalT b i (CEKValue b i m) --- enforceKeySetRef ksr = do --- let pactDb = _ckePactDb ?cekRuntimeEnv --- liftIO (_readKeyset pactDb ksr) >>= \case --- Just ks -> enforceKeySet ks --- Nothing -> throwM (EnforceException "no such keyset") - --- enforceUserGuard :: CEKRuntime b i => CEKValue b i m -> EvalT b i (CEKValue b i m) --- enforceUserGuard = \case --- v@VClosure{} -> unsafeApplyOne v (VLiteral LUnit) >>= \case --- VLiteral LUnit -> pure (VLiteral LUnit) --- _ -> failInvariant "expected a function returning unit" --- _ -> failInvariant "invalid type for user closure" - --- createUserGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- createUserGuard = mkBuiltinFn \case --- [v@VClosure{}] -> pure (VGuard (GUserGuard v)) --- _ -> failInvariant "create-user-guard" - ------------------------------------ --- Other Core forms ------------------------------------ - --- coreIf :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreIf = mkBuiltinFn \case --- [VLiteral (LBool b), VClosure tbody tenv, VClosure fbody fenv] -> --- if b then eval tenv tbody else eval fenv fbody --- _ -> failInvariant "if" - -coreB64Encode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Encode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString l)] -> - returnCEKValue cont handler $ VLiteral $ LString $ toB64UrlUnpaddedText $ T.encodeUtf8 l - _ -> failInvariant "base64-encode" - - -coreB64Decode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Decode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> case fromB64UrlUnpaddedText $ T.encodeUtf8 s of - Left{} -> throwExecutionError' (DecodeError "invalid b64 encoding") - Right txt -> returnCEKValue cont handler (VLiteral (LString txt)) - _ -> failInvariant "base64-encode" - - - ------------------------------------ --- Core definitions ------------------------------------ - -unimplemented :: NativeFn b i m -unimplemented = error "unimplemented" - -rawBuiltinRuntime - :: (MonadEval RawBuiltin i m) - => RawBuiltin - -> NativeFn RawBuiltin i m -rawBuiltinRuntime = rawBuiltinLiftedRuntime id - -rawBuiltinLiftedRuntime - :: (MonadEval b i m, BuiltinArity b) - => (RawBuiltin -> b) - -> RawBuiltin - -> NativeFn b i m -rawBuiltinLiftedRuntime f = \case - RawAdd -> rawAdd (f RawAdd) - RawSub -> rawSub (f RawSub) - RawMultiply -> rawMul (f RawMultiply) - RawDivide -> rawDiv (f RawDivide) - RawNegate -> rawNegate (f RawNegate) - RawAbs -> rawAbs (f RawAbs) - RawPow -> rawPow (f RawPow) - RawNot -> notBool (f RawNot) - RawEq -> rawEq (f RawEq) - RawNeq -> rawNeq (f RawNeq) - RawGT -> rawGt (f RawGT) - RawGEQ -> rawGeq (f RawGEQ) - RawLT -> rawLt (f RawLT) - RawLEQ -> rawLeq (f RawLEQ) - RawBitwiseAnd -> bitAndInt (f RawBitwiseAnd) - RawBitwiseOr -> bitOrInt (f RawBitwiseOr) - RawBitwiseXor -> bitXorInt (f RawBitwiseXor) - RawBitwiseFlip -> bitComplementInt (f RawBitwiseFlip) - RawBitShift -> bitShiftInt (f RawBitShift) - RawRound -> roundDec (f RawRound) - RawCeiling -> ceilingDec (f RawCeiling) - RawFloor -> floorDec (f RawFloor) - RawExp -> rawExp (f RawExp) - RawLn -> rawLn (f RawLn) - RawSqrt -> rawSqrt (f RawSqrt) - RawLogBase -> rawLogBase (f RawLogBase) - RawLength -> rawLength (f RawLength) - RawTake -> rawTake (f RawTake) - RawDrop -> rawDrop (f RawDrop) - RawConcat -> concatStr (f RawConcat) - RawReverse -> rawReverse (f RawReverse) - RawMod -> modInt (f RawMod) - RawMap -> coreMap (f RawMap) - RawFilter -> coreFilter (f RawFilter) - RawZip -> zipList (f RawZip) - RawIntToStr -> unimplemented - RawStrToInt -> unimplemented - RawFold -> coreFold (f RawFold) - RawDistinct -> unimplemented - RawEnforce -> coreEnforce (f RawEnforce) - RawEnforceOne -> unimplemented - RawEnumerate -> coreEnumerate (f RawEnumerate) - RawEnumerateStepN -> coreEnumerateStepN (f RawEnumerateStepN) - RawShow -> rawShow (f RawShow) - RawReadInteger -> unimplemented - RawReadDecimal -> unimplemented - RawReadString -> unimplemented - RawReadKeyset -> unimplemented - RawEnforceGuard -> unimplemented - RawKeysetRefGuard -> unimplemented - RawListAccess -> listAccess (f RawListAccess) - RawMakeList -> makeList (f RawMakeList) - RawB64Encode -> coreB64Encode (f RawB64Encode) - RawB64Decode -> coreB64Decode (f RawB64Decode) - RawStrToList -> strToList (f RawStrToList) diff --git a/typed-core/Pact/Core/Untyped/Term.hs b/typed-core/Pact/Core/Untyped/Term.hs deleted file mode 100644 index c63e1ccaa..000000000 --- a/typed-core/Pact/Core/Untyped/Term.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} - -module Pact.Core.Untyped.Term - ( Defun(..) - , DefConst(..) - , DefCap(..) - , Def(..) - , defType - , defName - , defTerm - , defKind - , ifDefName - , Module(..) - , Interface(..) - , IfDefun(..) - , IfDefCap(..) - , IfDef(..) - , TopLevel(..) - , ReplTopLevel(..) - , Term(..) - , EvalTerm - , EvalModule - , EvalInterface - , EvalDef - , EvalDefConst - , fromIRTerm - , fromIRDef - , fromIRModule - , fromIRTopLevel - , fromIRReplTopLevel - , termInfo - -- Module Lenses - , mName - , mDefs - , mBlessed - , mImports - , mImplements - , mHash - , mGovernance - , mInfo - -- Interface lenses - , ifName - , ifDefns - , ifHash - , ifInfo - , findIfDef - , _IfDfun - , _IfDConst - ) where - -import Control.Lens -import Data.Text(Text) -import Data.Void -import Data.Foldable(foldl', find) -import qualified Data.Set as Set - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Names -import Pact.Core.Type -import Pact.Core.Imports -import Pact.Core.Hash -import Pact.Core.Guards -import Pact.Core.Capabilities -import Pact.Core.Pretty(Pretty(..), pretty, (<+>)) - -import qualified Pact.Core.Pretty as Pretty -import qualified Pact.Core.IR.Term as IR - -data Defun name builtin info - = Defun - { _dfunName :: Text - , _dfunType :: Type Void - , _dfunTerm :: Term name builtin info - , _dfunInfo :: info - } deriving Show - -data DefConst name builtin info - = DefConst - { _dcName :: Text - , _dcType :: Type Void - , _dcTerm :: Term name builtin info - , _dcInfo :: info - } deriving Show - -data DefCap name builtin info - = DefCap - { _dcapName :: Text - , _dcapAppArity :: Int - , _dcapArgTypes :: [Type Void] - , _dcapRType :: Type Void - , _dcapTerm :: Term name builtin info - , _dcapMeta :: Maybe (DefCapMeta name) - , _dcapInfo :: info - } deriving Show - -data Def name builtin info - = Dfun (Defun name builtin info) - | DConst (DefConst name builtin info) - | DCap (DefCap name builtin info) - deriving Show - --- DCap (DefCap name builtin info) --- DPact (DefPact name builtin info) --- DSchema (DefSchema name info) --- DTable (DefTable name info) - --- Todo: Remove this, not all top level defs have a proper --- associated type, and DCap types are w holly irrelevant, we cannot simply --- call them, they can only be evaluated within `with-capability`. -defType :: Def name builtin info -> TypeOfDef Void -defType = \case - Dfun d -> DefunType (_dfunType d) - DConst d -> DefunType $ _dcType d - DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) - -defName :: Def name builtin i -> Text -defName = \case - Dfun d -> _dfunName d - DConst d -> _dcName d - DCap d -> _dcapName d - -defKind :: Def name builtin i -> DefKind -defKind = \case - Dfun _ -> DKDefun - DConst _ -> DKDefConst - DCap _ -> DKDefCap - -ifDefName :: IfDef name builtin i -> Text -ifDefName = \case - IfDfun ifd -> _ifdName ifd - IfDConst dc -> _dcName dc - IfDCap d -> _ifdcName d - -defTerm :: Def name builtin info -> Term name builtin info -defTerm = \case - Dfun d -> _dfunTerm d - DConst d -> _dcTerm d - DCap d -> _dcapTerm d - -data Module name builtin info - = Module - { _mName :: ModuleName - , _mGovernance :: Governance name - , _mDefs :: [Def name builtin info] - , _mBlessed :: !(Set.Set ModuleHash) - , _mImports :: [Import] - , _mImplements :: [ModuleName] - , _mHash :: ModuleHash - , _mInfo :: info - } deriving Show - -data Interface name builtin info - = Interface - { _ifName :: ModuleName - , _ifDefns :: [IfDef name builtin info] - , _ifHash :: ModuleHash - , _ifInfo :: info - } deriving Show - -data IfDefun info - = IfDefun - { _ifdName :: Text - , _ifdType :: Type Void - , _ifdInfo :: info - } deriving Show - -data IfDefCap info - = IfDefCap - { _ifdcName :: Text - , _ifdcArgTys :: [Type Void] - , _ifdcRType :: Type Void - , _ifdcInfo :: info - } deriving (Show, Functor) - -data IfDef name builtin info - = IfDfun (IfDefun info) - | IfDConst (DefConst name builtin info) - | IfDCap (IfDefCap info) - deriving Show - -data TopLevel name builtin info - = TLModule (Module name builtin info) - | TLInterface (Interface name builtin info) - | TLTerm (Term name builtin info) - deriving Show - -data ReplTopLevel name builtin info - = RTLModule (Module name builtin info) - | RTLInterface (Interface name builtin info) - | RTLDefun (Defun name builtin info) - | RTLDefConst (DefConst name builtin info) - | RTLTerm (Term name builtin info) - deriving Show - --- | Untyped pact core terms -data Term name builtin info - = Var name info - -- ^ single variables, e.g the term `x` - | Lam (Term name builtin info) info - -- ^ f = \a b c -> e - -- All lambdas, even anonymous ones, are named, for the sake of them adding a stack frame - | App (Term name builtin info) (Term name builtin info) info - -- ^ Constant/Literal values - | Sequence (Term name builtin info) (Term name builtin info) info - -- ^ (e_1 e_2 .. e_n) - | Conditional (BuiltinForm (Term name builtin info)) info - -- ^ Special nodes for If, And and Or. - | Builtin builtin info - -- ^ Built-in functions (or natives) - | Constant Literal info - -- ^ ΛX.e - | ListLit [Term name builtin info] info - -- ^ [e_1, e_2, .., e_n] - | Try (Term name builtin info) (Term name builtin info) info - -- ^ try (catch expr) (try-expr) - | DynInvoke (Term name builtin info) Text info - -- ^ dynamic module reference invocation m::f - | CapabilityForm (CapForm name (Term name builtin info)) info - -- ^ Capability - | Error Text info - -- ^ Error catching - deriving (Show, Functor, Foldable, Traversable) - --- Post Typecheck terms + modules -type EvalTerm b i = Term Name b i -type EvalDefConst b i = DefConst Name b i -type EvalDef b i = Def Name b i -type EvalModule b i = Module Name b i -type EvalInterface b i = Interface Name b i - -fromIRTerm :: IR.Term n b i -> Term n b i -fromIRTerm = \case - IR.Var n i -> Var n i - IR.Lam nsts body i -> - foldr (\_ t -> Lam t i) (fromIRTerm body) nsts - IR.Let _ _ e1 e2 i -> - App (Lam (fromIRTerm e2) i) (fromIRTerm e1) i - IR.App fn apps i -> - foldl' (\f arg -> App f (fromIRTerm arg) i) (fromIRTerm fn) apps - IR.Builtin b i -> - Builtin b i - IR.Constant lit i -> - Constant lit i - IR.Sequence e1 e2 i -> - Sequence (fromIRTerm e1) (fromIRTerm e2) i - IR.Conditional c i -> - Conditional (fromIRTerm <$> c) i - IR.ListLit v i -> - ListLit (fromIRTerm <$> v) i - IR.Try e1 e2 i -> - Try (fromIRTerm e1) (fromIRTerm e2) i - IR.DynInvoke n t i -> - DynInvoke (fromIRTerm n) t i - IR.CapabilityForm cf i -> - CapabilityForm (fmap fromIRTerm cf) i - IR.Error e i -> - Error e i - -fromIRDefun - :: IR.Defun name builtin info - -> Defun name builtin info -fromIRDefun (IR.Defun n ty term i) = - Defun n (fmap absurd ty) (fromIRTerm term) i - -fromIRIfDefun :: IR.IfDefun info -> IfDefun info -fromIRIfDefun (IR.IfDefun dfn ty i) = - IfDefun dfn ty i - -fromIRIfDefCap :: IR.IfDefCap info -> IfDefCap info -fromIRIfDefCap (IR.IfDefCap dfn argtys rty i) = - IfDefCap dfn argtys rty i - -fromIRDConst - :: IR.DefConst name builtin info - -> DefConst name builtin info -fromIRDConst (IR.DefConst n ty term i) = - DefConst n (maybe TyUnit (fmap absurd) ty) (fromIRTerm term) i - -fromIRDCap :: IR.DefCap name builtin info -> DefCap name builtin info -fromIRDCap (IR.DefCap name arity argtys rtype body meta i) = - DefCap name arity argtys rtype (fromIRTerm body) meta i - -fromIRDef - :: IR.Def name builtin info - -> Def name builtin info -fromIRDef = \case - IR.Dfun d -> Dfun (fromIRDefun d) - IR.DConst d -> DConst (fromIRDConst d) - IR.DCap d -> DCap (fromIRDCap d) - -fromIRIfDef - :: IR.IfDef name builtin info - -> IfDef name builtin info -fromIRIfDef = \case - IR.IfDfun d -> IfDfun (fromIRIfDefun d) - IR.IfDConst d -> IfDConst (fromIRDConst d) - IR.IfDCap d -> IfDCap (fromIRIfDefCap d) - -fromIRModule - :: IR.Module name builtin info - -> Module name builtin info -fromIRModule (IR.Module mn gov defs blessed imports implements hs i) = - Module mn gov (fromIRDef <$> defs) blessed imports implements hs i - -fromIRInterface - :: IR.Interface name builtin info - -> Interface name builtin info -fromIRInterface (IR.Interface ifn ifdefs ifhash i) = - Interface ifn (fromIRIfDef <$> ifdefs) ifhash i - -fromIRTopLevel - :: IR.TopLevel name builtin info - -> TopLevel name builtin info -fromIRTopLevel = \case - IR.TLModule m -> TLModule (fromIRModule m) - IR.TLInterface iface -> - TLInterface (fromIRInterface iface) - IR.TLTerm e -> TLTerm (fromIRTerm e) - -fromIRReplTopLevel - :: IR.ReplTopLevel name builtin info - -> ReplTopLevel name builtin info -fromIRReplTopLevel = \case - IR.RTLModule m -> RTLModule (fromIRModule m) - IR.RTLInterface iface -> RTLInterface (fromIRInterface iface) - IR.RTLTerm e -> RTLTerm (fromIRTerm e) - IR.RTLDefun df -> RTLDefun (fromIRDefun df) - IR.RTLDefConst dc -> RTLDefConst (fromIRDConst dc) - -findIfDef :: Text -> Interface name builtin info -> Maybe (IfDef name builtin info) -findIfDef f iface = - find ((== f) . ifDefName) (_ifDefns iface) - -instance (Pretty name, Pretty builtin) => Pretty (Term name builtin info) where - pretty = \case - Var n _ -> - pretty n - Lam term _ -> - Pretty.parens ("λ." <> pretty term) - App t1 t2 _ -> - Pretty.parens (Pretty.hsep [pretty t1, pretty t2]) - Builtin b _ -> pretty b - Constant l _ -> pretty l - Sequence e1 e2 _ -> Pretty.parens ("seq" <+> pretty e1 <+> pretty e2) - Conditional c _ -> pretty c - ListLit li _ -> - Pretty.brackets $ - Pretty.hsep $ - Pretty.punctuate Pretty.comma (pretty <$> li) - Try e1 e2 _ -> - Pretty.parens ("try" <+> pretty e1 <+> pretty e2) - DynInvoke n t _ -> - pretty n <> "::" <> pretty t - CapabilityForm _ _ -> error "pretty capform" - Error e _ -> - Pretty.parens ("error \"" <> pretty e <> "\"") - -- ObjectLit (M.toList -> obj) _ -> - -- Pretty.braces $ - -- Pretty.hsep $ - -- Pretty.punctuate Pretty.comma $ - -- fmap (\(f, o) -> pretty f <> ":" <+> pretty o) obj - -- ObjectOp oop _ -> case oop of - -- ObjectAccess fi te -> - -- Pretty.parens $ Pretty.hsep ["@" <> pretty fi, pretty te] - -- ObjectRemove fi te -> - -- Pretty.parens $ Pretty.hsep ["#" <> pretty fi, pretty te] - -- ObjectExtend fi v o -> - -- Pretty.braces $ Pretty.hsep [pretty fi <> ":" <> pretty v, "|", pretty o] - -termInfo :: Lens' (Term name builtin info) info -termInfo f = \case - Var n i -> Var n <$> f i - Lam term i -> Lam term <$> f i - App t1 t2 i -> App t1 t2 <$> f i - Sequence e1 e2 i -> Sequence e1 e2 <$> f i - Conditional c i -> Conditional c <$> f i - ListLit v i -> ListLit v <$> f i - Builtin b i -> Builtin b <$> f i - Constant l i -> Constant l <$> f i - Try e1 e2 i -> - Try e1 e2 <$> f i - DynInvoke n t i -> DynInvoke n t <$> f i - CapabilityForm cf i -> - CapabilityForm cf <$> f i - Error e i -> - Error e <$> f i - -makeLenses ''Module -makeLenses ''Interface -makePrisms ''IfDef diff --git a/typed-core/Pact/Core/Untyped/Utils.hs b/typed-core/Pact/Core/Untyped/Utils.hs deleted file mode 100644 index dd0b0305c..000000000 --- a/typed-core/Pact/Core/Untyped/Utils.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Pact.Core.Untyped.Utils where - -import Data.Foldable(foldl') - -import Pact.Core.Untyped.Term -import qualified Pact.Core.Typed.Term as Typed - -fromTypedTerm :: Typed.Term name tyname b i -> Term name b i -fromTypedTerm = \case - Typed.Var n i -> Var n i - Typed.Lam args body i -> - foldr (\_ t -> Lam t i) (fromTypedTerm body) args - Typed.App fn apps i -> - foldl' (\f arg -> App f (fromTypedTerm arg) i) (fromTypedTerm fn) apps - Typed.Let _ e1 e2 i -> - App (Lam (fromTypedTerm e2) i) (fromTypedTerm e1) i - Typed.Builtin b i -> - Builtin b i - Typed.Constant lit i -> - Constant lit i - Typed.TyApp te _ _ -> - fromTypedTerm te - Typed.TyAbs _ term _ -> - fromTypedTerm term - Typed.Sequence e1 e2 i -> - Sequence (fromTypedTerm e1) (fromTypedTerm e2) i - Typed.Conditional c i -> - Conditional (fromTypedTerm <$> c) i - Typed.ListLit _ vec i -> - ListLit (fromTypedTerm <$> vec) i - Typed.Try e1 e2 i -> - Try (fromTypedTerm e1) (fromTypedTerm e2) i - Typed.DynInvoke term t i -> - DynInvoke (fromTypedTerm term) t i - Typed.CapabilityForm cf i -> - CapabilityForm (fromTypedTerm <$> cf) i - Typed.Error _ e i -> Error e i - -- Typed.ObjectLit m i -> - -- ObjectLit (fromTypedTerm <$> m) i - -- Typed.ObjectOp oo i -> - -- ObjectOp (fromTypedTerm <$> oo) i - - -fromTypedDefun - :: Typed.Defun name tyname builtin info - -> Defun name builtin info -fromTypedDefun (Typed.Defun n ty term i) = - Defun n ty (fromTypedTerm term) i - -fromTypedIfDefun - :: Typed.IfDefun info - -> IfDefun info -fromTypedIfDefun (Typed.IfDefun n ty i) = - IfDefun n ty i - -fromTypedIfDefCap - :: Typed.IfDefCap info - -> IfDefCap info -fromTypedIfDefCap (Typed.IfDefCap n argtys ty i) = - IfDefCap n argtys ty i - -fromTypedDConst - :: Typed.DefConst name tyname builtin info - -> DefConst name builtin info -fromTypedDConst (Typed.DefConst n ty term i) = - DefConst n ty (fromTypedTerm term) i - -fromTypedDCap - :: Typed.DefCap name tyname builtin info - -> DefCap name builtin info -fromTypedDCap (Typed.DefCap name appArity argTys rty term meta i) = - DefCap name appArity argTys rty (fromTypedTerm term) meta i - -fromTypedDef - :: Typed.Def name tyname builtin info - -> Def name builtin info -fromTypedDef = \case - Typed.Dfun d -> Dfun (fromTypedDefun d) - Typed.DConst d -> DConst (fromTypedDConst d) - Typed.DCap d -> DCap (fromTypedDCap d) - -fromTypedIfDef - :: Typed.IfDef name tyname builtin info - -> IfDef name builtin info -fromTypedIfDef = \case - Typed.IfDfun d -> IfDfun (fromTypedIfDefun d) - Typed.IfDConst d -> - IfDConst (fromTypedDConst d) - Typed.IfDCap d -> - IfDCap (fromTypedIfDefCap d) - -fromTypedModule - :: Typed.Module name tyname builtin info - -> Module name builtin info -fromTypedModule (Typed.Module mn mgov defs blessed imports implements hs i) = - Module mn mgov (fromTypedDef <$> defs) blessed imports implements hs i - -fromTypedInterface - :: Typed.Interface name tyname builtin info - -> Interface name builtin info -fromTypedInterface (Typed.Interface ifname ifdefs ifh i) = - Interface ifname (fromTypedIfDef <$> ifdefs) ifh i - -fromTypedTopLevel - :: Typed.TopLevel name tyname builtin info - -> TopLevel name builtin info -fromTypedTopLevel = \case - Typed.TLModule m -> - TLModule (fromTypedModule m) - Typed.TLInterface iface -> - TLInterface (fromTypedInterface iface) - Typed.TLTerm e -> - TLTerm (fromTypedTerm e) - -fromTypedReplTopLevel - :: Typed.ReplTopLevel name tyname builtin info - -> ReplTopLevel name builtin info -fromTypedReplTopLevel = \case - Typed.RTLModule m -> - RTLModule (fromTypedModule m) - Typed.RTLDefun de -> - RTLDefun (fromTypedDefun de) - Typed.RTLDefConst dc -> - RTLDefConst (fromTypedDConst dc) - Typed.RTLTerm te -> - RTLTerm (fromTypedTerm te) - Typed.RTLInterface i -> - RTLInterface (fromTypedInterface i)