From 04eece14154e72caee181d0d269cf16521ebd3fa Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Tue, 28 Nov 2023 19:00:37 -0500 Subject: [PATCH 01/44] flake --- flake.nix | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 flake.nix diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..a1b9de74 --- /dev/null +++ b/flake.nix @@ -0,0 +1,41 @@ +{ + description = "A very basic flake"; + inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; + inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + inputs.flake-utils.url = "github:numtide/flake-utils"; + outputs = { self, nixpkgs, flake-utils, haskellNix }: + flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: + let + overlays = [ haskellNix.overlay + (final: prev: { + # This overlay adds our project to pkgs + helloProject = + final.haskell-nix.project' { + src = ./.; + compiler-nix-name = "ghc925"; + # This is used by `nix develop .` to open a shell for use with + # `cabal`, `hlint` and `haskell-language-server` + shell.tools = { + cabal = {}; + hlint = {}; + haskell-language-server = {}; + }; + # Non-Haskell shell tools go here + shell.buildInputs = with pkgs; [ + nixpkgs-fmt + ]; + # This adds `js-unknown-ghcjs-cabal` to the shell. + # shell.crossPlatforms = p: [p.ghcjs]; + }; + }) + ]; + pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; + flake = pkgs.helloProject.flake { + # This adds support for `nix build .#js-unknown-ghcjs:hello:exe:hello` + # crossPlatforms = p: [p.ghcjs]; + }; + in flake // { + # Built by `nix build .` + packages.default = flake.packages."purescript:exe:purs"; + }); +} From c6c8930b623c47dd44ee4fed345e0695aa0fd8df Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Tue, 28 Nov 2023 20:11:40 -0500 Subject: [PATCH 02/44] shell --- cabal.project | 12 + flake.lock | 640 +++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 13 +- purescript.cabal | 4 +- shell.nix | 18 ++ 5 files changed, 682 insertions(+), 5 deletions(-) create mode 100644 flake.lock create mode 100644 shell.nix diff --git a/cabal.project b/cabal.project index 51c7ecb8..9ec59cd0 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,14 @@ +repository cardano-haskell-packages + url: https://github.com/input-output-hk/cardano-haskell-packages + secure: True + root-keys: + 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f + 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 + a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 + bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 + c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 + d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee + + packages: purescript.cabal diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..8e489dd3 --- /dev/null +++ b/flake.lock @@ -0,0 +1,640 @@ +{ + "nodes": { + "CHaP": { + "flake": false, + "locked": { + "lastModified": 1701085773, + "narHash": "sha256-R4931htVMyz67VAOrnucHwJqg9pg7ugQ6Us2gIpeD8A=", + "owner": "input-output-hk", + "repo": "cardano-haskell-packages", + "rev": "cb16e4a295c594cd1d5f02008e4dd03eb6061d25", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "repo", + "repo": "cardano-haskell-packages", + "type": "github" + } + }, + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc98X": { + "flake": false, + "locked": { + "lastModified": 1696643148, + "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", + "ref": "ghc-9.8", + "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", + "revCount": 61642, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "ref": "ghc-9.8", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc99": { + "flake": false, + "locked": { + "lastModified": 1697054644, + "narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=", + "ref": "refs/heads/master", + "rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a", + "revCount": 62040, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1701130974, + "narHash": "sha256-0ykM3chRG8TXHhfEytU1IerNq5vN5rluaOnLNCJUZ6s=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "618294813c33cc6c8b98c1ec5570bc48864b13ec", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc98X": "ghc98X", + "ghc99": "ghc99", + "hackage": "hackage", + "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", + "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", + "iserv-proxy": "iserv-proxy", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "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" + }, + "locked": { + "lastModified": 1701213767, + "narHash": "sha256-zELQxq+2PpzVFaimtoS82MxEdsUiIiThxzjGAqNLYYE=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "9392cb0472e6d40eb56dc90a3a8df8c49ff7e6c5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hls-1.10": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "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" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1696939266, + "narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "362fdd1293efb4b82410b676ab1273479f6d17ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskellNix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1691634696, + "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", + "ref": "hkm/remote-iserv", + "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", + "revCount": 14, + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + }, + "original": { + "ref": "hkm/remote-iserv", + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + } + }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1661606874, + "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", + "owner": "NixOS", + "repo": "nix", + "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.11.0", + "repo": "nix", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1657693803, + "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-22.05-small", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1659914493, + "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1659446231, + "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2205": { + "locked": { + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2211": { + "locked": { + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1695416179, + "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "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": { + "locked": { + "lastModified": 1695318763, + "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "root": { + "inputs": { + "CHaP": "CHaP", + "flake-utils": "flake-utils", + "haskellNix": "haskellNix", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ] + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1701130167, + "narHash": "sha256-Mdzljtmfe6lg8lo7BAMXPRay0fH17MVoBQJBPzt3s+w=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "4396102706df8636afae08806984e03f4afd381e", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix index a1b9de74..9e749c96 100644 --- a/flake.nix +++ b/flake.nix @@ -3,16 +3,20 @@ inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; inputs.flake-utils.url = "github:numtide/flake-utils"; - outputs = { self, nixpkgs, flake-utils, haskellNix }: + inputs.CHaP = { + url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; + flake = false; + }; + outputs = { self, nixpkgs, flake-utils, haskellNix, CHaP }: flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: let overlays = [ haskellNix.overlay (final: prev: { # This overlay adds our project to pkgs helloProject = - final.haskell-nix.project' { + final.haskell-nix.cabalProject { src = ./.; - compiler-nix-name = "ghc925"; + compiler-nix-name = "ghc924"; # This is used by `nix develop .` to open a shell for use with # `cabal`, `hlint` and `haskell-language-server` shell.tools = { @@ -26,13 +30,14 @@ ]; # This adds `js-unknown-ghcjs-cabal` to the shell. # shell.crossPlatforms = p: [p.ghcjs]; + inputMap = { "https://input-output-hk.github.io/cardano-haskell-packages" = CHaP; }; }; }) ]; pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; flake = pkgs.helloProject.flake { # This adds support for `nix build .#js-unknown-ghcjs:hello:exe:hello` - # crossPlatforms = p: [p.ghcjs]; + # crossPlatforms = p: [p.ghcjs;] }; in flake // { # Built by `nix build .` diff --git a/purescript.cabal b/purescript.cabal index a608c61c..f3835964 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -208,7 +208,9 @@ common defaults transformers-base >=0.4.6 && <0.5, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, - witherable >=0.4.2 && <0.5 + witherable >=0.4.2 && <0.5, + + plutus-core library import: defaults diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000..637c3650 --- /dev/null +++ b/shell.nix @@ -0,0 +1,18 @@ +with (import {}); +mkShell { + buildInputs = [ + cabal-install + haskell-language-server + haskell.compiler.ghc924 + zlib + libsodium + secp256k1 + ]; + + shelHook = '' + export PKG_CONFIG_PATH=/usr/lib/pkgconfig:/usr/share/pkgconfig:/usr/local/lib/pkgconfig + export PKG_CONFIG_PATH=/usr/share/pkgconfig:$PKG_CONFIG_PATH + export PKG_CONFIG_PATH=/usr/local/lib/pkgconfig:$PKG_CONFIG_PATH + export LC_ALL=C.utf8 + ''; +} From 3e3562c981069f3c9dcc95899aa060a932feb829 Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Wed, 29 Nov 2023 19:38:00 -0500 Subject: [PATCH 03/44] Added uplc command line option for , pulled in plutus-core dep from CHaP, added basic nix shell with build deps & locale config, placeholder UPLC codegen module & functions. You almost certainly need the hie.yaml and .envrc to work on this so I committed those intentionally. --- .envrc | 1 + cabal.project | 2 +- flake.lock | 640 ------------------------ flake.nix | 46 -- hie.yaml | 43 ++ purescript.cabal | 5 +- shell.nix | 19 +- src/Language/PureScript/CodeGen/UPLC.hs | 31 ++ src/Language/PureScript/Make/Actions.hs | 4 + src/Language/PureScript/Options.hs | 3 +- 10 files changed, 96 insertions(+), 698 deletions(-) create mode 100644 .envrc delete mode 100644 flake.lock delete mode 100644 flake.nix create mode 100644 hie.yaml create mode 100644 src/Language/PureScript/CodeGen/UPLC.hs diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..1d953f4b --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use nix diff --git a/cabal.project b/cabal.project index 9ec59cd0..aa859b8b 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ repository cardano-haskell-packages - url: https://github.com/input-output-hk/cardano-haskell-packages + url: https://input-output-hk.github.io/cardano-haskell-packages secure: True root-keys: 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f diff --git a/flake.lock b/flake.lock deleted file mode 100644 index 8e489dd3..00000000 --- a/flake.lock +++ /dev/null @@ -1,640 +0,0 @@ -{ - "nodes": { - "CHaP": { - "flake": false, - "locked": { - "lastModified": 1701085773, - "narHash": "sha256-R4931htVMyz67VAOrnucHwJqg9pg7ugQ6Us2gIpeD8A=", - "owner": "input-output-hk", - "repo": "cardano-haskell-packages", - "rev": "cb16e4a295c594cd1d5f02008e4dd03eb6061d25", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "repo", - "repo": "cardano-haskell-packages", - "type": "github" - } - }, - "HTTP": { - "flake": false, - "locked": { - "lastModified": 1451647621, - "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", - "owner": "phadej", - "repo": "HTTP", - "rev": "9bc0996d412fef1787449d841277ef663ad9a915", - "type": "github" - }, - "original": { - "owner": "phadej", - "repo": "HTTP", - "type": "github" - } - }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, - "cabal-34": { - "flake": false, - "locked": { - "lastModified": 1645834128, - "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", - "owner": "haskell", - "repo": "cabal", - "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.4", - "repo": "cabal", - "type": "github" - } - }, - "cabal-36": { - "flake": false, - "locked": { - "lastModified": 1669081697, - "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", - "owner": "haskell", - "repo": "cabal", - "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.6", - "repo": "cabal", - "type": "github" - } - }, - "cardano-shell": { - "flake": false, - "locked": { - "lastModified": 1608537748, - "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", - "owner": "input-output-hk", - "repo": "cardano-shell", - "rev": "9392c75087cb9a3d453998f4230930dea3a95725", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "cardano-shell", - "type": "github" - } - }, - "flake-compat": { - "flake": false, - "locked": { - "lastModified": 1672831974, - "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", - "owner": "input-output-hk", - "repo": "flake-compat", - "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "hkm/gitlab-fix", - "repo": "flake-compat", - "type": "github" - } - }, - "flake-utils": { - "inputs": { - "systems": "systems" - }, - "locked": { - "lastModified": 1694529238, - "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "ghc-8.6.5-iohk": { - "flake": false, - "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", - "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", - "type": "github" - } - }, - "ghc98X": { - "flake": false, - "locked": { - "lastModified": 1696643148, - "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", - "ref": "ghc-9.8", - "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", - "revCount": 61642, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "ref": "ghc-9.8", - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, - "ghc99": { - "flake": false, - "locked": { - "lastModified": 1697054644, - "narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=", - "ref": "refs/heads/master", - "rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a", - "revCount": 62040, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, - "hackage": { - "flake": false, - "locked": { - "lastModified": 1701130974, - "narHash": "sha256-0ykM3chRG8TXHhfEytU1IerNq5vN5rluaOnLNCJUZ6s=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "618294813c33cc6c8b98c1ec5570bc48864b13ec", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "hackage.nix", - "type": "github" - } - }, - "haskellNix": { - "inputs": { - "HTTP": "HTTP", - "cabal-32": "cabal-32", - "cabal-34": "cabal-34", - "cabal-36": "cabal-36", - "cardano-shell": "cardano-shell", - "flake-compat": "flake-compat", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc98X": "ghc98X", - "ghc99": "ghc99", - "hackage": "hackage", - "hls-1.10": "hls-1.10", - "hls-2.0": "hls-2.0", - "hls-2.2": "hls-2.2", - "hls-2.3": "hls-2.3", - "hls-2.4": "hls-2.4", - "hpc-coveralls": "hpc-coveralls", - "hydra": "hydra", - "iserv-proxy": "iserv-proxy", - "nixpkgs": [ - "haskellNix", - "nixpkgs-unstable" - ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2105": "nixpkgs-2105", - "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" - }, - "locked": { - "lastModified": 1701213767, - "narHash": "sha256-zELQxq+2PpzVFaimtoS82MxEdsUiIiThxzjGAqNLYYE=", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "9392cb0472e6d40eb56dc90a3a8df8c49ff7e6c5", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "haskell.nix", - "type": "github" - } - }, - "hls-1.10": { - "flake": false, - "locked": { - "lastModified": 1680000865, - "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "1.10.0.0", - "repo": "haskell-language-server", - "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" - } - }, - "hls-2.2": { - "flake": false, - "locked": { - "lastModified": 1693064058, - "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.2.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-2.3": { - "flake": false, - "locked": { - "lastModified": 1695910642, - "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.3.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-2.4": { - "flake": false, - "locked": { - "lastModified": 1696939266, - "narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "362fdd1293efb4b82410b676ab1273479f6d17ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.4.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hpc-coveralls": { - "flake": false, - "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", - "type": "github" - }, - "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "type": "github" - } - }, - "hydra": { - "inputs": { - "nix": "nix", - "nixpkgs": [ - "haskellNix", - "hydra", - "nix", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1671755331, - "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", - "owner": "NixOS", - "repo": "hydra", - "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", - "type": "github" - }, - "original": { - "id": "hydra", - "type": "indirect" - } - }, - "iserv-proxy": { - "flake": false, - "locked": { - "lastModified": 1691634696, - "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", - "ref": "hkm/remote-iserv", - "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", - "revCount": 14, - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - }, - "original": { - "ref": "hkm/remote-iserv", - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - } - }, - "lowdown-src": { - "flake": false, - "locked": { - "lastModified": 1633514407, - "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", - "owner": "kristapsdz", - "repo": "lowdown", - "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", - "type": "github" - }, - "original": { - "owner": "kristapsdz", - "repo": "lowdown", - "type": "github" - } - }, - "nix": { - "inputs": { - "lowdown-src": "lowdown-src", - "nixpkgs": "nixpkgs", - "nixpkgs-regression": "nixpkgs-regression" - }, - "locked": { - "lastModified": 1661606874, - "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", - "owner": "NixOS", - "repo": "nix", - "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "2.11.0", - "repo": "nix", - "type": "github" - } - }, - "nixpkgs": { - "locked": { - "lastModified": 1657693803, - "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-22.05-small", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2003": { - "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2105": { - "locked": { - "lastModified": 1659914493, - "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2111": { - "locked": { - "lastModified": 1659446231, - "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2205": { - "locked": { - "lastModified": 1685573264, - "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "380be19fbd2d9079f677978361792cb25e8a3635", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2211": { - "locked": { - "lastModified": 1688392541, - "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2305": { - "locked": { - "lastModified": 1695416179, - "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-23.05-darwin", - "repo": "nixpkgs", - "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": { - "locked": { - "lastModified": 1695318763, - "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "old-ghc-nix": { - "flake": false, - "locked": { - "lastModified": 1631092763, - "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", - "owner": "angerman", - "repo": "old-ghc-nix", - "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", - "type": "github" - }, - "original": { - "owner": "angerman", - "ref": "master", - "repo": "old-ghc-nix", - "type": "github" - } - }, - "root": { - "inputs": { - "CHaP": "CHaP", - "flake-utils": "flake-utils", - "haskellNix": "haskellNix", - "nixpkgs": [ - "haskellNix", - "nixpkgs-unstable" - ] - } - }, - "stackage": { - "flake": false, - "locked": { - "lastModified": 1701130167, - "narHash": "sha256-Mdzljtmfe6lg8lo7BAMXPRay0fH17MVoBQJBPzt3s+w=", - "owner": "input-output-hk", - "repo": "stackage.nix", - "rev": "4396102706df8636afae08806984e03f4afd381e", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "stackage.nix", - "type": "github" - } - }, - "systems": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } - } - }, - "root": "root", - "version": 7 -} diff --git a/flake.nix b/flake.nix deleted file mode 100644 index 9e749c96..00000000 --- a/flake.nix +++ /dev/null @@ -1,46 +0,0 @@ -{ - description = "A very basic flake"; - inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; - inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; - inputs.flake-utils.url = "github:numtide/flake-utils"; - inputs.CHaP = { - url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; - flake = false; - }; - outputs = { self, nixpkgs, flake-utils, haskellNix, CHaP }: - flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: - let - overlays = [ haskellNix.overlay - (final: prev: { - # This overlay adds our project to pkgs - helloProject = - final.haskell-nix.cabalProject { - src = ./.; - compiler-nix-name = "ghc924"; - # This is used by `nix develop .` to open a shell for use with - # `cabal`, `hlint` and `haskell-language-server` - shell.tools = { - cabal = {}; - hlint = {}; - haskell-language-server = {}; - }; - # Non-Haskell shell tools go here - shell.buildInputs = with pkgs; [ - nixpkgs-fmt - ]; - # This adds `js-unknown-ghcjs-cabal` to the shell. - # shell.crossPlatforms = p: [p.ghcjs]; - inputMap = { "https://input-output-hk.github.io/cardano-haskell-packages" = CHaP; }; - }; - }) - ]; - pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; - flake = pkgs.helloProject.flake { - # This adds support for `nix build .#js-unknown-ghcjs:hello:exe:hello` - # crossPlatforms = p: [p.ghcjs;] - }; - in flake // { - # Built by `nix build .` - packages.default = flake.packages."purescript:exe:purs"; - }); -} diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 00000000..39760416 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,43 @@ +cradle: + cabal: + - path: "src" + component: "lib:purescript" + + - path: "app/Main.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Bundle.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Compile.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Docs.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Docs/Html.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Docs/Markdown.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Graph.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Hierarchy.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Ide.hs" + component: "purescript:exe:purs" + + - path: "app/Command/Publish.hs" + component: "purescript:exe:purs" + + - path: "app/Command/REPL.hs" + component: "purescript:exe:purs" + + - path: "app/Version.hs" + component: "purescript:exe:purs" + + - path: "tests" + component: "purescript:test:tests" diff --git a/purescript.cabal b/purescript.cabal index f3835964..49d52279 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -157,7 +157,7 @@ common defaults aeson-better-errors >=0.9.1.1 && <0.10, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, - base >=4.16.2.0 && <4.17, + base >=4.16.2.0 && <4.18, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, @@ -201,7 +201,7 @@ common defaults stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, template-haskell >=2.18.0.0 && <2.19, - text >=1.2.5.0 && <1.3, + text >=1.2.5.0 && <2.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, @@ -232,6 +232,7 @@ library Language.PureScript.AST.Utils Language.PureScript.Bundle Language.PureScript.CodeGen + Language.PureScript.CodeGen.UPLC Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.Common Language.PureScript.CodeGen.JS.Printer diff --git a/shell.nix b/shell.nix index 637c3650..7e50545d 100644 --- a/shell.nix +++ b/shell.nix @@ -1,18 +1,21 @@ with (import {}); -mkShell { - buildInputs = [ +let haskell928 = haskell.packages.ghc928; + ghc928 = haskell.compiler.ghc928; +in mkShell { + nativeBuildInputs = [ + pkg-config + haskell928.haskell-language-server + ghc928 cabal-install - haskell-language-server - haskell.compiler.ghc924 + ]; + + buildInputs = [ zlib libsodium secp256k1 ]; - shelHook = '' - export PKG_CONFIG_PATH=/usr/lib/pkgconfig:/usr/share/pkgconfig:/usr/local/lib/pkgconfig - export PKG_CONFIG_PATH=/usr/share/pkgconfig:$PKG_CONFIG_PATH - export PKG_CONFIG_PATH=/usr/local/lib/pkgconfig:$PKG_CONFIG_PATH + shellHook = '' export LC_ALL=C.utf8 ''; } diff --git a/src/Language/PureScript/CodeGen/UPLC.hs b/src/Language/PureScript/CodeGen/UPLC.hs new file mode 100644 index 00000000..e0618a8d --- /dev/null +++ b/src/Language/PureScript/CodeGen/UPLC.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +module Language.PureScript.CodeGen.UPLC (moduleToUPLC, printUPLC) where + +import Prelude ((.), ($)) +import Protolude (print) +import Protolude.Error (error) + +import Control.Monad.Except (MonadError) +import Control.Monad.Reader (MonadReader) +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.IO.Class (MonadIO (liftIO)) + +import Language.PureScript.CoreFn (Ann, Module(..)) +import Language.PureScript.Errors (MultipleErrors(..)) +import Language.PureScript.Options (Options(..)) + + +import UntypedPlutusCore + ( DeBruijn, DefaultFun, DefaultUni, Program ) +import PlutusCore.Pretty ( prettyPlcReadableDef ) + +-- Stolen from Ply, not 100% sure if this is what we want, i.e. maybe there should be an annotation? +type UPLCProgram = Program DeBruijn DefaultUni DefaultFun () + +moduleToUPLC :: forall m + . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) + => Module Ann -> m UPLCProgram +moduleToUPLC = error "Error: UPLC Backend not yet implemented!" + +printUPLC :: forall m. MonadIO m => UPLCProgram -> m () +printUPLC program = liftIO . print $ prettyPlcReadableDef program diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f138327c..1cca61b2 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -38,6 +38,7 @@ import Language.PureScript.AST (SourcePos(..)) import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.CodeGen.JS qualified as J import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps) +import Language.PureScript.CodeGen.UPLC qualified as PC import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.ToJSON qualified as CFJ import Language.PureScript.Crash (internalError) @@ -277,6 +278,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings when (S.member Docs codegenTargets) $ do lift $ writeJSONFile (outputFilename mn "docs.json") docs + when (S.member UPLC codegenTargets) $ do + uplc <- PC.moduleToUPLC m + lift $ PC.printUPLC uplc ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index d94d344c..f3a50d86 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -20,12 +20,13 @@ data Options = Options defaultOptions :: Options defaultOptions = Options False False (S.singleton JS) -data CodegenTarget = JS | JSSourceMap | CoreFn | Docs +data CodegenTarget = JS | JSSourceMap | CoreFn | Docs | UPLC deriving (Eq, Ord, Show) codegenTargets :: Map String CodegenTarget codegenTargets = Map.fromList [ ("js", JS) + , ("uplc", UPLC) , ("sourcemaps", JSSourceMap) , ("corefn", CoreFn) , ("docs", Docs) From 99c51cb989981280b381b87cd9da68562bf45391 Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Thu, 30 Nov 2023 17:31:08 -0500 Subject: [PATCH 04/44] PlutusIR dependency sorted out --- purescript.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 49d52279..60a664b7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. @@ -34,7 +34,7 @@ extra-source-files: tests/support/pscide/src/**/*.purs tests/support/pscide/src/**/*.js tests/support/pscide/src/**/*.fail - stack.yaml + -- stack.yaml README.md INSTALL.md CONTRIBUTORS.md @@ -209,8 +209,8 @@ common defaults utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, witherable >=0.4.2 && <0.5, - - plutus-core + plutus-core, + plutus-core:plutus-ir library import: defaults From 75012d16984ef9acc97edb6851414e650cd63a7e Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Wed, 6 Dec 2023 02:59:43 -0500 Subject: [PATCH 05/44] Typed CoreFn conversion & pretty printer (messy) --- purescript.cabal | 2 + src/Language/PureScript/CodeGen/UPLC.hs | 141 ++++- src/Language/PureScript/CoreFn/Typed.hs | 500 ++++++++++++++++++ .../PureScript/CoreFn/Typed/Pretty.hs | 199 +++++++ src/Language/PureScript/Environment.hs | 14 +- src/Language/PureScript/Make.hs | 11 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 1 + src/Language/PureScript/TypeChecker/Monad.hs | 18 +- src/Language/PureScript/TypeChecker/Types.hs | 12 + 10 files changed, 878 insertions(+), 22 deletions(-) create mode 100644 src/Language/PureScript/CoreFn/Typed.hs create mode 100644 src/Language/PureScript/CoreFn/Typed/Pretty.hs diff --git a/purescript.cabal b/purescript.cabal index 60a664b7..178e0931 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -250,6 +250,8 @@ library Language.PureScript.CoreFn.Optimizer Language.PureScript.CoreFn.ToJSON Language.PureScript.CoreFn.Traversals + Language.PureScript.CoreFn.Typed + Language.PureScript.CoreFn.Typed.Pretty Language.PureScript.CoreImp Language.PureScript.CoreImp.AST Language.PureScript.CoreImp.Module diff --git a/src/Language/PureScript/CodeGen/UPLC.hs b/src/Language/PureScript/CodeGen/UPLC.hs index e0618a8d..a993c358 100644 --- a/src/Language/PureScript/CodeGen/UPLC.hs +++ b/src/Language/PureScript/CodeGen/UPLC.hs @@ -1,8 +1,19 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module Language.PureScript.CodeGen.UPLC (moduleToUPLC, printUPLC) where +{-# LANGUAGE TypeApplications #-} +module Language.PureScript.CodeGen.UPLC where import Prelude ((.), ($)) -import Protolude (print) +import Protolude + ( ($), + Monad, + Maybe, + (.), + MonadError, + MonadIO(..), + print, + undefined, + MonadReader, + MonadState, (<$>) ) import Protolude.Error (error) import Control.Monad.Except (MonadError) @@ -10,22 +21,134 @@ import Control.Monad.Reader (MonadReader) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Language.PureScript.CoreFn (Ann, Module(..)) +import Language.PureScript.AST qualified as AST +import Language.PureScript.CoreFn (Ann, Module(..), Expr(..), Literal(..), Meta) import Language.PureScript.Errors (MultipleErrors(..)) import Language.PureScript.Options (Options(..)) - -import UntypedPlutusCore - ( DeBruijn, DefaultFun, DefaultUni, Program ) import PlutusCore.Pretty ( prettyPlcReadableDef ) +import PlutusCore (someValue) +import Data.String (IsString(fromString)) +import Language.PureScript.Names (Ident(..)) +import Language.PureScript.Types qualified as T +import Language.PureScript.TypeChecker.Types (infer) +import PlutusCore qualified as PLC +import PlutusIR qualified as PIR +import Language.PureScript.TypeChecker (CheckState) +import Control.Monad.Writer.Class (MonadWriter) +import Language.PureScript.Comments (Comment) +import Language.PureScript.Types (SourceType) -- Stolen from Ply, not 100% sure if this is what we want, i.e. maybe there should be an annotation? -type UPLCProgram = Program DeBruijn DefaultUni DefaultFun () +type PIRProgram = PIR.Program PLC.TyName PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun () + +type PIRTerm ann = PIR.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ann + +sourceSpan :: Ann -> AST.SourceSpan +sourceSpan (x,_,_) = x + +comments :: Ann -> [Comment] +comments (_,x,_) = x + +meta :: Ann -> Maybe Meta +meta (_,_,x) = x moduleToUPLC :: forall m . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) - => Module Ann -> m UPLCProgram + => Module Ann -> m PIRProgram moduleToUPLC = error "Error: UPLC Backend not yet implemented!" -printUPLC :: forall m. MonadIO m => UPLCProgram -> m () + + +type M m = (Monad m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +{- +transformExpr :: forall m b + . M m + => Expr Ann + -> m (Expr (SourceType,Ann)) +transformExpr = \case + Literal ann cfnLit -> case cfnLit of + NumericLiteral x -> do + TypedValue' <- infer $ AST.Literal (sourceSpan ann) $ NumericLiteral x + pure $ Literal + StringLiteral psString -> f ann $ AST.Literal (sourceSpan ann) $ StringLiteral psString + CharLiteral c -> f ann $ AST.Literal (sourceSpan ann) $ CharLiteral c + BooleanLiteral b -> f ann $ AST.Literal (sourceSpan ann) $ BooleanLiteral b + ArrayLiteral xs -> Literal $ ArrayLiteral $ foldExpr f <$> xs + + Constructor ann tyName ctorName fields -> undefined + Accessor ann l t -> undefined + ObjectUpdate a orig copyFields updateFields -> undefined + Abs ann identifier body -> undefined + App ann e1 e2 -> undefined + Var ann qualIdent -> undefined + Case ann es alts -> undefined + Let ann binds expr -> undefined +-} + +inferExprTypes :: forall m a + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr a + -> m (Expr (T.Type a)) +inferExprTypes = \case + _ -> undefined + +{-| nil = constr 0 [] + cons x xs = constr 1 x xs + +sopList :: forall name ann. ann -> [PIRTerm ann] -> PIRTerm ann +sopList ann = \case -- ann is the default annotation for an empty list + [] -> PIR.Constr ann 0 [] + (x:xs) -> PIR.Constr ann 1 [x,sopList ann xs] + + + +exprToTerm :: forall m ann + . (MonadReader Options m, + MonadSupply m, + MonadError MultipleErrors m, + Monoid ann + ) => Expr ann -> m (PIRTerm ann) +exprToTerm = \case + Literal ann lit -> litToTerm ann lit + Constructor ann tyName ctorName identifiers -> undefined + Accessor ann label expr -> undefined + ObjectUpdate ann expr copyFields updateFields -> undefined + Abs ann identifier expr -> do + name <- identifierToName identifier + body <- exprToTerm expr + pure $PIR.LamAbs ann name body + App ann e1 e2 -> undefined + Var ann qIdentifier -> undefined + Case ann es cas -> undefined + Let ann binds expr -> undefined + where + identifierToName :: Ident -> m PIR.Name + identifierToName = \case + GenIdent (Just nm) i -> pure $ PIR.Name nm (PLC.Unique $ fromIntegral i) + _ -> error "WIP" + + litToTerm :: ann -> Literal (Expr ann) -> m (PIRTerm ann) + litToTerm a = \case + NumericLiteral (Left integer) -> pure $ PIR.Constant a (someValue integer) + NumericLiteral (Right _double) -> error "Figure out what to do w/ Doubles" + StringLiteral psString -> do + let bs :: ByteString = fromString (show psString) + pure $ PIR.Constant a (someValue bs) + CharLiteral _char -> error "Figure out what to do with Chars" + BooleanLiteral boolean -> pure $ PIR.Constant a (someValue boolean) + ArrayLiteral array -> sopList mempty <$> traverse exprToTerm array + {- ObjectLiterals, aka Record literals, get represented onchain as products with field order determined by lexicographic sorting of the labels. + -} + ObjectLiteral fields -> do + let sorted = map snd . sortOn fst $ fields -- these are probably already sorted somewhere, but not 100% sure + terms <- traverse exprToTerm sorted + pure $ PIR.Constr a 0 terms -- the evaluator should use 0 based indices? i hope? + +-} + + + + +printUPLC :: forall m. MonadIO m => PIRProgram -> m () printUPLC program = liftIO . print $ prettyPlcReadableDef program diff --git a/src/Language/PureScript/CoreFn/Typed.hs b/src/Language/PureScript/CoreFn/Typed.hs new file mode 100644 index 00000000..dcb71b32 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Typed.hs @@ -0,0 +1,500 @@ +{- This module is a part of a hack intended to solve a problem arising from the structure of the PS compiler pipeline: + - We need CoreFn `Expr (Type Ann)` which contains annotates AST nodes with inferred type information + - PS performs typechecking on the Language.PureScript.AST Expr type, which we don't have access to in the `codegen` function part of the pipeline + - We need to modify the AST -> CoreFn desguaring phase so that it annotates the AST w/ type information + - The most sensible way to do that is to do inference & conversion all at once during typechecking + - We can't do that without disassembling the `moduleToCoreFn` function from the Desugar module + +This is a very rough draft ATM. In a more polished version these should all be rewritten to `Reader Env (...)` functions + +-} + +module Language.PureScript.CoreFn.Typed (moduleToCoreFn, forgetNonTypes) where + +import Prelude +import Protolude (ordNub, orEmpty, Bifunctor (first)) + +import Control.Arrow (second) + +import Data.Function (on) +import Data.Maybe (mapMaybe) +import Data.Tuple (swap) +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M + +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.Traversals (everythingOnValues) +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreFn.Ann (Ann, ssAnn) +import Language.PureScript.CoreFn.Binders (Binder(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, extractAnn) +import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) +import Language.PureScript.CoreFn.Module (Module(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, function, NameVisibility (..), tyBoolean) +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, mkQualified) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) +import Language.PureScript.AST qualified as A +import Language.PureScript.Constants.Prim qualified as C +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.State.Strict (MonadState, gets, modify) +import Control.Monad.Writer.Class +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, unsafeCheckCurrentModule, makeBindingGroupVisible) +import Control.Monad.Error (MonadError) +import Language.PureScript.TypeChecker.Types +import Data.List.NonEmpty qualified as NE +import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) +import Control.Monad (forM, (<=<)) +import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) +import Language.PureScript.Errors (MultipleErrors, parU) +import Language.PureScript.TypeChecker.Monad (CheckState(CheckState)) +import Language.PureScript.AST.SourcePos (nullSourceAnn, pattern NullSourceAnn) +import Debug.Trace (traceM) +import Language.PureScript.Pretty.Types +type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + +type TypeAnn = (SourceType,Ann) + +forgetSourceAnn :: TypeAnn -> Type () +forgetSourceAnn (ty,_) = (const ()) <$> ty + +forgetSourceAnnBindings :: Bind TypeAnn -> Bind (Type ()) +forgetSourceAnnBindings = \case + NonRec ann _id exp -> NonRec (forgetSourceAnn ann) _id (forgetSourceAnn <$> exp) + Rec bs -> Rec $ flip map bs $ \((ann,_id),exp) -> ((forgetSourceAnn ann,_id),forgetSourceAnn <$> exp) + +forgetNonTypes :: Module TypeAnn -> Module (Type ()) +forgetNonTypes Module{..} = Module { + moduleImports = first forgetSourceAnn <$> moduleImports, + moduleDecls = forgetSourceAnnBindings <$> moduleDecls, + .. + } + + +unFun :: Type a -> Either (Type a) (Type a,Type a) +unFun = \case + TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) + other -> Left other + + + + +-- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module +-- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. + +-- | Desugars a module from AST to CoreFn representation. +moduleToCoreFn :: forall m. M m => A.Module -> m (Module TypeAnn) +moduleToCoreFn (A.Module _ _ _ _ Nothing) = + internalError "Module exports were not elaborated before moduleToCoreFn" +moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do + setModuleName + let importHelper ds = fmap ((tUnknown (modSS,[]),ssAnn modSS),) (findQualModules ds) + imports = mapMaybe importToCoreFn decls ++ importHelper decls + exps' = ordNub $ concatMap exportToCoreFn exps + reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) + externs = ordNub $ mapMaybe externToCoreFn decls + decls' <- concat <$> traverse (declToCoreFn mn) decls + + {- + let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) + imports' = dedupeImports imports + exps' = ordNub $ concatMap exportToCoreFn exps + reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) + externs = ordNub $ mapMaybe externToCoreFn decls + decls' = concatMap (declToCoreFn env mn) decls + in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' -} + pure $ Module modSS coms mn (spanName modSS) imports exps' reExps externs decls' + where + setModuleName = modify $ \cs -> + cs {checkCurrentModule = Just mn} + -- Creates a map from a module name to the re-export references defined in + -- that module. +reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] +reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') + +toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) +toReExportRef (A.ReExportRef _ src ref) = + fmap + (, ref) + (A.exportSourceImportedFrom src) +toReExportRef _ = Nothing + + -- Remove duplicate imports +dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] +dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap + +ssA :: SourceSpan -> Ann +ssA ss = (ss, [], Nothing) + + +lookupType :: M m => ModuleName -> ProperName 'TypeName -> m SourceType +lookupType mn tn = do + env <- gets checkEnv + case M.lookup (mkQualified tn mn) (types env) of + Nothing -> error $ "No type found for " <> show tn + Just (ty,kind) -> pure ty + +lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType +lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do + env <- gets checkEnv + case M.lookup (mkQualified ctorName mn) (dataConstructors env) of + Nothing -> error $ "No constr decl info found for " <> show ctorName + Just (_declType,_tyName,ty,_idents) -> pure ty + +moduleName :: M m => m ModuleName +moduleName = gets checkCurrentModule >>= \case + Just mn -> pure mn + Nothing -> error "No module name found in checkState" + +-- Desugars member declarations from AST to CoreFn representation. +declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind (SourceType,Ann)] +declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dataCtorFields ctor of + [(_,wrappedTy)] -> do + declTy <- lookupType mn name + let innerFunTy = function wrappedTy wrappedTy + pure [NonRec (declTy, (ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ + Abs (innerFunTy,(ss, com, Just IsNewtype)) (Ident "x") (Var (wrappedTy,ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] + _ -> error "Found newtype with multiple fields" + where + declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor +declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = + error $ "Found newtype with multiple constructors: " ++ show d +declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = + traverse go ctors + where + go ctorDecl = do + env <- gets checkEnv + let ctor = A.dataCtorName ctorDecl + (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) + ctorDeclTy <- lookupCtorDeclTy mn ctorDecl + pure $ NonRec (ctorDeclTy, (ssA ss)) (properToIdent ctor) $ Constructor (ctorTy,(ss, com, Nothing)) tyName ctor fields +declToCoreFn mn (A.DataBindingGroupDeclaration ds) = + concat <$> traverse (declToCoreFn mn) ds +declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do + traceM $ "decltoCoreFn " <> show name + env <- gets checkEnv + let mValDeclTy = lookupValue env (mkQualified name mn) + case mValDeclTy of + Just(valDeclTy,nameKind,nameVis) -> bindLocalVariables ([(ss,name,valDeclTy,nameVis)]) $ do + expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? + pure $ [NonRec (valDeclTy, ssA ss) name expr] + Nothing -> error $ "No type found for value declaration " <> show name +declToCoreFn mn (A.BindingGroupDeclaration ds) = do + let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds + types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident + recBody <- traverse goRecBindings types + pure [Rec recBody] + where + goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m (((SourceType, Ann), Ident), Expr (SourceType, Ann)) + goRecBindings ((ann,ident),(expr,ty)) = do + expr' <- exprToCoreFn mn (fst ann) (Just ty) expr + pure (((ty,ssA $ fst ann),ident), expr') +declToCoreFn _ _ = pure [] + +traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) +traverseLit f = \case + NumericLiteral x -> pure $ NumericLiteral x + StringLiteral x -> pure $ StringLiteral x + CharLiteral x -> pure $ CharLiteral x + BooleanLiteral x -> pure $ BooleanLiteral x + ArrayLiteral xs -> ArrayLiteral <$> traverse f xs + +inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType +inferType (Just t) _ = pure t +inferType Nothing e = infer e >>= \case + TypedValue' _ _ t -> pure t + +-- Desugars expressions from AST to CoreFn representation. +exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr (SourceType, Ann)) +exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = do + litT <- inferType mTy astLit + lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit + pure $ Literal (litT, (ss, [], Nothing)) lit' + +exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = do + expT <- inferType mTy accessor + expr <- exprToCoreFn mn ss Nothing v + pure $ Accessor (expT, ssA ss) name expr + +exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do + expT <- inferType mTy objUpd + obj' <- exprToCoreFn mn ss Nothing obj + vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs + pure $ + ObjectUpdate + (expT, ssA ss) + obj' + (mTy >>= unchangedRecordFields (fmap fst vs)) + vs' + where + -- Return the unchanged labels of a closed record, or Nothing for other types or open records. + unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] + unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = + collect row + where + collect :: Type a -> Maybe [PSString] + collect (REmptyKinded _ _) = Just [] + collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r + collect _ = Nothing + unchangedRecordFields _ _ = Nothing +exprToCoreFn mn ss mTy lam@(A.Abs (A.VarBinder ssb name) v) = do + traceM $ "exprToCoreFn lam " <> (show name) + (unFun <$> inferType mTy lam) >>= \case + Right (a,b)-> do + traceM $ "function lam " <> prettyPrintType 0 (function a b) + let toBind = [(ssb, name, a, Defined )] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (function a b , ssA ssb) name body + Left ty -> do + traceM $ "??? lam " <> prettyPrintType 0 ty + body <- exprToCoreFn mn ss (Just ty) v + pure $ Abs (ty, ssA ssb) name body + +exprToCoreFn _ _ _ (A.Abs _ _) = + internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" +exprToCoreFn mn ss mTy app@(A.App v1 v2) = do + appT <- inferType mTy app + v1' <- exprToCoreFn mn ss Nothing v1 + v2' <- exprToCoreFn mn ss Nothing v2 + pure $ App (appT, (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp)) v1' v2' + where + isDictCtor = \case + A.Constructor _ (Qualified _ name) -> isDictTypeName name + _ -> False + isSynthetic = \case + A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 + A.Accessor _ v3 -> isSynthetic v3 + A.Var NullSourceSpan _ -> True + A.Unused{} -> True + _ -> False +exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ + error "Don't know what to do w/ exprToCoreFn A.Unused" + -- pure $ Var (ss, com, Nothing) C.I_undefined +exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> + pure $ Var (ty, (ss, [], getValueMeta env ident)) ident +exprToCoreFn mn _ _ (A.Var ss ident) = + gets checkEnv >>= \env -> case lookupValue env ident of + Just (ty,_,_) -> pure $ Var (ty, (ss, [], getValueMeta env ident)) ident + Nothing -> error $ "No known type for identifier " <> show ident +exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do + ifteTy <- inferType mTy ifte + condE <- exprToCoreFn mn ss (Just tyBoolean) cond + thE <- exprToCoreFn mn ss Nothing th + elE <- exprToCoreFn mn ss Nothing el + pure $ Case (ifteTy,(ss, [], Nothing)) [condE] + [ CaseAlternative [LiteralBinder (tyBoolean,ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it + (Right thE) + , CaseAlternative [NullBinder (tyBoolean,ssAnn ss)] -- * + (Right elE) ] +exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = do + env <- gets checkEnv + let ctorMeta = getConstructorMeta env name + ctorType <- inferType mTy ctor + pure $ Var (ctorType,(ss, [], Just ctorMeta)) $ fmap properToIdent name +exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = do + caseTy <- inferType mTy astCase + vs' <- traverse (exprToCoreFn mn ss Nothing) vs + alts' <- traverse (altToCoreFn mn ss) alts + pure $ Case (caseTy, ssA ss) vs' alts' +exprToCoreFn mn ss _ (A.TypedValue _ v ty) = + exprToCoreFn mn ss (Just ty) v +exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = do + letTy <- inferType mTy astLet + (ds', expr) <- transformLetBindings mn ss [] ds v + pure $ Let (letTy,(ss, [], getLetMeta w)) ds' expr +exprToCoreFn mn _ ty (A.PositionedValue ss com1 v) = + exprToCoreFn mn ss ty v +exprToCoreFn _ _ _ e = + error $ "Unexpected value in exprToCoreFn mn: " ++ show e + +transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind (SourceType, Ann)] -> [A.Declaration] -> A.Expr -> m ([Bind (SourceType, Ann)], Expr (SourceType, Ann)) +transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) +-- for typed values (this might be wrong?) +transformLetBindings mn _ss seen (valdec@(A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do + TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do + ((args, elabTy), kind) <- kindOfWithScopedVars ty + checkTypeKind ty kind + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy + if checkType + then withScopedTypeVars mn args $ bindNames dict $ check val ty' + else return (TypedValue' checkType val elabTy) + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val' ty'')]) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +-- untyped values +transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = do + valTy <- freshTypeWithKind kindType + TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) + bindNames dict $ infer val + warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = do + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds + ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict + let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + bindNames dict $ do + makeBindingGroupVisible + thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" + + +-- Desugars case alternatives from AST to CoreFn representation. +altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative (SourceType,Ann)) +altToCoreFn mn ss (A.CaseAlternative bs vs) = do + env <- gets checkEnv + let binders = binderToCoreFn env mn ss <$> bs + ege <- go vs + pure $ CaseAlternative binders ege + where + go :: [A.GuardedExpr] -> m (Either [(Guard (SourceType,Ann), Expr (SourceType,Ann))] (Expr (SourceType,Ann))) + go [A.MkUnguarded e] = do + expr <- exprToCoreFn mn ss Nothing e + pure $ Right expr + go gs = do + ges <- forM gs $ \case + A.GuardedExpr g e -> do + let cond = guardToExpr g + condE <- exprToCoreFn mn ss Nothing cond + eE <- exprToCoreFn mn ss Nothing e + pure (condE,eE) + pure . Left $ ges + guardToExpr [A.ConditionGuard cond] = cond + guardToExpr _ = internalError "Guard not correctly desugared" + +-- This should ONLY ever be used to create a type in contexts where one doesn't make sense +tUnknown :: forall a. a -> Type a +tUnknown x = TUnknown x (-1) + +-- I'm not sure how to type Binders. Likely we need a new syntatic construct? But if the sub-terms are well-typed we should be able to give binder a placeholder type? idk +-- Desugars case binders from AST to CoreFn representation. +binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder (SourceType,Ann) +binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = + let lit' = binderToCoreFn env mn ss <$> lit + ty = tUnknown (ss,[]) + in LiteralBinder (ty, (ss, [], Nothing)) lit' +binderToCoreFn _ mn ss A.NullBinder = + let ty = tUnknown (ss,[]) + in NullBinder (ty, (ss, [], Nothing)) +binderToCoreFn _ mn _ss (A.VarBinder ss name) = + let ty = tUnknown (ss,[]) + in VarBinder (ty,(ss, [], Nothing)) name +binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = + let (_, tctor, _, _) = lookupConstructor env dctor + ty = tUnknown (ss,[]) + args = binderToCoreFn env mn _ss <$> bs + in ConstructorBinder (ty,(ss, [], Just $ getConstructorMeta env dctor)) (Qualified mn' tctor) dctor args +binderToCoreFn env mn _ss (A.NamedBinder ss name b) = + let ty = tUnknown (ss,[]) + arg = binderToCoreFn env mn _ss b + in NamedBinder (ty,(ss, [], Nothing)) name arg +binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = + binderToCoreFn env mn ss b +binderToCoreFn env mn ss (A.TypedBinder _ b) = + binderToCoreFn env mn ss b +binderToCoreFn _ _ _ A.OpBinder{} = + internalError "OpBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.ParensInBinder{} = + internalError "ParensInBinder should have been desugared before binderToCoreFn" + +-- Gets metadata for let bindings. +getLetMeta :: A.WhereProvenance -> Maybe Meta +getLetMeta A.FromWhere = Just IsWhere +getLetMeta A.FromLet = Nothing + +-- Gets metadata for values. +getValueMeta :: Environment -> Qualified Ident -> Maybe Meta +getValueMeta env name = + case lookupValue env name of + Just (_, External, _) -> Just IsForeign + _ -> Nothing + +-- Gets metadata for data constructors. +getConstructorMeta :: Environment -> Qualified (ProperName 'ConstructorName) -> Meta +getConstructorMeta env ctor = + case lookupConstructor env ctor of + (Newtype, _, _, _) -> IsNewtype + dc@(Data, _, _, fields) -> + let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType + in IsConstructor constructorType fields + where + + numConstructors + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> Int + numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env + + typeConstructor + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> (ModuleName, ProperName 'TypeName) + typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor _ = internalError "Invalid argument to typeConstructor" + +-- | Find module names from qualified references to values. This is used to +-- ensure instances are imported from any module that is referenced by the +-- current module, not just from those that are imported explicitly (#667). +findQualModules :: [A.Declaration] -> [ModuleName] +findQualModules decls = + let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) + in f `concatMap` decls + +fqDecls :: A.Declaration -> [ModuleName] +fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q +fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q +fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q +fqDecls _ = [] + +fqValues :: A.Expr -> [ModuleName] +fqValues (A.Var _ q) = getQual' q +fqValues (A.Constructor _ q) = getQual' q +fqValues _ = [] + +fqBinders :: A.Binder -> [ModuleName] +fqBinders (A.ConstructorBinder _ q _) = getQual' q +fqBinders _ = [] + +getQual' :: Qualified a -> [ModuleName] +getQual' = maybe [] return . getQual + +-- | Desugars import declarations from AST to CoreFn representation. +importToCoreFn :: A.Declaration -> Maybe ((SourceType,Ann), ModuleName) +-- TODO: We probably *DO* want types here +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((tUnknown (ss,[]),(ss, com, Nothing)), name) +importToCoreFn _ = Nothing + +-- | Desugars foreign declarations from AST to CoreFn representation. +externToCoreFn :: A.Declaration -> Maybe Ident +externToCoreFn (A.ExternDeclaration _ name _) = Just name +externToCoreFn _ = Nothing + +-- | Desugars export declarations references from AST to CoreFn representation. +-- CoreFn modules only export values, so all data constructors, instances and +-- values are flattened into one list. +exportToCoreFn :: A.DeclarationRef -> [Ident] +exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors +exportToCoreFn (A.TypeRef _ _ Nothing) = [] +exportToCoreFn (A.TypeOpRef _ _) = [] +exportToCoreFn (A.ValueRef _ name) = [name] +exportToCoreFn (A.ValueOpRef _ _) = [] +exportToCoreFn (A.TypeClassRef _ _) = [] +exportToCoreFn (A.TypeInstanceRef _ name _) = [name] +exportToCoreFn (A.ModuleRef _ _) = [] +exportToCoreFn (A.ReExportRef _ _ _) = [] + +-- | Converts a ProperName to an Ident. +properToIdent :: ProperName a -> Ident +properToIdent = Ident . runProperName diff --git a/src/Language/PureScript/CoreFn/Typed/Pretty.hs b/src/Language/PureScript/CoreFn/Typed/Pretty.hs new file mode 100644 index 00000000..c61d6163 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Typed/Pretty.hs @@ -0,0 +1,199 @@ +module Language.PureScript.CoreFn.Typed.Pretty where + +import Prelude hiding ((<>)) + +import Control.Arrow (second) + +import Data.Text (Text) +import Data.List.NonEmpty qualified as NEL +import Data.Monoid qualified as Monoid ((<>)) +import Data.Text qualified as T + +import Language.PureScript.Environment +import Language.PureScript.CoreFn +import Language.PureScript.Crash (internalError) +import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName) +import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) +import Language.PureScript.Types (Constraint(..), Type) +import Language.PureScript.PSString (PSString, prettyPrintString) + +import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, hcat, vsep, (//), (<>), render) +import Language.PureScript.Pretty.Types +import Data.Map qualified as M + +textT :: Text -> Box +textT = text . T.unpack + +oneLine :: String -> String +oneLine = filter (/= '\n') + +-- | Render an aligned list of items separated with commas +list :: Char -> Char -> (a -> Box) -> [a] -> Box +list open close _ [] = text [open, close] +list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) + where + toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a + +ellipsis :: Box +ellipsis = text "..." + +prettyPrintObject :: Int -> [(PSString, Maybe (Expr (Type ())))] -> Box +prettyPrintObject d = list '{' '}' prettyPrintObjectProperty + where + prettyPrintObjectProperty :: (PSString, Maybe (Expr (Type ()))) -> Box + prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value + +prettyPrintUpdateEntry :: Int -> PSString -> Expr (Type ()) -> Box +prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val + +-- | Pretty-print an expression +prettyPrintValue :: Int -> Expr (Type ())-> Box +-- prettyPrintValue d _ | d < 0 = text "..." +prettyPrintValue d (Accessor _ prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps +prettyPrintValue d (App _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Abs ty arg val) = text (oneLine $ '\\' : T.unpack (showIdent arg) ++ ": " ++ prettyPrintType (d) (getFunArgTy ty) ++ " -> ") // (prettyPrintValue (d-1) val) +prettyPrintValue d (Case _ values binders) = + (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // + moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) +prettyPrintValue d (Let _ ds val) = + text "let" // + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // + (text "in " <> prettyPrintValue (d - 1) val) +-- TODO: constraint kind args +prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l +prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr + +-- | Pretty-print an atomic expression, adding parentheses if necessary. +prettyPrintValueAtom :: Int -> Expr (Type ()) -> Box +prettyPrintValueAtom d (Literal _ l) = prettyPrintLiteralValue d l +prettyPrintValueAtom _ (Constructor _ _ name _) = text $ T.unpack $ runProperName name +prettyPrintValueAtom d (Var ty ident) = text . oneLine $ "(" ++ T.unpack (showIdent (disqualify ident)) ++ ": " ++ prettyPrintType d ty ++ ")" +prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" + +prettyPrintLiteralValue :: Int -> Literal (Expr (Type ())) -> Box +prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n +prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s +prettyPrintLiteralValue _ (CharLiteral c) = text $ show c +prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" +prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" +prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs +prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps + +prettyPrintDeclaration :: Int -> Bind (Type ()) -> Box +-- prettyPrintDeclaration d _ | d < 0 = ellipsis +prettyPrintDeclaration d b = case b of + NonRec ty ident expr -> + vcat left [ + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ prettyPrintType 0 ty ), + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here + ] + Rec bindings -> vsep 1 left $ map (\((ty,ident),expr) -> + vcat left [ + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ prettyPrintType 0 ty ), + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr + ]) bindings + +prettyPrintCaseAlternative :: Int -> CaseAlternative (Type ()) -> Box +-- prettyPrintCaseAlternative d _ | d < 0 = ellipsis +prettyPrintCaseAlternative d (CaseAlternative binders result) = + text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result + where + prettyPrintResult :: Either [(Guard (Type ()), Expr (Type ()))] (Expr (Type ())) -> Box + prettyPrintResult = \case + Left ges -> vcat left $ map (prettyPrintGuardedValueSep' (text " | ")) ges + Right exp -> text " -> " <> prettyPrintValue (d-1) exp + + prettyPrintGuardedValueSep' :: Box -> (Guard (Type ()), Expr (Type ())) -> Box + prettyPrintGuardedValueSep' sep (guardE, resultE) = + prettyPrintValue (d-1) guardE <> text " -> " <> prettyPrintValue (d-1) resultE + + +prettyPrintModule :: Module (Type ()) -> Box +prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = + vcat left $ + [text (show modName ++ " (" ++ modPath ++ ")")] + ++ ["Imported Modules: "] + ++ map (moveRight 2 . text . show . snd) modImports + ++ ["Exports: "] + ++ map (moveRight 2 . text . T.unpack . showIdent) modExports + ++ ["Re-Exports: "] + ++ map (moveRight 2 . goReExport) (M.toList modReExports) + ++ ["Foreign: "] + ++ map (moveRight 2. text . T.unpack . showIdent) modForeign + ++ ["Declarations: "] + ++ map (prettyPrintDeclaration 0) modDecls + where + goReExport :: (ModuleName,[Ident]) -> Box + goReExport (mn,idents) = vcat left $ flip map idents $ \i -> text (show mn ++ "." ++ T.unpack (showIdent i)) + +prettyPrintModule' :: Module (Type ()) -> String +prettyPrintModule' = render . prettyPrintModule +{- + prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v + prettyPrintResult gs = + vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) + + prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box + prettyPrintGuardedValueSep _ (GuardedExpr [] val) = + text " -> " <> prettyPrintValue (d - 1) val + + prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = + foldl1 before [ sep + , prettyPrintGuard guard + , prettyPrintGuardedValueSep sep (GuardedExpr [] val) + ] + + prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = + vcat left [ foldl1 before + [ sep + , prettyPrintGuard guard + ] + , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) + ] + + prettyPrintGuard (ConditionGuard cond) = + prettyPrintValue (d - 1) cond + prettyPrintGuard (PatternGuard binder val) = + foldl1 before + [ text (T.unpack (prettyPrintBinder binder)) + , text " <- " + , prettyPrintValue (d - 1) val + ] +-} + +prettyPrintBinderAtom :: Binder a -> Text +prettyPrintBinderAtom (NullBinder _) = "_" +prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l +prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident +prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) +prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) +prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder + +prettyPrintLiteralBinder :: Literal (Binder a) -> Text +prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str +prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) +prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num +prettyPrintLiteralBinder (BooleanLiteral True) = "true" +prettyPrintLiteralBinder (BooleanLiteral False) = "false" +prettyPrintLiteralBinder (ObjectLiteral bs) = + "{ " + Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) + Monoid.<> " }" + where + prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Text + prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder +prettyPrintLiteralBinder (ArrayLiteral bs) = + "[ " + Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) + Monoid.<> " ]" + +-- | +-- Generate a pretty-printed string representing a Binder +-- +prettyPrintBinder :: Binder a -> Text +prettyPrintBinder (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) +prettyPrintBinder (ConstructorBinder _ _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) +prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f85703..9cb8a636 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -20,7 +20,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.List.NonEmpty qualified as NEL -import Language.PureScript.AST.SourcePos (nullSourceAnn) +import Language.PureScript.AST.SourcePos (nullSourceAnn, pattern NullSourceAnn) import Language.PureScript.Crash (internalError) import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) import Language.PureScript.Roles (Role(..)) @@ -361,6 +361,18 @@ tyForall var k ty = ForAll nullSourceAnn TypeVarInvisible var (Just k) ty Nothin function :: SourceType -> SourceType -> SourceType function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction +-- This is borderline necessary +pattern (:->) :: Type () -> Type () -> Type () +pattern a :-> b = + TypeApp () + (TypeApp () (TypeConstructor () C.Function) a) + b + +getFunArgTy :: Type () -> Type () +getFunArgTy = \case + a :-> _ -> a + other -> other + -- To make reading the kind signatures below easier (-:>) :: SourceType -> SourceType -> SourceType (-:>) = function diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8340d77c..4b41bc42 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -48,9 +48,14 @@ import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF +import Language.PureScript.CoreFn.Typed qualified as CFT +import Language.PureScript.CoreFn.Typed.Pretty qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +-- Temporary +import Debug.Trace (traceM) + -- | Rebuild a single module. -- -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). @@ -110,8 +115,10 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps - corefn = CF.moduleToCoreFn env' mod' - (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn + ((coreFnTyped,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') + traceM $ CFT.prettyPrintModule' (CFT.forgetNonTypes coreFnTyped) + let corefn = CF.moduleToCoreFn env' mod' + (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized exts = moduleToExternsFile mod' env' renamedIdents ffiCodegen renamed diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20de0ed9..4a810913 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -75,7 +75,7 @@ convertPrettyPrintType = go -- Guard the remaining "complex" type atoms on the current depth value. The -- prior constructors can all be printed simply so it's not really helpful to -- truncate them. - go d _ | d < 0 = PPTruncated + -- go d _ | d < 0 = PPTruncated go d (ConstrainedType _ (Constraint _ cls kargs args _) ty) = PPConstrainedType (cls, go (d-1) <$> kargs, go (d-1) <$> args) (go d ty) go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (go (d-1) k) go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f0..fde27f1e 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -5,6 +5,7 @@ module Language.PureScript.TypeChecker ( module T , typeCheckModule , checkNewtype + , typeCheckAll ) where import Prelude diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index ba27d029..396769a0 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -72,18 +72,18 @@ emptySubstitution = Substitution M.empty M.empty M.empty -- | State required for type checking data CheckState = CheckState - { checkEnv :: Environment + { checkEnv :: !Environment -- ^ The current @Environment@ - , checkNextType :: Int + , checkNextType :: !Int -- ^ The next type unification variable - , checkNextSkolem :: Int + , checkNextSkolem :: !Int -- ^ The next skolem variable - , checkNextSkolemScope :: Int + , checkNextSkolemScope :: !Int -- ^ The next skolem scope constant - , checkCurrentModule :: Maybe ModuleName + , checkCurrentModule :: !(Maybe ModuleName) -- ^ The current module , checkCurrentModuleImports :: - [ ( SourceAnn + ![ ( SourceAnn , ModuleName , ImportDeclarationType , Maybe ModuleName @@ -94,14 +94,14 @@ data CheckState = CheckState -- Newtype constructors have to be in scope for some Coercible constraints to -- be solvable, so we need to know which constructors are imported and whether -- they are actually defined in or re-exported from the imported modules. - , checkSubstitution :: Substitution + , checkSubstitution :: !Substitution -- ^ The current substitution - , checkHints :: [ErrorMessageHint] + , checkHints :: ![ErrorMessageHint] -- ^ The current error message hint stack. -- This goes into state, rather than using 'rethrow', -- since this way, we can provide good error messages -- during instance resolution. - , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) + , checkConstructorImportsForCoercible :: !(S.Set (ModuleName, Qualified (ProperName 'ConstructorName))) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. } diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3f758805..a468a961 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -5,6 +5,18 @@ module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) , typesOf , checkTypeKind + , check + , infer + , inferBinder + , freshTypeWithKind + , kindType + , TypedValue' (..) + , instantiatePolyTypeWithUnknowns + , tvToExpr + , SplitBindingGroup(..) + , typeDictionaryForBindingGroup + , typeForBindingGroupElement + , checkTypedBindingGroupElement ) where {- From 62c4685dc429f4d60a6bfcd8d641146fe25b38f4 Mon Sep 17 00:00:00 2001 From: Sean Hunter Date: Wed, 6 Dec 2023 18:34:01 -0500 Subject: [PATCH 06/44] More detailed tracing to investigate type reprs --- src/Language/PureScript/CoreFn/Typed.hs | 1 + src/Language/PureScript/Make.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/Language/PureScript/CoreFn/Typed.hs b/src/Language/PureScript/CoreFn/Typed.hs index dcb71b32..1d997a6b 100644 --- a/src/Language/PureScript/CoreFn/Typed.hs +++ b/src/Language/PureScript/CoreFn/Typed.hs @@ -201,6 +201,7 @@ traverseLit f = \case CharLiteral x -> pure $ CharLiteral x BooleanLiteral x -> pure $ BooleanLiteral x ArrayLiteral xs -> ArrayLiteral <$> traverse f xs + ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType inferType (Just t) _ = pure t diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4b41bc42..7020a291 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -114,8 +114,10 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ desugarCaseGuards elaborated regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded + let mod' = Module ss coms moduleName regrouped exps ((coreFnTyped,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') + mapM_ (traceM . show . fmap (fmap (const ()) . fst)) . CF.moduleDecls $ coreFnTyped traceM $ CFT.prettyPrintModule' (CFT.forgetNonTypes coreFnTyped) let corefn = CF.moduleToCoreFn env' mod' (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn From b173bafb6a7b362ef00388dea1418dd522422f69 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 11 Jan 2024 21:47:10 -0500 Subject: [PATCH 07/44] Switched to a typed CoreFn data type (instead of stashing type info in the annotation) + reworked pretty printer to... print prettily --- purescript.cabal | 2 + src/Language/PureScript/AST/Literals.hs | 8 +- src/Language/PureScript/CoreFn/Binders.hs | 7 +- src/Language/PureScript/CoreFn/Typed.hs | 152 +++++++++--------- src/Language/PureScript/CoreFn/Typed/Expr.hs | 147 +++++++++++++++++ .../PureScript/CoreFn/Typed/Module.hs | 25 +++ .../PureScript/CoreFn/Typed/Pretty.hs | 80 +++++---- src/Language/PureScript/Environment.hs | 9 +- src/Language/PureScript/Make.hs | 9 +- src/Language/PureScript/Pretty/Types.hs | 7 +- 10 files changed, 330 insertions(+), 116 deletions(-) create mode 100644 src/Language/PureScript/CoreFn/Typed/Expr.hs create mode 100644 src/Language/PureScript/CoreFn/Typed/Module.hs diff --git a/purescript.cabal b/purescript.cabal index 178e0931..7bb38daa 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -252,6 +252,8 @@ library Language.PureScript.CoreFn.Traversals Language.PureScript.CoreFn.Typed Language.PureScript.CoreFn.Typed.Pretty + Language.PureScript.CoreFn.Typed.Expr + Language.PureScript.CoreFn.Typed.Module Language.PureScript.CoreImp Language.PureScript.CoreImp.AST Language.PureScript.CoreImp.Module diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index cfa2e880..6cb94a40 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -6,6 +6,9 @@ module Language.PureScript.AST.Literals where import Prelude import Language.PureScript.PSString (PSString) +-- For serializing/deserializing Typed CoreFn +import GHC.Generics ( Generic ) +import Data.Aeson (FromJSON, ToJSON) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and -- Binders. @@ -35,4 +38,7 @@ data Literal a -- An object literal -- | ObjectLiteral [(PSString, a)] - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic) + +instance FromJSON a => FromJSON (Literal a) +instance ToJSON a => ToJSON (Literal a) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 4b64b97c..62d1fcf7 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -8,6 +8,9 @@ import Prelude import Language.PureScript.AST.Literals (Literal) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) +import GHC.Generics +import Data.Aeson (FromJSON, ToJSON) + -- | -- Data type for binders -- @@ -31,8 +34,10 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor) + | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor, Generic) +instance FromJSON a => FromJSON (Binder a) +instance ToJSON a => ToJSON (Binder a) extractBinderAnn :: Binder a -> a extractBinderAnn (NullBinder a) = a diff --git a/src/Language/PureScript/CoreFn/Typed.hs b/src/Language/PureScript/CoreFn/Typed.hs index 1d997a6b..b0bcc66b 100644 --- a/src/Language/PureScript/CoreFn/Typed.hs +++ b/src/Language/PureScript/CoreFn/Typed.hs @@ -9,12 +9,11 @@ This is a very rough draft ATM. In a more polished version these should all be r -} -module Language.PureScript.CoreFn.Typed (moduleToCoreFn, forgetNonTypes) where +module Language.PureScript.CoreFn.Typed (moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, Bifunctor (first)) +import Protolude (ordNub, orEmpty) -import Control.Arrow (second) import Data.Function (on) import Data.Maybe (mapMaybe) @@ -25,53 +24,50 @@ import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) import Language.PureScript.AST.Traversals (everythingOnValues) -import Language.PureScript.Comments (Comment) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) -import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, extractAnn) +import Language.PureScript.CoreFn.Typed.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, PurusType) import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) -import Language.PureScript.CoreFn.Module (Module(..)) +import Language.PureScript.CoreFn.Typed.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, function, NameVisibility (..), tyBoolean) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, mkQualified) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) -import Language.PureScript.AST qualified as A +import Language.PureScript.AST.Binders qualified as A +import Language.PureScript.AST.Declarations qualified as A +import Language.PureScript.AST.SourcePos qualified as A import Language.PureScript.Constants.Prim qualified as C import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Strict (MonadState, gets, modify) -import Control.Monad.Writer.Class -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, unsafeCheckCurrentModule, makeBindingGroupVisible) +import Control.Monad.Writer.Class ( MonadWriter ) +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible) import Control.Monad.Error (MonadError) import Language.PureScript.TypeChecker.Types + ( kindType, + checkTypeKind, + freshTypeWithKind, + SplitBindingGroup(SplitBindingGroup), + TypedValue'(TypedValue'), + BindingGroupType(RecursiveBindingGroup), + typesOf, + typeDictionaryForBindingGroup, + checkTypedBindingGroupElement, + typeForBindingGroupElement, + infer, + check ) import Data.List.NonEmpty qualified as NE import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) import Control.Monad (forM, (<=<)) import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) import Language.PureScript.Errors (MultipleErrors, parU) -import Language.PureScript.TypeChecker.Monad (CheckState(CheckState)) -import Language.PureScript.AST.SourcePos (nullSourceAnn, pattern NullSourceAnn) import Debug.Trace (traceM) -import Language.PureScript.Pretty.Types +import Language.PureScript.Pretty.Types ( prettyPrintType ) type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) -type TypeAnn = (SourceType,Ann) - -forgetSourceAnn :: TypeAnn -> Type () -forgetSourceAnn (ty,_) = (const ()) <$> ty - -forgetSourceAnnBindings :: Bind TypeAnn -> Bind (Type ()) -forgetSourceAnnBindings = \case - NonRec ann _id exp -> NonRec (forgetSourceAnn ann) _id (forgetSourceAnn <$> exp) - Rec bs -> Rec $ flip map bs $ \((ann,_id),exp) -> ((forgetSourceAnn ann,_id),forgetSourceAnn <$> exp) - -forgetNonTypes :: Module TypeAnn -> Module (Type ()) -forgetNonTypes Module{..} = Module { - moduleImports = first forgetSourceAnn <$> moduleImports, - moduleDecls = forgetSourceAnnBindings <$> moduleDecls, - .. - } +purusTy :: Type a -> PurusType +purusTy = fmap (const ()) unFun :: Type a -> Either (Type a) (Type a,Type a) @@ -79,20 +75,17 @@ unFun = \case TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) other -> Left other - - - -- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module -- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. -- | Desugars a module from AST to CoreFn representation. -moduleToCoreFn :: forall m. M m => A.Module -> m (Module TypeAnn) +moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do setModuleName - let importHelper ds = fmap ((tUnknown (modSS,[]),ssAnn modSS),) (findQualModules ds) - imports = mapMaybe importToCoreFn decls ++ importHelper decls + let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) + imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls exps' = ordNub $ concatMap exportToCoreFn exps reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) externs = ordNub $ mapMaybe externToCoreFn decls @@ -150,13 +143,13 @@ moduleName = gets checkCurrentModule >>= \case Nothing -> error "No module name found in checkState" -- Desugars member declarations from AST to CoreFn representation. -declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind (SourceType,Ann)] +declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dataCtorFields ctor of [(_,wrappedTy)] -> do - declTy <- lookupType mn name - let innerFunTy = function wrappedTy wrappedTy - pure [NonRec (declTy, (ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ - Abs (innerFunTy,(ss, com, Just IsNewtype)) (Ident "x") (Var (wrappedTy,ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] + -- declTy <- lookupType mn name // might need this? + let innerFunTy = purusFun wrappedTy wrappedTy + pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ + Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] _ -> error "Found newtype with multiple fields" where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor @@ -169,8 +162,8 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = env <- gets checkEnv let ctor = A.dataCtorName ctorDecl (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - ctorDeclTy <- lookupCtorDeclTy mn ctorDecl - pure $ NonRec (ctorDeclTy, (ssA ss)) (properToIdent ctor) $ Constructor (ctorTy,(ss, com, Nothing)) tyName ctor fields + -- ctorDeclTy <- lookupCtorDeclTy mn ctorDecl + pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields declToCoreFn mn (A.DataBindingGroupDeclaration ds) = concat <$> traverse (declToCoreFn mn) ds declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do @@ -178,9 +171,9 @@ declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do env <- gets checkEnv let mValDeclTy = lookupValue env (mkQualified name mn) case mValDeclTy of - Just(valDeclTy,nameKind,nameVis) -> bindLocalVariables ([(ss,name,valDeclTy,nameVis)]) $ do + Just(valDeclTy,nameKind,nameVis) -> bindLocalVariables [(ss,name,valDeclTy,nameVis)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? - pure $ [NonRec (valDeclTy, ssA ss) name expr] + pure $ [NonRec (ssA ss) name expr] Nothing -> error $ "No type found for value declaration " <> show name declToCoreFn mn (A.BindingGroupDeclaration ds) = do let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds @@ -188,10 +181,10 @@ declToCoreFn mn (A.BindingGroupDeclaration ds) = do recBody <- traverse goRecBindings types pure [Rec recBody] where - goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m (((SourceType, Ann), Ident), Expr (SourceType, Ann)) + goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) goRecBindings ((ann,ident),(expr,ty)) = do expr' <- exprToCoreFn mn (fst ann) (Just ty) expr - pure (((ty,ssA $ fst ann),ident), expr') + pure ((ssA $ fst ann,ident), expr') declToCoreFn _ _ = pure [] traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) @@ -209,24 +202,25 @@ inferType Nothing e = infer e >>= \case TypedValue' _ _ t -> pure t -- Desugars expressions from AST to CoreFn representation. -exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr (SourceType, Ann)) +exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = do - litT <- inferType mTy astLit + litT <- purusTy <$> inferType mTy astLit lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit - pure $ Literal (litT, (ss, [], Nothing)) lit' + pure $ Literal (ss, [], Nothing) litT lit' exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = do - expT <- inferType mTy accessor + expT <- purusTy <$> inferType mTy accessor expr <- exprToCoreFn mn ss Nothing v - pure $ Accessor (expT, ssA ss) name expr + pure $ Accessor (ssA ss) expT name expr exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do - expT <- inferType mTy objUpd + expT <- purusTy <$> inferType mTy objUpd obj' <- exprToCoreFn mn ss Nothing obj vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs pure $ ObjectUpdate - (expT, ssA ss) + (ssA ss) + expT obj' (mTy >>= unchangedRecordFields (fmap fst vs)) vs' @@ -244,16 +238,16 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do exprToCoreFn mn ss mTy lam@(A.Abs (A.VarBinder ssb name) v) = do traceM $ "exprToCoreFn lam " <> (show name) (unFun <$> inferType mTy lam) >>= \case - Right (a,b)-> do - traceM $ "function lam " <> prettyPrintType 0 (function a b) + Right (a,b) -> do + traceM $ "function lam " <> prettyPrintType 0 (purusFun a b) let toBind = [(ssb, name, a, Defined )] bindLocalVariables toBind $ do body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (function a b , ssA ssb) name body + pure $ Abs (ssA ssb) (purusFun a b) name body Left ty -> do traceM $ "??? lam " <> prettyPrintType 0 ty body <- exprToCoreFn mn ss (Just ty) v - pure $ Abs (ty, ssA ssb) name body + pure $ Abs (ssA ssb) (purusTy ty) name body exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" @@ -261,7 +255,7 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) = do appT <- inferType mTy app v1' <- exprToCoreFn mn ss Nothing v1 v2' <- exprToCoreFn mn ss Nothing v2 - pure $ App (appT, (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp)) v1' v2' + pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' where isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name @@ -276,46 +270,46 @@ exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ error "Don't know what to do w/ exprToCoreFn A.Unused" -- pure $ Var (ss, com, Nothing) C.I_undefined exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> - pure $ Var (ty, (ss, [], getValueMeta env ident)) ident + pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident exprToCoreFn mn _ _ (A.Var ss ident) = gets checkEnv >>= \env -> case lookupValue env ident of - Just (ty,_,_) -> pure $ Var (ty, (ss, [], getValueMeta env ident)) ident + Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident Nothing -> error $ "No known type for identifier " <> show ident exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do ifteTy <- inferType mTy ifte condE <- exprToCoreFn mn ss (Just tyBoolean) cond thE <- exprToCoreFn mn ss Nothing th elE <- exprToCoreFn mn ss Nothing el - pure $ Case (ifteTy,(ss, [], Nothing)) [condE] - [ CaseAlternative [LiteralBinder (tyBoolean,ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it + pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] + [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it (Right thE) - , CaseAlternative [NullBinder (tyBoolean,ssAnn ss)] -- * + , CaseAlternative [NullBinder (ssAnn ss)] -- * (Right elE) ] exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = do env <- gets checkEnv let ctorMeta = getConstructorMeta env name ctorType <- inferType mTy ctor - pure $ Var (ctorType,(ss, [], Just ctorMeta)) $ fmap properToIdent name + pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = do caseTy <- inferType mTy astCase vs' <- traverse (exprToCoreFn mn ss Nothing) vs alts' <- traverse (altToCoreFn mn ss) alts - pure $ Case (caseTy, ssA ss) vs' alts' + pure $ Case (ssA ss) (purusTy caseTy) vs' alts' exprToCoreFn mn ss _ (A.TypedValue _ v ty) = exprToCoreFn mn ss (Just ty) v exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = do letTy <- inferType mTy astLet (ds', expr) <- transformLetBindings mn ss [] ds v - pure $ Let (letTy,(ss, [], getLetMeta w)) ds' expr -exprToCoreFn mn _ ty (A.PositionedValue ss com1 v) = + pure $ Let (ss, [], getLetMeta w) (purusTy letTy) ds' expr +exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = exprToCoreFn mn ss ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e -transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind (SourceType, Ann)] -> [A.Declaration] -> A.Expr -> m ([Bind (SourceType, Ann)], Expr (SourceType, Ann)) +transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) -- for typed values (this might be wrong?) -transformLetBindings mn _ss seen (valdec@(A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do +transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind @@ -353,14 +347,14 @@ transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings -- Desugars case alternatives from AST to CoreFn representation. -altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative (SourceType,Ann)) +altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann) altToCoreFn mn ss (A.CaseAlternative bs vs) = do env <- gets checkEnv let binders = binderToCoreFn env mn ss <$> bs ege <- go vs pure $ CaseAlternative binders ege where - go :: [A.GuardedExpr] -> m (Either [(Guard (SourceType,Ann), Expr (SourceType,Ann))] (Expr (SourceType,Ann))) + go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) go [A.MkUnguarded e] = do expr <- exprToCoreFn mn ss Nothing e pure $ Right expr @@ -381,26 +375,26 @@ tUnknown x = TUnknown x (-1) -- I'm not sure how to type Binders. Likely we need a new syntatic construct? But if the sub-terms are well-typed we should be able to give binder a placeholder type? idk -- Desugars case binders from AST to CoreFn representation. -binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder (SourceType,Ann) +binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = let lit' = binderToCoreFn env mn ss <$> lit ty = tUnknown (ss,[]) - in LiteralBinder (ty, (ss, [], Nothing)) lit' + in LiteralBinder (ss, [], Nothing) lit' binderToCoreFn _ mn ss A.NullBinder = let ty = tUnknown (ss,[]) - in NullBinder (ty, (ss, [], Nothing)) + in NullBinder (ss, [], Nothing) binderToCoreFn _ mn _ss (A.VarBinder ss name) = let ty = tUnknown (ss,[]) - in VarBinder (ty,(ss, [], Nothing)) name + in VarBinder (ss, [], Nothing) name binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor ty = tUnknown (ss,[]) args = binderToCoreFn env mn _ss <$> bs - in ConstructorBinder (ty,(ss, [], Just $ getConstructorMeta env dctor)) (Qualified mn' tctor) dctor args + in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args binderToCoreFn env mn _ss (A.NamedBinder ss name b) = let ty = tUnknown (ss,[]) arg = binderToCoreFn env mn _ss b - in NamedBinder (ty,(ss, [], Nothing)) name arg + in NamedBinder (ss, [], Nothing) name arg binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = binderToCoreFn env mn ss b binderToCoreFn env mn ss (A.TypedBinder _ b) = @@ -472,9 +466,9 @@ getQual' :: Qualified a -> [ModuleName] getQual' = maybe [] return . getQual -- | Desugars import declarations from AST to CoreFn representation. -importToCoreFn :: A.Declaration -> Maybe ((SourceType,Ann), ModuleName) +importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -- TODO: We probably *DO* want types here -importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((tUnknown (ss,[]),(ss, com, Nothing)), name) +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) importToCoreFn _ = Nothing -- | Desugars foreign declarations from AST to CoreFn representation. diff --git a/src/Language/PureScript/CoreFn/Typed/Expr.hs b/src/Language/PureScript/CoreFn/Typed/Expr.hs new file mode 100644 index 00000000..3e969e8f --- /dev/null +++ b/src/Language/PureScript/CoreFn/Typed/Expr.hs @@ -0,0 +1,147 @@ +module Language.PureScript.CoreFn.Typed.Expr where +import Prelude + +import Control.Arrow ((***)) + +import GHC.Generics +import Data.Aeson (FromJSON, ToJSON) + + +import Language.PureScript.AST.Literals (Literal) +import Language.PureScript.CoreFn.Binders (Binder) +import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Types (Type) + + +type PurusType = Type () + +-- | +-- Data type for expressions and terms +-- +data Expr a + -- | + -- A literal value + -- + = Literal a PurusType (Literal (Expr a)) + -- | + -- A data constructor (type name, constructor name, field names) + -- + | Constructor a PurusType (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] + -- | + -- A record property accessor + -- + | Accessor a PurusType PSString (Expr a) + -- | + -- Partial record update (original value, fields to copy (if known), fields to update) + -- + | ObjectUpdate a PurusType (Expr a) (Maybe [PSString]) [(PSString, Expr a)] + -- | + -- Function introduction + -- + | Abs a PurusType Ident (Expr a) + -- | + -- Function application + -- + | App a PurusType (Expr a) (Expr a) + -- | + -- Variable + -- + | Var a PurusType (Qualified Ident) + -- | + -- A case expression + -- + | Case a PurusType [Expr a] [CaseAlternative a] + -- | + -- A let binding + -- + | Let a PurusType [Bind a] (Expr a) + deriving (Eq, Ord, Show, Functor, Generic) + +instance FromJSON a => FromJSON (Expr a) +instance ToJSON a => ToJSON (Expr a) + +exprType :: Expr a -> PurusType +exprType = \case + Literal _ ty _ -> ty + Constructor _ ty _ _ _ -> ty + Accessor _ ty _ _ -> ty + ObjectUpdate _ ty _ _ _ -> ty + Abs _ ty _ _ -> ty + App _ ty _ _ -> ty + Var _ ty __ -> ty + Case _ ty _ _ -> ty + Let _ ty _ _ -> ty + +-- | +-- A let or module binding. +-- +data Bind a + -- | + -- Non-recursive binding for a single value + -- + = NonRec a Ident (Expr a) + -- | + -- Mutually recursive binding group for several values + -- + | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor, Generic) + +instance FromJSON a => FromJSON (Bind a) +instance ToJSON a => ToJSON (Bind a) + +-- | +-- A guard is just a boolean-valued expression that appears alongside a set of binders +-- +type Guard a = Expr a + +-- | +-- An alternative in a case statement +-- +data CaseAlternative a = CaseAlternative + { -- | + -- A collection of binders with which to match the inputs + -- + caseAlternativeBinders :: [Binder a] + -- | + -- The result expression or a collect of guarded expressions + -- + , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) + } deriving (Eq, Ord, Show, Generic) + +instance FromJSON a => FromJSON (CaseAlternative a) +instance ToJSON a => ToJSON (CaseAlternative a) + +instance Functor CaseAlternative where + + fmap f (CaseAlternative cabs car) = CaseAlternative + (fmap (fmap f) cabs) + (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car) + +-- | +-- Extract the annotation from a term +-- +extractAnn :: Expr a -> a +extractAnn (Literal a _ _) = a +extractAnn (Constructor a _ _ _ _) = a +extractAnn (Accessor a _ _ _) = a +extractAnn (ObjectUpdate a _ _ _ _) = a +extractAnn (Abs a _ _ _) = a +extractAnn (App a _ _ _) = a +extractAnn (Var a _ _) = a +extractAnn (Case a _ _ _) = a +extractAnn (Let a _ _ _) = a + + +-- | +-- Modify the annotation on a term +-- +modifyAnn :: (a -> a) -> Expr a -> Expr a +modifyAnn f (Literal a b c) = Literal (f a) b c +modifyAnn f (Constructor a b c d e) = Constructor (f a) b c d e +modifyAnn f (Accessor a b c d) = Accessor (f a) b c d +modifyAnn f (ObjectUpdate a b c d e) = ObjectUpdate (f a) b c d e +modifyAnn f (Abs a b c d) = Abs (f a) b c d +modifyAnn f (App a b c d) = App (f a) b c d +modifyAnn f (Var a b c) = Var (f a) b c +modifyAnn f (Case a b c d) = Case (f a) b c d +modifyAnn f (Let a b c d) = Let (f a) b c d diff --git a/src/Language/PureScript/CoreFn/Typed/Module.hs b/src/Language/PureScript/CoreFn/Typed/Module.hs new file mode 100644 index 00000000..439416d1 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Typed/Module.hs @@ -0,0 +1,25 @@ +module Language.PureScript.CoreFn.Typed.Module where + +import Prelude + +import Data.Map.Strict (Map) + +import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreFn.Typed.Expr (Bind) +import Language.PureScript.Names (Ident, ModuleName) + +-- | +-- The CoreFn module representation +-- +data Module a = Module + { moduleSourceSpan :: SourceSpan + , moduleComments :: [Comment] + , moduleName :: ModuleName + , modulePath :: FilePath + , moduleImports :: [(a, ModuleName)] + , moduleExports :: [Ident] + , moduleReExports :: Map ModuleName [Ident] + , moduleForeign :: [Ident] + , moduleDecls :: [Bind a] + } deriving (Functor, Show) diff --git a/src/Language/PureScript/CoreFn/Typed/Pretty.hs b/src/Language/PureScript/CoreFn/Typed/Pretty.hs index c61d6163..a578f6cf 100644 --- a/src/Language/PureScript/CoreFn/Typed/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Typed/Pretty.hs @@ -10,11 +10,14 @@ import Data.Monoid qualified as Monoid ((<>)) import Data.Text qualified as T import Language.PureScript.Environment -import Language.PureScript.CoreFn +import Language.PureScript.CoreFn.Typed.Expr +import Language.PureScript.CoreFn.Typed.Module +import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn.Binders import Language.PureScript.Crash (internalError) import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName) import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) -import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) +import Language.PureScript.Pretty.Types ( typeAsBox, typeAtomAsBox, prettyPrintObjectKey) import Language.PureScript.Types (Constraint(..), Type) import Language.PureScript.PSString (PSString, prettyPrintString) @@ -22,6 +25,17 @@ import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, hcat, vsep, (// import Language.PureScript.Pretty.Types import Data.Map qualified as M +-- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack +ppType :: Int -> Type a -> String +ppType i t = go [] $ prettyPrintType i t + where + go :: String -> String -> String + go acc [] = acc + go acc (' ':xs) = case dropWhile (== ' ') xs of + [] -> acc + more -> go (acc `mappend` [' ']) more + go acc (x:xs) = go (acc `mappend` [x]) xs + textT :: Text -> Box textT = text . T.unpack @@ -35,45 +49,53 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl where toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a + +hlist :: Char -> Char -> (a -> Box) -> [a] -> Box +hlist open close _ [] = text [open, close] +hlist open close f xs = hcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) + where + toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a + + ellipsis :: Box ellipsis = text "..." -prettyPrintObject :: Int -> [(PSString, Maybe (Expr (Type ())))] -> Box -prettyPrintObject d = list '{' '}' prettyPrintObjectProperty +prettyPrintObject :: Int -> [(PSString, Maybe (Expr a))] -> Box +prettyPrintObject d = hlist '{' '}' prettyPrintObjectProperty where - prettyPrintObjectProperty :: (PSString, Maybe (Expr (Type ()))) -> Box + prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Box prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -prettyPrintUpdateEntry :: Int -> PSString -> Expr (Type ()) -> Box +prettyPrintUpdateEntry :: Int -> PSString -> Expr a -> Box prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val -- | Pretty-print an expression -prettyPrintValue :: Int -> Expr (Type ())-> Box +prettyPrintValue :: Int -> Expr a -> Box -- prettyPrintValue d _ | d < 0 = text "..." -prettyPrintValue d (Accessor _ prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps -prettyPrintValue d (App _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs ty arg val) = text (oneLine $ '\\' : T.unpack (showIdent arg) ++ ": " ++ prettyPrintType (d) (getFunArgTy ty) ++ " -> ") // (prettyPrintValue (d-1) val) -prettyPrintValue d (Case _ values binders) = +prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps +prettyPrintValue d (App ann _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ " -> ") // (prettyPrintValue (d-1) val) +prettyPrintValue d (Case ann ty values binders) = (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) -prettyPrintValue d (Let _ ds val) = +prettyPrintValue d (Let _ _ ds val) = text "let" // moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // (text "in " <> prettyPrintValue (d - 1) val) -- TODO: constraint kind args -prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l +prettyPrintValue d (Literal _ _ l) = prettyPrintLiteralValue d l prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Int -> Expr (Type ()) -> Box -prettyPrintValueAtom d (Literal _ l) = prettyPrintLiteralValue d l -prettyPrintValueAtom _ (Constructor _ _ name _) = text $ T.unpack $ runProperName name -prettyPrintValueAtom d (Var ty ident) = text . oneLine $ "(" ++ T.unpack (showIdent (disqualify ident)) ++ ": " ++ prettyPrintType d ty ++ ")" +prettyPrintValueAtom :: Int -> Expr a -> Box +prettyPrintValueAtom d (Literal _ _ l) = prettyPrintLiteralValue d l +prettyPrintValueAtom _ (Constructor _ _ _ name _) = text $ T.unpack $ runProperName name +prettyPrintValueAtom d (Var ann ty ident) = text . oneLine $ "(" ++ T.unpack (showIdent (disqualify ident)) ++ ": " ++ ppType d ty ++ ")" prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" -prettyPrintLiteralValue :: Int -> Literal (Expr (Type ())) -> Box +prettyPrintLiteralValue :: Int -> Literal (Expr a) -> Box prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s prettyPrintLiteralValue _ (CharLiteral c) = text $ show c @@ -82,36 +104,36 @@ prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps -prettyPrintDeclaration :: Int -> Bind (Type ()) -> Box +prettyPrintDeclaration :: Int -> Bind a -> Box -- prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration d b = case b of - NonRec ty ident expr -> + NonRec _ ident expr -> vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ prettyPrintType 0 ty ), + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here ] - Rec bindings -> vsep 1 left $ map (\((ty,ident),expr) -> + Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ prettyPrintType 0 ty ), + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr ]) bindings -prettyPrintCaseAlternative :: Int -> CaseAlternative (Type ()) -> Box +prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box -- prettyPrintCaseAlternative d _ | d < 0 = ellipsis prettyPrintCaseAlternative d (CaseAlternative binders result) = text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result where - prettyPrintResult :: Either [(Guard (Type ()), Expr (Type ()))] (Expr (Type ())) -> Box + prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Box prettyPrintResult = \case Left ges -> vcat left $ map (prettyPrintGuardedValueSep' (text " | ")) ges Right exp -> text " -> " <> prettyPrintValue (d-1) exp - prettyPrintGuardedValueSep' :: Box -> (Guard (Type ()), Expr (Type ())) -> Box + prettyPrintGuardedValueSep' :: Box -> (Guard a, Expr a) -> Box prettyPrintGuardedValueSep' sep (guardE, resultE) = prettyPrintValue (d-1) guardE <> text " -> " <> prettyPrintValue (d-1) resultE -prettyPrintModule :: Module (Type ()) -> Box +prettyPrintModule :: Module a -> Box prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = vcat left $ [text (show modName ++ " (" ++ modPath ++ ")")] @@ -129,7 +151,7 @@ prettyPrintModule (Module modSS modComments modName modPath modImports modExport goReExport :: (ModuleName,[Ident]) -> Box goReExport (mn,idents) = vcat left $ flip map idents $ \i -> text (show mn ++ "." ++ T.unpack (showIdent i)) -prettyPrintModule' :: Module (Type ()) -> String +prettyPrintModule' :: Module a -> String prettyPrintModule' = render . prettyPrintModule {- prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 9cb8a636..ef0b7ea5 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -4,7 +4,7 @@ import Prelude import GHC.Generics (Generic) import Control.DeepSeq (NFData) -import Control.Monad (unless) +import Control.Monad (unless, void) import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import Data.Aeson qualified as A @@ -361,6 +361,13 @@ tyForall var k ty = ForAll nullSourceAnn TypeVarInvisible var (Just k) ty Nothin function :: SourceType -> SourceType -> SourceType function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction +purusFun :: Type a -> Type a -> Type () +purusFun = f . g + where + f x = TypeApp () x . void + g = TypeApp () tyFunctionNoAnn . void + tyFunctionNoAnn = TypeConstructor () C.Function + -- This is borderline necessary pattern (:->) :: Type () -> Type () -> Type () pattern a :-> b = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 7020a291..157d03a6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -50,6 +50,7 @@ import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.Typed qualified as CFT import Language.PureScript.CoreFn.Typed.Pretty qualified as CFT +import Language.PureScript.CoreFn.Typed.Module qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) @@ -90,6 +91,7 @@ rebuildModuleWithIndex -> Maybe (Int, Int) -> m ExternsFile rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do + traceM "hi" progress $ CompilingModule moduleName moduleIndex let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m @@ -117,8 +119,9 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ let mod' = Module ss coms moduleName regrouped exps ((coreFnTyped,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') - mapM_ (traceM . show . fmap (fmap (const ()) . fst)) . CF.moduleDecls $ coreFnTyped - traceM $ CFT.prettyPrintModule' (CFT.forgetNonTypes coreFnTyped) + traceM "boom?" + mapM_ (traceM . show) . CFT.moduleDecls $ coreFnTyped + traceM $ CFT.prettyPrintModule' coreFnTyped let corefn = CF.moduleToCoreFn env' mod' (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized @@ -138,7 +141,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs Right d -> d - evalSupplyT nextVar'' $ codegen renamed docs exts + evalSupplyT nextVar''' $ codegen renamed docs exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 4a810913..f40b9b93 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -36,6 +36,8 @@ import Language.PureScript.Label (Label(..)) import Text.PrettyPrint.Boxes (Box(..), hcat, hsep, left, moveRight, nullBox, render, text, top, vcat, (<>)) +import Debug.Trace + data PrettyPrintType = PPTUnknown Int | PPTypeVar Text (Maybe Text) @@ -56,6 +58,7 @@ data PrettyPrintType | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPTruncated + deriving (Show) type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType], [PrettyPrintType]) @@ -118,12 +121,12 @@ constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTy -- Generate a pretty-printed string representing a Row -- prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box -prettyPrintRowWith tro open close labels rest = +prettyPrintRowWith tro open close labels rest = trace ("prettyPrintRowWith: \n" `mappend` show labels `mappend` "\n" `mappend` show rest) $ case (labels, rest) of ([], Nothing) -> if troRowAsDiff tro then text [ open, ' ' ] <> text "..." <> text [ ' ', close ] else text [ open, close ] ([], Just _) -> - text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] + text [ open {-, ' ' -}] <> tailToPs rest <> text [ ' ' {-, close -}] _ -> vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++ From 5b02fe142b5edb6113947e6bac44a73a82f4ba6c Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 17 Jan 2024 02:07:21 -0500 Subject: [PATCH 08/44] Preserving ForAll quantifiers in output CoreFn AST (WIP/maybe broken) --- purescript.cabal | 9 +- src/Language/PureScript/CodeGen.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 519 --------------- src/Language/PureScript/CodeGen/JS/Common.hs | 249 ------- src/Language/PureScript/CodeGen/JS/Printer.hs | 310 --------- src/Language/PureScript/CoreFn/CSE.hs | 30 +- src/Language/PureScript/CoreFn/Desugar.hs | 619 ++++++++++++------ src/Language/PureScript/CoreFn/Expr.hs | 93 ++- src/Language/PureScript/CoreFn/FromJSON.hs | 37 +- src/Language/PureScript/CoreFn/Laziness.hs | 568 ---------------- src/Language/PureScript/CoreFn/Optimizer.hs | 6 +- .../PureScript/CoreFn/{Typed => }/Pretty.hs | 13 +- src/Language/PureScript/CoreFn/ToJSON.hs | 29 +- src/Language/PureScript/CoreFn/Traversals.hs | 28 +- src/Language/PureScript/CoreFn/Typed.hs | 495 -------------- src/Language/PureScript/CoreFn/Typed/Expr.hs | 147 ----- .../PureScript/CoreFn/Typed/Module.hs | 25 - src/Language/PureScript/Make.hs | 34 +- src/Language/PureScript/Make/Actions.hs | 23 +- src/Language/PureScript/Options.hs | 4 +- src/Language/PureScript/Pretty/Types.hs | 6 +- src/Language/PureScript/Renamer.hs | 32 +- 22 files changed, 628 insertions(+), 2650 deletions(-) delete mode 100644 src/Language/PureScript/CodeGen/JS.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Common.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Printer.hs delete mode 100644 src/Language/PureScript/CoreFn/Laziness.hs rename src/Language/PureScript/CoreFn/{Typed => }/Pretty.hs (97%) delete mode 100644 src/Language/PureScript/CoreFn/Typed.hs delete mode 100644 src/Language/PureScript/CoreFn/Typed/Expr.hs delete mode 100644 src/Language/PureScript/CoreFn/Typed/Module.hs diff --git a/purescript.cabal b/purescript.cabal index 7bb38daa..2357dc5d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -233,9 +233,6 @@ library Language.PureScript.Bundle Language.PureScript.CodeGen Language.PureScript.CodeGen.UPLC - Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Printer Language.PureScript.Constants.Libs Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann @@ -244,16 +241,12 @@ library Language.PureScript.CoreFn.Desugar Language.PureScript.CoreFn.Expr Language.PureScript.CoreFn.FromJSON - Language.PureScript.CoreFn.Laziness Language.PureScript.CoreFn.Meta Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Optimizer + Language.PureScript.CoreFn.Pretty Language.PureScript.CoreFn.ToJSON Language.PureScript.CoreFn.Traversals - Language.PureScript.CoreFn.Typed - Language.PureScript.CoreFn.Typed.Pretty - Language.PureScript.CoreFn.Typed.Expr - Language.PureScript.CoreFn.Typed.Module Language.PureScript.CoreImp Language.PureScript.CoreImp.AST Language.PureScript.CoreImp.Module diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index 02edf9ec..a552ce52 100644 --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -5,4 +5,4 @@ -- module Language.PureScript.CodeGen (module C) where -import Language.PureScript.CodeGen.JS as C +import Language.PureScript.CodeGen.UPLC as C diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs deleted file mode 100644 index 14d122a3..00000000 --- a/src/Language/PureScript/CodeGen/JS.hs +++ /dev/null @@ -1,519 +0,0 @@ --- | This module generates code in the core imperative representation from --- elaborated PureScript code. -module Language.PureScript.CodeGen.JS - ( module AST - , module Common - , moduleToJs - ) where - -import Prelude -import Protolude (ordNub) - -import Control.Applicative (liftA2) -import Control.Monad (forM, replicateM, void) -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.Supply.Class (MonadSupply, freshName) -import Control.Monad.Writer (MonadWriter, runWriterT, writer) - -import Data.Bifunctor (first) -import Data.List ((\\), intersect) -import Data.List.NonEmpty qualified as NEL (nonEmpty) -import Data.Foldable qualified as F -import Data.Map qualified as M -import Data.Set qualified as S -import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import Data.Monoid (Any(..)) -import Data.String (fromString) -import Data.Text (Text) -import Data.Text qualified as T - -import Language.PureScript.AST.SourcePos (SourceSpan, displayStartEndPos) -import Language.PureScript.CodeGen.JS.Common as Common -import Language.PureScript.CoreImp.AST (AST, InitializerEffects(..), everywhere, everywhereTopDownM, withSourceSpan) -import Language.PureScript.CoreImp.AST qualified as AST -import Language.PureScript.CoreImp.Module qualified as AST -import Language.PureScript.CoreImp.Optimizer (optimize) -import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Literal(..), Meta(..), Module(..), extractAnn, extractBinderAnn, modifyAnn, removeComments) -import Language.PureScript.CoreFn.Laziness (applyLazinessTransform) -import Language.PureScript.Crash (internalError) -import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), - MultipleErrors(..), rethrow, errorMessage, - errorMessage', rethrowWithPosition, addHint) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified) -import Language.PureScript.Options (CodegenTarget(..), Options(..)) -import Language.PureScript.PSString (PSString, mkString) -import Language.PureScript.Traversals (sndM) -import Language.PureScript.Constants.Prim qualified as C - -import System.FilePath.Posix (()) - --- | Generate code in the simplified JavaScript intermediate representation for all declarations in a --- module. -moduleToJs - :: forall m - . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) - => Module Ann - -> Maybe PSString - -> m AST.Module -moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = - rethrow (addHint (ErrorInModule mn)) $ do - let usedNames = concatMap getNames decls - let imps' = ordNub $ map snd imps - let mnLookup = renameImports usedNames imps' - (jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls - optimized <- fmap (fmap (fmap annotatePure)) . optimize (map identToJs exps) $ if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls - F.traverse_ (F.traverse_ checkIntegers) optimized - comments <- not <$> asks optionsNoComments - let header = if comments then coms else [] - let foreign' = maybe [] (pure . AST.Import FFINamespace) $ if null foreigns then Nothing else foreignInclude - let moduleBody = concat optimized - let (S.union (M.keysSet reExps) -> usedModuleNames, renamedModuleBody) = traverse (replaceModuleAccessors mnLookup) moduleBody - let jsImports - = map (importToJs mnLookup) - . filter (flip S.member usedModuleNames) - $ (\\ (mn : C.primModules)) imps' - let foreignExps = exps `intersect` foreigns - let standardExps = exps \\ foreignExps - let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) - let jsExports - = (maybeToList . exportsToJs foreignInclude $ foreignExps) - ++ (maybeToList . exportsToJs Nothing $ standardExps) - ++ mapMaybe reExportsToJs reExps' - return $ AST.Module header (foreign' ++ jsImports) renamedModuleBody jsExports - - where - -- Adds purity annotations to top-level values for bundlers. - -- The semantics here derive from treating top-level module evaluation as pure, which lets - -- us remove any unreferenced top-level declarations. To achieve this, we wrap any non-trivial - -- top-level values in an IIFE marked with a pure annotation. - annotatePure :: AST -> AST - annotatePure = annotateOrWrap - where - annotateOrWrap = liftA2 fromMaybe pureIife maybePure - - -- If the JS is potentially effectful (in the eyes of a bundler that - -- doesn't know about PureScript), return Nothing. Otherwise, return Just - -- the JS with any needed pure annotations added, and, in the case of a - -- variable declaration, an IIFE to be annotated. - maybePure :: AST -> Maybe AST - maybePure = maybePureGen False - - -- Like maybePure, but doesn't add a pure annotation to App. This exists - -- to prevent from doubling up on annotation comments on curried - -- applications; from experimentation, it turns out that a comment on the - -- outermost App is sufficient for the entire curried chain to be - -- considered effect-free. - maybePure' :: AST -> Maybe AST - maybePure' = maybePureGen True - - maybePureGen alreadyAnnotated = \case - AST.VariableIntroduction ss name j -> Just (AST.VariableIntroduction ss name (fmap annotateOrWrap <$> j)) - AST.App ss f args -> (if alreadyAnnotated then AST.App else pureApp) ss <$> maybePure' f <*> traverse maybePure args - AST.ArrayLiteral ss jss -> AST.ArrayLiteral ss <$> traverse maybePure jss - AST.ObjectLiteral ss props -> AST.ObjectLiteral ss <$> traverse (traverse maybePure) props - AST.Comment c js -> AST.Comment c <$> maybePure js - - js@(AST.Indexer _ _ (AST.Var _ FFINamespace)) -> Just js - - js@AST.NumericLiteral{} -> Just js - js@AST.StringLiteral{} -> Just js - js@AST.BooleanLiteral{} -> Just js - js@AST.Function{} -> Just js - js@AST.Var{} -> Just js - js@AST.ModuleAccessor{} -> Just js - - _ -> Nothing - - pureIife :: AST -> AST - pureIife val = pureApp Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing [AST.Return Nothing val])) [] - - pureApp :: Maybe SourceSpan -> AST -> [AST] -> AST - pureApp ss f = AST.Comment AST.PureAnnotation . AST.App ss f - - -- Extracts all declaration names from a binding group. - getNames :: Bind Ann -> [Ident] - getNames (NonRec _ ident _) = [ident] - getNames (Rec vals) = map (snd . fst) vals - - -- Creates alternative names for each module to ensure they don't collide - -- with declaration names. - renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName Text - renameImports = go M.empty - where - go :: M.Map ModuleName Text -> [Ident] -> [ModuleName] -> M.Map ModuleName Text - go acc used (mn' : mns') = - let mnj = moduleNameToJs mn' - in if mn' /= mn && Ident mnj `elem` used - then let newName = freshModuleName 1 mnj used - in go (M.insert mn' newName acc) (Ident newName : used) mns' - else go (M.insert mn' mnj acc) used mns' - go acc _ [] = acc - - freshModuleName :: Integer -> Text -> [Ident] -> Text - freshModuleName i mn' used = - let newName = mn' <> "_" <> T.pack (show i) - in if Ident newName `elem` used - then freshModuleName (i + 1) mn' used - else newName - - -- Generates JavaScript code for a module import, binding the required module - -- to the alternative - importToJs :: M.Map ModuleName Text -> ModuleName -> AST.Import - importToJs mnLookup mn' = - let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - in AST.Import mnSafe (moduleImportPath mn') - - -- Generates JavaScript code for exporting at least one identifier, - -- eventually from another module. - exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST.Export - exportsToJs from = fmap (flip AST.Export from) . NEL.nonEmpty . fmap runIdent - - -- Generates JavaScript code for re-exporting at least one identifier from - -- from another module. - reExportsToJs :: (ModuleName, [Ident]) -> Maybe AST.Export - reExportsToJs = uncurry exportsToJs . first (Just . moduleImportPath) - - moduleImportPath :: ModuleName -> PSString - moduleImportPath mn' = fromString (".." T.unpack (runModuleName mn') "index.js") - - -- Replaces the `ModuleAccessor`s in the AST with `Indexer`s, ensuring that - -- the generated code refers to the collision-avoiding renamed module - -- imports. Also returns set of used module names. - replaceModuleAccessors :: M.Map ModuleName Text -> AST -> (S.Set ModuleName, AST) - replaceModuleAccessors mnLookup = everywhereTopDownM $ \case - AST.ModuleAccessor _ mn' name -> - let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - in (S.singleton mn', accessorString name $ AST.Var Nothing mnSafe) - other -> pure other - - -- Check that all integers fall within the valid int range for JavaScript. - checkIntegers :: AST -> m () - checkIntegers = void . everywhereTopDownM go - where - go :: AST -> m AST - go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) = - -- Move the negation inside the literal; since this is a top-down - -- traversal doing this replacement will stop the next case from raising - -- the error when attempting to use -2147483648, as if left unrewritten - -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and - -- 2147483648 is larger than the maximum allowed int. - return $ AST.NumericLiteral ss (Left (-i)) - go js@(AST.NumericLiteral ss (Left i)) = - let minInt = -2147483648 - maxInt = 2147483647 - in if i < minInt || i > maxInt - then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt - else return js - go other = return other - - runtimeLazy :: AST - runtimeLazy = - AST.VariableIntroduction Nothing "$runtime_lazy" . Just . (UnknownEffects, ) . AST.Function Nothing Nothing ["name", "moduleName", "init"] . AST.Block Nothing $ - [ AST.VariableIntroduction Nothing "state" . Just . (UnknownEffects, ) . AST.NumericLiteral Nothing $ Left 0 - , AST.VariableIntroduction Nothing "val" Nothing - , AST.Return Nothing . AST.Function Nothing Nothing ["lineNumber"] . AST.Block Nothing $ - [ AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 2))) (AST.Return Nothing $ AST.Var Nothing "val") Nothing - , AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 1))) (AST.Throw Nothing $ AST.Unary Nothing AST.New (AST.App Nothing (AST.Var Nothing "ReferenceError") [foldl1 (AST.Binary Nothing AST.Add) - [ AST.Var Nothing "name" - , AST.StringLiteral Nothing " was needed before it finished initializing (module " - , AST.Var Nothing "moduleName" - , AST.StringLiteral Nothing ", line " - , AST.Var Nothing "lineNumber" - , AST.StringLiteral Nothing ")" - ], AST.Var Nothing "moduleName", AST.Var Nothing "lineNumber"])) Nothing - , AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 1 - , AST.Assignment Nothing (AST.Var Nothing "val") $ AST.App Nothing (AST.Var Nothing "init") [] - , AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 2 - , AST.Return Nothing $ AST.Var Nothing "val" - ] - ] - - -moduleBindToJs - :: forall m - . (MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) - => ModuleName - -> Bind Ann - -> m [AST] -moduleBindToJs mn = bindToJs - where - -- Generate code in the simplified JavaScript intermediate representation for a declaration - bindToJs :: Bind Ann -> m [AST] - bindToJs (NonRec (_, _, Just IsTypeClassConstructor) _ _) = pure [] - -- Unlike other newtype constructors, type class constructors are only - -- ever applied; it's not possible to use them as values. So it's safe to - -- erase them. - bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val - bindToJs (Rec vals) = writer (applyLazinessTransform mn vals) >>= traverse (uncurry . uncurry $ nonRecToJS) - - -- Generate code in the simplified JavaScript intermediate representation for a single non-recursive - -- declaration. - -- - -- The main purpose of this function is to handle code generation for comments. - nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST - nonRecToJS a i e@(extractAnn -> (_, com, _)) | not (null com) = do - withoutComment <- asks optionsNoComments - if withoutComment - then nonRecToJS a i (modifyAnn removeComments e) - else AST.Comment (AST.SourceComments com) <$> nonRecToJS a i (modifyAnn removeComments e) - nonRecToJS (ss, _, _) ident val = do - js <- valueToJs val - withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just (guessEffects val, js)) - - guessEffects :: Expr Ann -> AST.InitializerEffects - guessEffects = \case - Var _ (Qualified (BySourcePos _) _) -> NoEffects - App (_, _, Just IsSyntheticApp) _ _ -> NoEffects - _ -> UnknownEffects - - withPos :: SourceSpan -> AST -> m AST - withPos ss js = do - withSM <- asks (elem JSSourceMap . optionsCodegenTargets) - return $ if withSM - then withSourceSpan ss js - else js - - -- Generate code in the simplified JavaScript intermediate representation for a variable based on a - -- PureScript identifier. - var :: Ident -> AST - var = AST.Var Nothing . identToJs - - -- Generate code in the simplified JavaScript intermediate representation for a value or expression. - valueToJs :: Expr Ann -> m AST - valueToJs e = - let (ss, _, _) = extractAnn e in - withPos ss =<< valueToJs' e - - valueToJs' :: Expr Ann -> m AST - valueToJs' (Literal (pos, _, _) l) = - rethrowWithPosition pos $ literalToValueJS pos l - valueToJs' (Var (_, _, Just (IsConstructor _ [])) name) = - return $ accessorString "value" $ qualifiedToJS id name - valueToJs' (Var (_, _, Just (IsConstructor _ _)) name) = - return $ accessorString "create" $ qualifiedToJS id name - valueToJs' (Accessor _ prop val) = - accessorString prop <$> valueToJs val - valueToJs' (ObjectUpdate (pos, _, _) o copy ps) = do - obj <- valueToJs o - sts <- mapM (sndM valueToJs) ps - case copy of - Nothing -> extendObj obj sts - Just names -> pure $ AST.ObjectLiteral (Just pos) (map f names ++ sts) - where f name = (name, accessorString name obj) - valueToJs' (Abs _ arg val) = do - ret <- valueToJs val - let jsArg = case arg of - UnusedIdent -> [] - _ -> [identToJs arg] - return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret]) - valueToJs' e@App{} = do - let (f, args) = unApp e [] - args' <- mapM valueToJs args - case f of - Var (_, _, Just IsNewtype) _ -> return (head args') - Var (_, _, Just (IsConstructor _ fields)) name | length args == length fields -> - return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' - _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f - where - unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) - unApp (App _ val arg) args = unApp val (arg : args) - unApp other args = (other, args) - valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = - return $ if mn' == mn - then foreignIdent ident - else varToJs qi - valueToJs' (Var (_, _, Just IsForeign) ident) = - internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) - valueToJs' (Var _ ident) = return $ varToJs ident - valueToJs' (Case (ss, _, _) values binders) = do - vals <- mapM valueToJs values - bindersToJs ss binders vals - valueToJs' (Let _ ds val) = do - ds' <- concat <$> mapM bindToJs ds - ret <- valueToJs val - return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] - valueToJs' (Constructor (_, _, Just IsNewtype) _ ctor _) = - return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just . (UnknownEffects, ) $ - AST.ObjectLiteral Nothing [("create", - AST.Function Nothing Nothing ["value"] - (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))]) - valueToJs' (Constructor _ _ ctor []) = - return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing []) - , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor))) - (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ] - valueToJs' (Constructor _ _ ctor fields) = - let constructor = - let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ] - in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body) - createFn = - let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields - in return $ iife (properToJs ctor) [ constructor - , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn - ] - - iife :: Text -> [AST] -> AST - iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) [] - - literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST - literalToValueJS ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i) - literalToValueJS ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n) - literalToValueJS ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s - literalToValueJS ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c]) - literalToValueJS ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b - literalToValueJS ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToJs xs - literalToValueJS ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToJs) ps - - -- Shallow copy an object. - extendObj :: AST -> [(PSString, AST)] -> m AST - extendObj obj sts = do - newObj <- freshName - key <- freshName - evaluatedObj <- freshName - let - jsKey = AST.Var Nothing key - jsNewObj = AST.Var Nothing newObj - jsEvaluatedObj = AST.Var Nothing evaluatedObj - block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj]) - evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just (UnknownEffects, obj)) - objAssign = AST.VariableIntroduction Nothing newObj (Just (NoEffects, AST.ObjectLiteral Nothing [])) - copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing] - cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] - assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)] - stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js - extend = map stToAssign sts - return $ AST.App Nothing (AST.Function Nothing Nothing [] block) [] - - -- Generate code in the simplified JavaScript intermediate representation for a reference to a - -- variable. - varToJs :: Qualified Ident -> AST - varToJs (Qualified (BySourcePos _) ident) = var ident - varToJs qual = qualifiedToJS id qual - - -- Generate code in the simplified JavaScript intermediate representation for a reference to a - -- variable that may have a qualified name. - qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a - qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) - - foreignIdent :: Ident -> AST - foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing FFINamespace) - - -- Generate code in the simplified JavaScript intermediate representation for pattern match binders - -- and guards. - bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST - bindersToJs ss binders vals = do - valNames <- replicateM (length vals) freshName - let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map (Just . (UnknownEffects, )) vals) - jss <- forM binders $ \(CaseAlternative bs result) -> do - ret <- guardsToJs result - go valNames ret bs - return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames]))) - [] - where - go :: [Text] -> [AST] -> [Binder Ann] -> m [AST] - go _ done [] = return done - go (v:vs) done' (b:bs) = do - done'' <- go vs done' bs - binderToJs v done'' b - go _ _ _ = internalError "Invalid arguments to bindersToJs" - - failedPatternError :: [Text] -> AST - failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)] - - failedPatternMessage :: Text - failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": " - - valueError :: Text -> AST -> AST - valueError _ l@(AST.NumericLiteral _ _) = l - valueError _ l@(AST.StringLiteral _ _) = l - valueError _ l@(AST.BooleanLiteral _ _) = l - valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s - - guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST] - guardsToJs (Left gs) = traverse genGuard gs where - genGuard (cond, val) = do - cond' <- valueToJs cond - val' <- valueToJs val - return - (AST.IfElse Nothing cond' - (AST.Block Nothing [AST.Return Nothing val']) Nothing) - - guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v - - binderToJs :: Text -> [AST] -> Binder Ann -> m [AST] - binderToJs s done binder = - let (ss, _, _) = extractBinderAnn binder in - traverse (withPos ss) =<< binderToJs' s done binder - - -- Generate code in the simplified JavaScript intermediate representation for a pattern match - -- binder. - binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST] - binderToJs' _ done NullBinder{} = return done - binderToJs' varName done (LiteralBinder _ l) = - literalToBinderJS varName done l - binderToJs' varName done (VarBinder _ ident) = - return (AST.VariableIntroduction Nothing (identToJs ident) (Just (NoEffects, AST.Var Nothing varName)) : done) - binderToJs' varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) = - binderToJs varName done b - binderToJs' varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do - js <- go (zip fields bs) done - return $ case ctorType of - ProductType -> js - SumType -> - [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) - (AST.Block Nothing js) - Nothing] - where - go :: [(Ident, Binder Ann)] -> [AST] -> m [AST] - go [] done' = return done' - go ((field, binder) : remain) done' = do - argVar <- freshName - done'' <- go remain done' - js <- binderToJs argVar done'' binder - return (AST.VariableIntroduction Nothing argVar (Just (UnknownEffects, accessorString (mkString $ identToJs field) $ AST.Var Nothing varName)) : js) - binderToJs' _ _ ConstructorBinder{} = - internalError "binderToJs: Invalid ConstructorBinder in binderToJs" - binderToJs' varName done (NamedBinder _ ident binder) = do - js <- binderToJs varName done binder - return (AST.VariableIntroduction Nothing (identToJs ident) (Just (NoEffects, AST.Var Nothing varName)) : js) - - literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST] - literalToBinderJS varName done (NumericLiteral num) = - return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing] - literalToBinderJS varName done (CharLiteral c) = - return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing] - literalToBinderJS varName done (StringLiteral str) = - return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing] - literalToBinderJS varName done (BooleanLiteral True) = - return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing done) Nothing] - literalToBinderJS varName done (BooleanLiteral False) = - return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing] - literalToBinderJS varName done (ObjectLiteral bs) = go done bs - where - go :: [AST] -> [(PSString, Binder Ann)] -> m [AST] - go done' [] = return done' - go done' ((prop, binder):bs') = do - propVar <- freshName - done'' <- go done' bs' - js <- binderToJs propVar done'' binder - return (AST.VariableIntroduction Nothing propVar (Just (UnknownEffects, accessorString prop (AST.Var Nothing varName))) : js) - literalToBinderJS varName done (ArrayLiteral bs) = do - js <- go done 0 bs - return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing] - where - go :: [AST] -> Integer -> [Binder Ann] -> m [AST] - go done' _ [] = return done' - go done' index (binder:bs') = do - elVar <- freshName - done'' <- go done' (index + 1) bs' - js <- binderToJs elVar done'' binder - return (AST.VariableIntroduction Nothing elVar (Just (UnknownEffects, AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) - -accessorString :: PSString -> AST -> AST -accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) - -pattern FFINamespace :: Text -pattern FFINamespace = "$foreign" diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs deleted file mode 100644 index e0294689..00000000 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ /dev/null @@ -1,249 +0,0 @@ --- | Common code generation utility functions -module Language.PureScript.CodeGen.JS.Common where - -import Prelude - -import Data.Char (isAlpha, isAlphaNum, isDigit, ord) -import Data.Text (Text) -import Data.Text qualified as T - -import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident(..), InternalIdentData(..), ModuleName(..), ProperName(..), unusedIdent) - -moduleNameToJs :: ModuleName -> Text -moduleNameToJs (ModuleName mn) = - let name = T.replace "." "_" mn - in if nameIsJsBuiltIn name then "$$" <> name else name - --- | Convert an 'Ident' into a valid JavaScript identifier: --- --- * Alphanumeric characters are kept unmodified. --- --- * Reserved javascript identifiers and identifiers starting with digits are --- prefixed with '$$'. -identToJs :: Ident -> Text -identToJs (Ident name) - | not (T.null name) && isDigit (T.head name) = "$$" <> T.concatMap identCharToText name - | otherwise = anyNameToJs name -identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -identToJs UnusedIdent = unusedIdent -identToJs (InternalIdent RuntimeLazyFactory) = "$runtime_lazy" -identToJs (InternalIdent (Lazy name)) = "$lazy_" <> anyNameToJs name - --- | Convert a 'ProperName' into a valid JavaScript identifier: --- --- * Alphanumeric characters are kept unmodified. --- --- * Reserved javascript identifiers are prefixed with '$$'. -properToJs :: ProperName a -> Text -properToJs = anyNameToJs . runProperName - --- | Convert any name into a valid JavaScript identifier. --- --- Note that this function assumes that the argument is a valid PureScript --- identifier (either an 'Ident' or a 'ProperName') to begin with; as such it --- will not produce valid JavaScript identifiers if the argument e.g. begins --- with a digit. Prefer 'identToJs' or 'properToJs' where possible. -anyNameToJs :: Text -> Text -anyNameToJs name - | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name - | otherwise = T.concatMap identCharToText name - --- | Test if a string is a valid JavaScript identifier as-is. Note that, while --- a return value of 'True' guarantees that the string is a valid JS --- identifier, a return value of 'False' does not guarantee that the string is --- not a valid JS identifier. That is, this check is more conservative than --- absolutely necessary. -isValidJsIdentifier :: Text -> Bool -isValidJsIdentifier s = - not (T.null s) && - isAlpha (T.head s) && - s == anyNameToJs s - --- | Attempts to find a human-readable name for a symbol, if none has been specified returns the --- ordinal value. -identCharToText :: Char -> Text -identCharToText c | isAlphaNum c = T.singleton c -identCharToText '_' = "_" -identCharToText '.' = "$dot" -identCharToText '$' = "$dollar" -identCharToText '~' = "$tilde" -identCharToText '=' = "$eq" -identCharToText '<' = "$less" -identCharToText '>' = "$greater" -identCharToText '!' = "$bang" -identCharToText '#' = "$hash" -identCharToText '%' = "$percent" -identCharToText '^' = "$up" -identCharToText '&' = "$amp" -identCharToText '|' = "$bar" -identCharToText '*' = "$times" -identCharToText '/' = "$div" -identCharToText '+' = "$plus" -identCharToText '-' = "$minus" -identCharToText ':' = "$colon" -identCharToText '\\' = "$bslash" -identCharToText '?' = "$qmark" -identCharToText '@' = "$at" -identCharToText '\'' = "$prime" -identCharToText c = '$' `T.cons` T.pack (show (ord c)) - --- | Checks whether an identifier name is reserved in JavaScript. -nameIsJsReserved :: Text -> Bool -nameIsJsReserved name = - name `elem` jsAnyReserved - --- | Checks whether a name matches a built-in value in JavaScript. -nameIsJsBuiltIn :: Text -> Bool -nameIsJsBuiltIn name = - name `elem` - [ "arguments" - , "Array" - , "ArrayBuffer" - , "Boolean" - , "DataView" - , "Date" - , "decodeURI" - , "decodeURIComponent" - , "encodeURI" - , "encodeURIComponent" - , "Error" - , "escape" - , "eval" - , "EvalError" - , "Float32Array" - , "Float64Array" - , "Function" - , "Infinity" - , "Int16Array" - , "Int32Array" - , "Int8Array" - , "Intl" - , "isFinite" - , "isNaN" - , "JSON" - , "Map" - , "Math" - , "NaN" - , "Number" - , "Object" - , "parseFloat" - , "parseInt" - , "Promise" - , "Proxy" - , "RangeError" - , "ReferenceError" - , "Reflect" - , "RegExp" - , "Set" - , "SIMD" - , "String" - , "Symbol" - , "SyntaxError" - , "TypeError" - , "Uint16Array" - , "Uint32Array" - , "Uint8Array" - , "Uint8ClampedArray" - , "undefined" - , "unescape" - , "URIError" - , "WeakMap" - , "WeakSet" - ] - -jsAnyReserved :: [Text] -jsAnyReserved = - concat - [ jsKeywords - , jsSometimesReserved - , jsFutureReserved - , jsFutureReservedStrict - , jsOldReserved - , jsLiterals - ] - -jsKeywords :: [Text] -jsKeywords = - [ "break" - , "case" - , "catch" - , "class" - , "const" - , "continue" - , "debugger" - , "default" - , "delete" - , "do" - , "else" - , "export" - , "extends" - , "finally" - , "for" - , "function" - , "if" - , "import" - , "in" - , "instanceof" - , "new" - , "return" - , "super" - , "switch" - , "this" - , "throw" - , "try" - , "typeof" - , "var" - , "void" - , "while" - , "with" - ] - -jsSometimesReserved :: [Text] -jsSometimesReserved = - [ "await" - , "let" - , "static" - , "yield" - ] - -jsFutureReserved :: [Text] -jsFutureReserved = - [ "enum" ] - -jsFutureReservedStrict :: [Text] -jsFutureReservedStrict = - [ "implements" - , "interface" - , "package" - , "private" - , "protected" - , "public" - ] - -jsOldReserved :: [Text] -jsOldReserved = - [ "abstract" - , "boolean" - , "byte" - , "char" - , "double" - , "final" - , "float" - , "goto" - , "int" - , "long" - , "native" - , "short" - , "synchronized" - , "throws" - , "transient" - , "volatile" - ] - -jsLiterals :: [Text] -jsLiterals = - [ "null" - , "true" - , "false" - ] diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs deleted file mode 100644 index 6740e2a7..00000000 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ /dev/null @@ -1,310 +0,0 @@ --- | Pretty printer for the JavaScript AST -module Language.PureScript.CodeGen.JS.Printer - ( prettyPrintJS - , prettyPrintJSWithSourceMaps - ) where - -import Prelude - -import Control.Arrow ((<+>)) -import Control.Monad (forM, mzero) -import Control.Monad.State (StateT, evalStateT) -import Control.PatternArrows (Operator(..), OperatorTable(..), Pattern(..), buildPrettyPrinter, mkPattern, mkPattern') -import Control.Arrow qualified as A - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.List.NonEmpty qualified as NEL (toList) - -import Language.PureScript.AST (SourceSpan(..)) -import Language.PureScript.CodeGen.JS.Common (identCharToText, isValidJsIdentifier, nameIsJsBuiltIn, nameIsJsReserved) -import Language.PureScript.CoreImp.AST (AST(..), BinaryOperator(..), CIComments(..), UnaryOperator(..), getSourceSpan) -import Language.PureScript.CoreImp.Module (Export(..), Import(..), Module(..)) -import Language.PureScript.Comments (Comment(..)) -import Language.PureScript.Crash (internalError) -import Language.PureScript.Pretty.Common (Emit(..), PrinterState(..), SMap, StrPos(..), addMapping', currentIndent, intercalate, parensPos, runPlainString, withIndent) -import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS) - --- TODO (Christoph): Get rid of T.unpack / pack - -literals :: (Emit gen) => Pattern PrinterState AST gen -literals = mkPattern' match' - where - match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen - match' js = (addMapping' (getSourceSpan js) <>) <$> match js - - match :: (Emit gen) => AST -> StateT PrinterState Maybe gen - match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n - match (StringLiteral _ s) = return $ emit $ prettyPrintStringJS s - match (BooleanLiteral _ True) = return $ emit "true" - match (BooleanLiteral _ False) = return $ emit "false" - match (ArrayLiteral _ xs) = mconcat <$> sequence - [ return $ emit "[ " - , intercalate (emit ", ") <$> forM xs prettyPrintJS' - , return $ emit " ]" - ] - match (ObjectLiteral _ []) = return $ emit "{}" - match (ObjectLiteral _ ps) = mconcat <$> sequence - [ return $ emit "{\n" - , withIndent $ do - jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value - indentString <- currentIndent - return $ intercalate (emit ",\n") $ map (indentString <>) jss - , return $ emit "\n" - , currentIndent - , return $ emit "}" - ] - where - objectPropertyToString :: (Emit gen) => PSString -> gen - objectPropertyToString s = - emit $ case decodeString s of - Just s' | isValidJsIdentifier s' -> - s' - _ -> - prettyPrintStringJS s - match (Block _ sts) = mconcat <$> sequence - [ return $ emit "{\n" - , withIndent $ prettyStatements sts - , return $ emit "\n" - , currentIndent - , return $ emit "}" - ] - match (Var _ ident) = return $ emit ident - match (VariableIntroduction _ ident value) = mconcat <$> sequence - [ return $ emit $ "var " <> ident - , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS' . snd) value - ] - match (Assignment _ target value) = mconcat <$> sequence - [ prettyPrintJS' target - , return $ emit " = " - , prettyPrintJS' value - ] - match (While _ cond sts) = mconcat <$> sequence - [ return $ emit "while (" - , prettyPrintJS' cond - , return $ emit ") " - , prettyPrintJS' sts - ] - match (For _ ident start end sts) = mconcat <$> sequence - [ return $ emit $ "for (var " <> ident <> " = " - , prettyPrintJS' start - , return $ emit $ "; " <> ident <> " < " - , prettyPrintJS' end - , return $ emit $ "; " <> ident <> "++) " - , prettyPrintJS' sts - ] - match (ForIn _ ident obj sts) = mconcat <$> sequence - [ return $ emit $ "for (var " <> ident <> " in " - , prettyPrintJS' obj - , return $ emit ") " - , prettyPrintJS' sts - ] - match (IfElse _ cond thens elses) = mconcat <$> sequence - [ return $ emit "if (" - , prettyPrintJS' cond - , return $ emit ") " - , prettyPrintJS' thens - , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses - ] - match (Return _ value) = mconcat <$> sequence - [ return $ emit "return " - , prettyPrintJS' value - ] - match (ReturnNoResult _) = return $ emit "return" - match (Throw _ value) = mconcat <$> sequence - [ return $ emit "throw " - , prettyPrintJS' value - ] - match (Comment (SourceComments com) js) = mconcat <$> sequence - [ return $ emit "\n" - , mconcat <$> forM com comment - , prettyPrintJS' js - ] - match (Comment PureAnnotation js) = mconcat <$> sequence - [ return $ emit "/* #__PURE__ */ " - , prettyPrintJS' js - ] - match _ = mzero - -comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen -comment (LineComment com) = mconcat <$> sequence - [ currentIndent - , return $ emit "//" <> emit com <> emit "\n" - ] -comment (BlockComment com) = fmap mconcat $ sequence $ - [ currentIndent - , return $ emit "/**\n" - ] ++ - map asLine (T.lines com) ++ - [ currentIndent - , return $ emit " */\n" - , currentIndent - ] - where - asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen - asLine s = do - i <- currentIndent - return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" - - removeComments :: Text -> Text - removeComments t = - case T.stripPrefix "*/" t of - Just rest -> removeComments rest - Nothing -> case T.uncons t of - Just (x, xs) -> x `T.cons` removeComments xs - Nothing -> "" - -prettyImport :: (Emit gen) => Import -> StateT PrinterState Maybe gen -prettyImport (Import ident from) = - return . emit $ - "import * as " <> ident <> " from " <> prettyPrintStringJS from <> ";" - -prettyExport :: (Emit gen) => Export -> StateT PrinterState Maybe gen -prettyExport (Export idents from) = - mconcat <$> sequence - [ return $ emit "export {\n" - , withIndent $ do - let exportsStrings = emit . exportedIdentToString from <$> idents - indentString <- currentIndent - return . intercalate (emit ",\n") . NEL.toList $ (indentString <>) <$> exportsStrings - , return $ emit "\n" - , currentIndent - , return . emit $ "}" <> maybe "" ((" from " <>) . prettyPrintStringJS) from <> ";" - ] - where - exportedIdentToString Nothing ident - | nameIsJsReserved ident || nameIsJsBuiltIn ident - = "$$" <> ident <> " as " <> ident - exportedIdentToString _ "$main" - = T.concatMap identCharToText "$main" <> " as $main" - exportedIdentToString _ ident - = T.concatMap identCharToText ident - -accessor :: Pattern PrinterState AST (Text, AST) -accessor = mkPattern match - where - match (Indexer _ (StringLiteral _ prop) val) = - case decodeString prop of - Just s | isValidJsIdentifier s -> Just (s, val) - _ -> Nothing - match _ = Nothing - -indexer :: (Emit gen) => Pattern PrinterState AST (gen, AST) -indexer = mkPattern' match - where - match (Indexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val - match _ = mzero - -lam :: Pattern PrinterState AST ((Maybe Text, [Text], Maybe SourceSpan), AST) -lam = mkPattern match - where - match (Function ss name args ret) = Just ((name, args, ss), ret) - match _ = Nothing - -app :: (Emit gen) => Pattern PrinterState AST (gen, AST) -app = mkPattern' match - where - match (App _ val args) = do - jss <- traverse prettyPrintJS' args - return (intercalate (emit ", ") jss, val) - match _ = mzero - -instanceOf :: Pattern PrinterState AST (AST, AST) -instanceOf = mkPattern match - where - match (InstanceOf _ val ty) = Just (val, ty) - match _ = Nothing - -unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen -unary' op mkStr = Wrap match (<>) - where - match :: (Emit gen) => Pattern PrinterState AST (gen, AST) - match = mkPattern match' - where - match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val) - match' _ = Nothing - -unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen -unary op str = unary' op (const str) - -negateOperator :: (Emit gen) => Operator PrinterState AST gen -negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-") - where - isNegate (Unary _ Negate _) = True - isNegate _ = False - -binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen -binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2) - where - match :: Pattern PrinterState AST (AST, AST) - match = mkPattern match' - where - match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2) - match' _ = Nothing - -prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen -prettyStatements sts = do - jss <- forM sts prettyPrintJS' - indentString <- currentIndent - return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss - -prettyModule :: (Emit gen) => Module -> StateT PrinterState Maybe gen -prettyModule Module{..} = do - header <- mconcat <$> traverse comment modHeader - imps <- traverse prettyImport modImports - body <- prettyStatements modBody - exps <- traverse prettyExport modExports - pure $ header <> intercalate (emit "\n") (imps ++ body : exps) - --- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level -prettyPrintJSWithSourceMaps :: Module -> (Text, [SMap]) -prettyPrintJSWithSourceMaps js = - let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyModule) js - in (s, mp) - -prettyPrintJS :: Module -> Text -prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyModule - --- | Generate an indented, pretty-printed string representing a JavaScript expression -prettyPrintJS' :: (Emit gen) => AST -> StateT PrinterState Maybe gen -prettyPrintJS' = A.runKleisli $ runPattern matchValue - where - matchValue :: (Emit gen) => Pattern PrinterState AST gen - matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue) - operators :: (Emit gen) => OperatorTable PrinterState AST gen - operators = - OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] - , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ] - , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ] - , [ unary New "new " ] - , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> - emit ("function " - <> fromMaybe "" name - <> "(" <> intercalate ", " args <> ") ") - <> ret ] - , [ unary Not "!" - , unary BitwiseNot "~" - , unary Positive "+" - , negateOperator ] - , [ binary Multiply "*" - , binary Divide "/" - , binary Modulus "%" ] - , [ binary Add "+" - , binary Subtract "-" ] - , [ binary ShiftLeft "<<" - , binary ShiftRight ">>" - , binary ZeroFillShiftRight ">>>" ] - , [ binary LessThan "<" - , binary LessThanOrEqualTo "<=" - , binary GreaterThan ">" - , binary GreaterThanOrEqualTo ">=" - , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ] - , [ binary EqualTo "===" - , binary NotEqualTo "!==" ] - , [ binary BitwiseAnd "&" ] - , [ binary BitwiseXor "^" ] - , [ binary BitwiseOr "|" ] - , [ binary And "&&" ] - , [ binary Or "||" ] - ] diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 576243c2..b7ceaafc 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -22,7 +22,7 @@ import Language.PureScript.AST.SourcePos (nullSourceSpan) import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders (Binder(..)) -import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), exprType) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) @@ -246,18 +246,18 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case -- enables doing monadic work in the RHS, namely `freshIdent` here.) where nameHint = \case - App _ v1 v2 - | Var _ n <- v1 + App _ _ v1 v2 + | Var _ _ n <- v1 , fmap (ProperName . runIdent) n == fmap dictTypeName C.IsSymbol - , Literal _ (ObjectLiteral [(_, Abs _ _ (Literal _ (StringLiteral str)))]) <- v2 + , Literal _ _ (ObjectLiteral [(_, Abs _ _ _ (Literal _ _ (StringLiteral str)))]) <- v2 , Just decodedStr <- decodeString str -> decodedStr <> "IsSymbol" | otherwise -> nameHint v1 - Var _ (Qualified _ ident) + Var _ _ (Qualified _ ident) | Ident name <- ident -> name | GenIdent (Just name) _ <- ident -> name - Accessor _ prop _ + Accessor _ _ prop _ | Just decodedProp <- decodeString prop -> decodedProp _ -> "ref" @@ -270,7 +270,7 @@ nullAnn = (nullSourceSpan, [], Nothing) replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] replaceLocals m = if M.null m then identity else map f' where (f', g', _) = everywhereOnValues identity f identity - f e@(Var _ (Qualified _ ident)) = maybe e g' $ ident `M.lookup` m + f e@(Var _ _ (Qualified _ ident)) = maybe e g' $ ident `M.lookup` m f e = e -- | @@ -292,7 +292,7 @@ floatExpr topLevelQB = \case let w' = w & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) & plurality .~ PluralityMap (M.singleton ident False) - pure (Var nullAnn (Qualified qb ident), w') + pure (Var nullAnn (exprType e) (Qualified qb ident), w') (e, w) -> pure (e, w) -- | @@ -328,8 +328,8 @@ getNewBindsAsLet -> m (Expr Ann) getNewBindsAsLet = fmap (uncurry go) . getNewBinds where go bs = if null bs then identity else \case - Let a bs' e' -> Let a (bs ++ bs') e' - e' -> Let nullAnn bs e' + Let a t bs' e' -> Let a t (bs ++ bs') e' + e' -> Let nullAnn (exprType e') bs e' -- | -- Feed the Writer part of the monad with the requirements of this name. @@ -386,13 +386,13 @@ optimizeCommonSubexpressions mn -- common subexpression elimination pass. shouldFloatExpr :: Expr Ann -> Bool shouldFloatExpr = \case - App (_, _, Just IsSyntheticApp) e _ -> isSimple e + App (_, _, Just IsSyntheticApp) _ e _ -> isSimple e _ -> False isSimple :: Expr Ann -> Bool isSimple = \case Var{} -> True - Accessor _ _ e -> isSimple e + Accessor _ _ _ e -> isSimple e _ -> False handleAndWrapExpr :: Expr Ann -> CSEMonad (Expr Ann) @@ -404,9 +404,9 @@ optimizeCommonSubexpressions mn handleExpr :: Expr Ann -> CSEMonad (Expr Ann) handleExpr = discuss (ifM (shouldFloatExpr . fst) (floatExpr topLevelQB) pure) . \case - Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents False [ident] (handleAndWrapExpr e) - v@(Var _ qname) -> summarizeName mn qname $> v - Let a bs e -> uncurry (Let a) <$> handleBinds False (handleExpr e) bs + Abs a t ident e -> enterAbs $ Abs a t ident <$> newScopeWithIdents False [ident] (handleAndWrapExpr e) + v@(Var _ _ qname) -> summarizeName mn qname $> v + Let a t bs e -> uncurry (Let a t) <$> handleBinds False (handleExpr e) bs x -> handleExprDefault x handleCaseAlternative :: CaseAlternative Ann -> CSEMonad (CaseAlternative Ann) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 34bf08f1..baed6715 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,9 +1,8 @@ -module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where +module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude import Protolude (ordNub, orEmpty) -import Control.Arrow (second) import Data.Function (on) import Data.Maybe (mapMaybe) @@ -14,237 +13,471 @@ import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) import Language.PureScript.AST.Traversals (everythingOnValues) -import Language.PureScript.Comments (Comment) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) -import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, PurusType, exprType) import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, mkQualified, showIdent) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) -import Language.PureScript.AST qualified as A +import Language.PureScript.AST.Binders qualified as A +import Language.PureScript.AST.Declarations qualified as A +import Language.PureScript.AST.SourcePos qualified as A import Language.PureScript.Constants.Prim qualified as C +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.State.Strict (MonadState, gets, modify) +import Control.Monad.Writer.Class ( MonadWriter ) +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible) +import Control.Monad.Error (MonadError) +import Language.PureScript.TypeChecker.Types + ( kindType, + checkTypeKind, + freshTypeWithKind, + SplitBindingGroup(SplitBindingGroup), + TypedValue'(TypedValue'), + BindingGroupType(RecursiveBindingGroup), + typesOf, + typeDictionaryForBindingGroup, + checkTypedBindingGroupElement, + typeForBindingGroupElement, + infer, + check, tvToExpr, instantiatePolyTypeWithUnknowns ) +import Data.List.NonEmpty qualified as NE +import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards, freshType) +import Control.Monad (forM, (<=<)) +import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) +import Language.PureScript.Errors (MultipleErrors, parU) +import Debug.Trace (traceM) +import Language.PureScript.CoreFn.Pretty +import qualified Data.Text as T +import Language.PureScript.Pretty.Types +type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + +purusTy :: Type a -> PurusType +purusTy = fmap (const ()) + +unFun :: Type a -> Either (Type a) (Type a,Type a) +unFun = \case + TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) + other -> Left other + +-- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module +-- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. -- | Desugars a module from AST to CoreFn representation. -moduleToCoreFn :: Environment -> A.Module -> Module Ann -moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = +moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) +moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = - let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) - imports' = dedupeImports imports +moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do + setModuleName + let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) + imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls exps' = ordNub $ concatMap exportToCoreFn exps reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap declToCoreFn decls - in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' - where + decls' <- concat <$> traverse (declToCoreFn mn) decls + pure $ Module modSS coms mn (spanName modSS) imports exps' reExps externs decls' + where + setModuleName = modify $ \cs -> + cs {checkCurrentModule = Just mn} -- Creates a map from a module name to the re-export references defined in -- that module. - reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] - reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') +reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] +reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') - toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) - toReExportRef (A.ReExportRef _ src ref) = +toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) +toReExportRef (A.ReExportRef _ src ref) = fmap (, ref) (A.exportSourceImportedFrom src) - toReExportRef _ = Nothing +toReExportRef _ = Nothing -- Remove duplicate imports - dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] - dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap +dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] +dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap - ssA :: SourceSpan -> Ann - ssA ss = (ss, [], Nothing) +ssA :: SourceSpan -> Ann +ssA ss = (ss, [], Nothing) - -- Desugars member declarations from AST to CoreFn representation. - declToCoreFn :: A.Declaration -> [Bind Ann] - declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = - [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] - where - declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor - declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = - error $ "Found newtype with multiple constructors: " ++ show d - declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = - flip fmap ctors $ \ctorDecl -> - let - ctor = A.dataCtorName ctorDecl - (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields - declToCoreFn (A.DataBindingGroupDeclaration ds) = - concatMap declToCoreFn ds - declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = - [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn (A.BindingGroupDeclaration ds) = - [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] - declToCoreFn _ = [] - - -- Desugars expressions from AST to CoreFn representation. - exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann - exprToCoreFn _ com _ (A.Literal ss lit) = - Literal (ss, com, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) - exprToCoreFn ss com _ (A.Accessor name v) = - Accessor (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs - where - -- Return the unchanged labels of a closed record, or Nothing for other types or open records. - unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] - unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = - collect row - where - collect :: Type a -> Maybe [PSString] - collect (REmptyKinded _ _) = Just [] - collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r - collect _ = Nothing - unchangedRecordFields _ _ = Nothing - exprToCoreFn ss com _ (A.Abs (A.VarBinder _ name) v) = - Abs (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) - exprToCoreFn _ _ _ (A.Abs _ _) = - internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" - exprToCoreFn ss com _ (A.App v1 v2) = - App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' - where - v1' = exprToCoreFn ss [] Nothing v1 - v2' = exprToCoreFn ss [] Nothing v2 - isDictCtor = \case - A.Constructor _ (Qualified _ name) -> isDictTypeName name - _ -> False - isSynthetic = \case - A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 - A.Accessor _ v3 -> isSynthetic v3 - A.Var NullSourceSpan _ -> True - A.Unused{} -> True - _ -> False - exprToCoreFn ss com _ (A.Unused _) = - Var (ss, com, Nothing) C.I_undefined - exprToCoreFn _ com _ (A.Var ss ident) = - Var (ss, com, getValueMeta ident) ident - exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) = - Case (ss, com, Nothing) [exprToCoreFn ss [] Nothing v1] - [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] - (Right $ exprToCoreFn ss [] Nothing v2) - , CaseAlternative [NullBinder (ssAnn ss)] - (Right $ exprToCoreFn ss [] Nothing v3) ] - exprToCoreFn _ com _ (A.Constructor ss name) = - Var (ss, com, Just $ getConstructorMeta name) $ fmap properToIdent name - exprToCoreFn ss com _ (A.Case vs alts) = - Case (ss, com, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) - exprToCoreFn ss com _ (A.TypedValue _ v ty) = - exprToCoreFn ss com (Just ty) v - exprToCoreFn ss com _ (A.Let w ds v) = - Let (ss, com, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = - exprToCoreFn ss (com ++ com1) ty v - exprToCoreFn _ _ _ e = - error $ "Unexpected value in exprToCoreFn mn: " ++ show e - - -- Desugars case alternatives from AST to CoreFn representation. - altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann - altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) - where - go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann) - go [A.MkUnguarded e] - = Right (exprToCoreFn ss [] Nothing e) - go gs - = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e) - | A.GuardedExpr g e <- gs - , let cond = guardToExpr g - ] - - guardToExpr [A.ConditionGuard cond] = cond - guardToExpr _ = internalError "Guard not correctly desugared" - - -- Desugars case binders from AST to CoreFn representation. - binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann - binderToCoreFn _ com (A.LiteralBinder ss lit) = - LiteralBinder (ss, com, Nothing) (fmap (binderToCoreFn ss com) lit) - binderToCoreFn ss com A.NullBinder = - NullBinder (ss, com, Nothing) - binderToCoreFn _ com (A.VarBinder ss name) = - VarBinder (ss, com, Nothing) name - binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = - let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) - binderToCoreFn _ com (A.NamedBinder ss name b) = - NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b) - binderToCoreFn _ com (A.PositionedBinder ss com1 b) = - binderToCoreFn ss (com ++ com1) b - binderToCoreFn ss com (A.TypedBinder _ b) = - binderToCoreFn ss com b - binderToCoreFn _ _ A.OpBinder{} = - internalError "OpBinder should have been desugared before binderToCoreFn" - binderToCoreFn _ _ A.BinaryNoParensBinder{} = - internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" - binderToCoreFn _ _ A.ParensInBinder{} = - internalError "ParensInBinder should have been desugared before binderToCoreFn" - - -- Gets metadata for let bindings. - getLetMeta :: A.WhereProvenance -> Maybe Meta - getLetMeta A.FromWhere = Just IsWhere - getLetMeta A.FromLet = Nothing - - -- Gets metadata for values. - getValueMeta :: Qualified Ident -> Maybe Meta - getValueMeta name = - case lookupValue env name of - Just (_, External, _) -> Just IsForeign - _ -> Nothing - - -- Gets metadata for data constructors. - getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta - getConstructorMeta ctor = - case lookupConstructor env ctor of - (Newtype, _, _, _) -> IsNewtype - dc@(Data, _, _, fields) -> - let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType - in IsConstructor constructorType fields + +lookupType :: M m => ModuleName -> Ident -> m (SourceType,NameVisibility) +lookupType mn tn = do + env <- gets checkEnv + case M.lookup (mkQualified tn mn) (names env) of + Nothing -> error $ "No type found for " <> show tn + Just (ty,nk,nv) -> do + traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty + pure (ty,nv) + +lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType +lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do + env <- gets checkEnv + case M.lookup (mkQualified ctorName mn) (dataConstructors env) of + Nothing -> error $ "No constr decl info found for " <> show ctorName + Just (_declType,_tyName,ty,_idents) -> pure ty + + + +moduleName :: M m => m ModuleName +moduleName = gets checkCurrentModule >>= \case + Just mn -> pure mn + Nothing -> error "No module name found in checkState" + +-- Desugars member declarations from AST to CoreFn representation. +declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] +declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dataCtorFields ctor of + [(_,wrappedTy)] -> do + -- declTy <- lookupType mn name // might need this? + let innerFunTy = purusFun wrappedTy wrappedTy + pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ + Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] + _ -> error "Found newtype with multiple fields" + where + declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor +declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = + error $ "Found newtype with multiple constructors: " ++ show d +declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = + traverse go ctors + where + go ctorDecl = do + env <- gets checkEnv + let ctor = A.dataCtorName ctorDecl + (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) + -- ctorDeclTy <- lookupCtorDeclTy mn ctorDecl + pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields +declToCoreFn mn (A.DataBindingGroupDeclaration ds) = + concat <$> traverse (declToCoreFn mn) ds +declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do + --traceM $ "decltoCoreFn " <> show name + -- env <- gets checkEnv + (valDeclTy,nv) <- lookupType mn name + traceM $ "decltoCoreFn " <> show name <> " :: " <> ppType 10 valDeclTy + bindLocalVariables [(ss,name,valDeclTy,nv)] $ do + expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? + pure $ [NonRec (ssA ss) name expr] + +declToCoreFn mn (A.BindingGroupDeclaration ds) = do + let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds + -- types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident + types <- traverse lookupTypes stripped + recBody <- traverse goRecBindings types + pure [Rec recBody] + where + lookupTypes :: ((A.SourceAnn, Ident), A.Expr) -> m ((A.SourceAnn, Ident), (A.Expr, SourceType)) + lookupTypes ((ann,ident),exp) = lookupType mn ident >>= \(ty,_) -> pure ((ann,ident),(exp,ty)) + + goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) + goRecBindings ((ann,ident),(expr,ty)) = do + expr' <- exprToCoreFn mn (fst ann) (Just ty) expr + pure ((ssA $ fst ann,ident), expr') +declToCoreFn _ _ = pure [] + +traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) +traverseLit f = \case + NumericLiteral x -> pure $ NumericLiteral x + StringLiteral x -> pure $ StringLiteral x + CharLiteral x -> pure $ CharLiteral x + BooleanLiteral x -> pure $ BooleanLiteral x + ArrayLiteral xs -> ArrayLiteral <$> traverse f xs + ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs + +inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType +inferType (Just t) _ = pure t +inferType Nothing e = infer e >>= \case + TypedValue' _ _ t -> pure t + +-- Desugars expressions from AST to CoreFn representation. +exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) +exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = do + litT <- purusTy <$> inferType mTy astLit + lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit + pure $ Literal (ss, [], Nothing) litT lit' + +exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = do + expT <- purusTy <$> inferType mTy accessor + expr <- exprToCoreFn mn ss Nothing v + pure $ Accessor (ssA ss) expT name expr + +exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do + expT <- purusTy <$> inferType mTy objUpd + obj' <- exprToCoreFn mn ss Nothing obj + vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs + pure $ + ObjectUpdate + (ssA ss) + expT + obj' + (mTy >>= unchangedRecordFields (fmap fst vs)) + vs' + where + -- Return the unchanged labels of a closed record, or Nothing for other types or open records. + unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] + unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = + collect row where + collect :: Type a -> Maybe [PSString] + collect (REmptyKinded _ _) = Just [] + collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r + collect _ = Nothing + unchangedRecordFields _ _ = Nothing +exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do + traceM $ "exprToCoreFn lam " <> " :: " <> ppType 10 ty + -- (lam', lamTy) <- instantiatePolyTypeWithUnknowns lam ty + traceM $ "IPTU lamTy: " <> ppType 10 ty + case unFun ty of + Right (a,b) -> do + let toBind = [(ssb, name, a, Defined )] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (purusTy ty) name body + Left e -> case e of + ForAll ann vis var mbK qty mSkol -> do + freshTy <- case mbK of + Nothing -> freshType + Just k -> freshTypeWithKind k + bindLocalVariables [(ssb, (Ident var), freshTy, Defined)] $ do + body <- exprToCoreFn mn ss (Just qty) v + pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbK) (purusTy qty) mSkol) name body + _ -> error "All lambda abstractions should have either a function type or a quantified function type" + -- error "boom" + + {- (unFun <$> inferType (Just ty) lam) >>= \case + Right (a,b) -> do + traceM $ "function lam " <> ppType 10 ty -- prettyPrintType 0 (purusFun a b) + let toBind = [(ssb, name, a, Defined )] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss Nothing v -- (Just b) v + pure $ Abs (ssA ssb) {- (purusFun a b) -} (purusTy ty) name body + Left _ty -> do + traceM $ "??? lam " <> prettyPrintType 0 _ty + body <- exprToCoreFn mn ss Nothing v + pure $ Abs (ssA ssb) (purusTy ty) name body +-} +exprToCoreFn _ _ _ lam@(A.Abs _ _) = + internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn" <> show lam +exprToCoreFn mn ss mTy app@(A.App v1 v2) = do + appT <- inferType mTy app + v1' <- exprToCoreFn mn ss Nothing v1 + v2' <- exprToCoreFn mn ss Nothing v2 + pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' + where + isDictCtor = \case + A.Constructor _ (Qualified _ name) -> isDictTypeName name + _ -> False + isSynthetic = \case + A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 + A.Accessor _ v3 -> isSynthetic v3 + A.Var NullSourceSpan _ -> True + A.Unused{} -> True + _ -> False +exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ + error "Don't know what to do w/ exprToCoreFn A.Unused" + -- pure $ Var (ss, com, Nothing) C.I_undefined +exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> + pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident +exprToCoreFn mn _ _ (A.Var ss ident) = + gets checkEnv >>= \env -> case lookupValue env ident of + Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident + Nothing -> error $ "No known type for identifier " <> show ident +exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do + ifteTy <- inferType mTy ifte + condE <- exprToCoreFn mn ss (Just tyBoolean) cond + thE <- exprToCoreFn mn ss Nothing th + elE <- exprToCoreFn mn ss Nothing el + pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] + [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it + (Right thE) + , CaseAlternative [NullBinder (ssAnn ss)] -- * + (Right elE) ] +exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = do + env <- gets checkEnv + let ctorMeta = getConstructorMeta env name + ctorType <- inferType mTy ctor + pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name +exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = do + caseTy <- inferType mTy astCase + vs' <- traverse (exprToCoreFn mn ss Nothing) vs + alts' <- traverse (altToCoreFn mn ss) alts + pure $ Case (ssA ss) (purusTy caseTy) vs' alts' +exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = + exprToCoreFn mn ss (Just ty) v +exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = + exprToCoreFn mn ss (Just ty) v +exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = do + letTy <- inferType mTy astLet + (ds', expr) <- transformLetBindings mn ss [] ds v + pure $ Let (ss, [], getLetMeta w) (purusTy letTy) ds' expr +exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = + exprToCoreFn mn ss ty v +exprToCoreFn _ _ _ e = + error $ "Unexpected value in exprToCoreFn mn: " ++ show e + +transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) +transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) +-- for typed values (this might be wrong?) +transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do + TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do + ((args, elabTy), kind) <- kindOfWithScopedVars ty + checkTypeKind ty kind + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy + if checkType + then withScopedTypeVars mn args $ bindNames dict $ check val ty' + else return (TypedValue' checkType val elabTy) + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val' ty'')]) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +-- untyped values +transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = do + valTy <- freshTypeWithKind kindType + TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) + bindNames dict $ infer val + warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = do + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds + ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict + let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + bindNames dict $ do + makeBindingGroupVisible + thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" + + +-- Desugars case alternatives from AST to CoreFn representation. +altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann) +altToCoreFn mn ss (A.CaseAlternative bs vs) = do + env <- gets checkEnv + let binders = binderToCoreFn env mn ss <$> bs + ege <- go vs + pure $ CaseAlternative binders ege + where + go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) + go [A.MkUnguarded e] = do + expr <- exprToCoreFn mn ss Nothing e + pure $ Right expr + go gs = do + ges <- forM gs $ \case + A.GuardedExpr g e -> do + let cond = guardToExpr g + condE <- exprToCoreFn mn ss Nothing cond + eE <- exprToCoreFn mn ss Nothing e + pure (condE,eE) + pure . Left $ ges + guardToExpr [A.ConditionGuard cond] = cond + guardToExpr _ = internalError "Guard not correctly desugared" + +-- This should ONLY ever be used to create a type in contexts where one doesn't make sense +tUnknown :: forall a. a -> Type a +tUnknown x = TUnknown x (-1) + +-- I'm not sure how to type Binders. Likely we need a new syntatic construct? But if the sub-terms are well-typed we should be able to give binder a placeholder type? idk +-- Desugars case binders from AST to CoreFn representation. +binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann +binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = + let lit' = binderToCoreFn env mn ss <$> lit + ty = tUnknown (ss,[]) + in LiteralBinder (ss, [], Nothing) lit' +binderToCoreFn _ mn ss A.NullBinder = + let ty = tUnknown (ss,[]) + in NullBinder (ss, [], Nothing) +binderToCoreFn _ mn _ss (A.VarBinder ss name) = + let ty = tUnknown (ss,[]) + in VarBinder (ss, [], Nothing) name +binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = + let (_, tctor, _, _) = lookupConstructor env dctor + ty = tUnknown (ss,[]) + args = binderToCoreFn env mn _ss <$> bs + in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args +binderToCoreFn env mn _ss (A.NamedBinder ss name b) = + let ty = tUnknown (ss,[]) + arg = binderToCoreFn env mn _ss b + in NamedBinder (ss, [], Nothing) name arg +binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = + binderToCoreFn env mn ss b +binderToCoreFn env mn ss (A.TypedBinder _ b) = + binderToCoreFn env mn ss b +binderToCoreFn _ _ _ A.OpBinder{} = + internalError "OpBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.ParensInBinder{} = + internalError "ParensInBinder should have been desugared before binderToCoreFn" - numConstructors - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> Int - numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env +-- Gets metadata for let bindings. +getLetMeta :: A.WhereProvenance -> Maybe Meta +getLetMeta A.FromWhere = Just IsWhere +getLetMeta A.FromLet = Nothing - typeConstructor - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) - typeConstructor _ = internalError "Invalid argument to typeConstructor" +-- Gets metadata for values. +getValueMeta :: Environment -> Qualified Ident -> Maybe Meta +getValueMeta env name = + case lookupValue env name of + Just (_, External, _) -> Just IsForeign + _ -> Nothing + +-- Gets metadata for data constructors. +getConstructorMeta :: Environment -> Qualified (ProperName 'ConstructorName) -> Meta +getConstructorMeta env ctor = + case lookupConstructor env ctor of + (Newtype, _, _, _) -> IsNewtype + dc@(Data, _, _, fields) -> + let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType + in IsConstructor constructorType fields + where + + numConstructors + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> Int + numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env + + typeConstructor + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> (ModuleName, ProperName 'TypeName) + typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor _ = internalError "Invalid argument to typeConstructor" -- | Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). findQualModules :: [A.Declaration] -> [ModuleName] findQualModules decls = - let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in f `concatMap` decls - where - fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q - fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q - fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q - fqDecls _ = [] + let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) + in f `concatMap` decls + +fqDecls :: A.Declaration -> [ModuleName] +fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q +fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q +fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q +fqDecls _ = [] - fqValues :: A.Expr -> [ModuleName] - fqValues (A.Var _ q) = getQual' q - fqValues (A.Constructor _ q) = getQual' q - fqValues _ = [] +fqValues :: A.Expr -> [ModuleName] +fqValues (A.Var _ q) = getQual' q +fqValues (A.Constructor _ q) = getQual' q +fqValues _ = [] - fqBinders :: A.Binder -> [ModuleName] - fqBinders (A.ConstructorBinder _ q _) = getQual' q - fqBinders _ = [] +fqBinders :: A.Binder -> [ModuleName] +fqBinders (A.ConstructorBinder _ q _) = getQual' q +fqBinders _ = [] - getQual' :: Qualified a -> [ModuleName] - getQual' = maybe [] return . getQual +getQual' :: Qualified a -> [ModuleName] +getQual' = maybe [] return . getQual -- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) +-- TODO: We probably *DO* want types here importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) importToCoreFn _ = Nothing diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 20ab3330..f243761e 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,16 +1,20 @@ --- | --- The core functional representation --- module Language.PureScript.CoreFn.Expr where - import Prelude import Control.Arrow ((***)) +import GHC.Generics +import Data.Aeson (FromJSON, ToJSON) + + import Language.PureScript.AST.Literals (Literal) import Language.PureScript.CoreFn.Binders (Binder) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) import Language.PureScript.PSString (PSString) +import Language.PureScript.Types (Type) + + +type PurusType = Type () -- | -- Data type for expressions and terms @@ -19,40 +23,55 @@ data Expr a -- | -- A literal value -- - = Literal a (Literal (Expr a)) + = Literal a PurusType (Literal (Expr a)) -- | -- A data constructor (type name, constructor name, field names) -- - | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] + | Constructor a PurusType (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] -- | -- A record property accessor -- - | Accessor a PSString (Expr a) + | Accessor a PurusType PSString (Expr a) -- | -- Partial record update (original value, fields to copy (if known), fields to update) -- - | ObjectUpdate a (Expr a) (Maybe [PSString]) [(PSString, Expr a)] + | ObjectUpdate a PurusType (Expr a) (Maybe [PSString]) [(PSString, Expr a)] -- | -- Function introduction -- - | Abs a Ident (Expr a) + | Abs a PurusType Ident (Expr a) -- | -- Function application -- - | App a (Expr a) (Expr a) + | App a PurusType (Expr a) (Expr a) -- | -- Variable -- - | Var a (Qualified Ident) + | Var a PurusType (Qualified Ident) -- | -- A case expression -- - | Case a [Expr a] [CaseAlternative a] + | Case a PurusType [Expr a] [CaseAlternative a] -- | -- A let binding -- - | Let a [Bind a] (Expr a) - deriving (Eq, Ord, Show, Functor) + | Let a PurusType [Bind a] (Expr a) + deriving (Eq, Ord, Show, Functor, Generic) + +instance FromJSON a => FromJSON (Expr a) +instance ToJSON a => ToJSON (Expr a) + +exprType :: Expr a -> PurusType +exprType = \case + Literal _ ty _ -> ty + Constructor _ ty _ _ _ -> ty + Accessor _ ty _ _ -> ty + ObjectUpdate _ ty _ _ _ -> ty + Abs _ ty _ _ -> ty + App _ ty _ _ -> ty + Var _ ty __ -> ty + Case _ ty _ _ -> ty + Let _ ty _ _ -> ty -- | -- A let or module binding. @@ -65,7 +84,10 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor) + | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor, Generic) + +instance FromJSON a => FromJSON (Bind a) +instance ToJSON a => ToJSON (Bind a) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -84,7 +106,10 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic) + +instance FromJSON a => FromJSON (CaseAlternative a) +instance ToJSON a => ToJSON (CaseAlternative a) instance Functor CaseAlternative where @@ -96,27 +121,27 @@ instance Functor CaseAlternative where -- Extract the annotation from a term -- extractAnn :: Expr a -> a -extractAnn (Literal a _) = a -extractAnn (Constructor a _ _ _) = a -extractAnn (Accessor a _ _) = a -extractAnn (ObjectUpdate a _ _ _) = a -extractAnn (Abs a _ _) = a -extractAnn (App a _ _) = a -extractAnn (Var a _) = a -extractAnn (Case a _ _) = a -extractAnn (Let a _ _) = a +extractAnn (Literal a _ _) = a +extractAnn (Constructor a _ _ _ _) = a +extractAnn (Accessor a _ _ _) = a +extractAnn (ObjectUpdate a _ _ _ _) = a +extractAnn (Abs a _ _ _) = a +extractAnn (App a _ _ _) = a +extractAnn (Var a _ _) = a +extractAnn (Case a _ _ _) = a +extractAnn (Let a _ _ _) = a -- | -- Modify the annotation on a term -- modifyAnn :: (a -> a) -> Expr a -> Expr a -modifyAnn f (Literal a b) = Literal (f a) b -modifyAnn f (Constructor a b c d) = Constructor (f a) b c d -modifyAnn f (Accessor a b c) = Accessor (f a) b c -modifyAnn f (ObjectUpdate a b c d) = ObjectUpdate (f a) b c d -modifyAnn f (Abs a b c) = Abs (f a) b c -modifyAnn f (App a b c) = App (f a) b c -modifyAnn f (Var a b) = Var (f a) b -modifyAnn f (Case a b c) = Case (f a) b c -modifyAnn f (Let a b c) = Let (f a) b c +modifyAnn f (Literal a b c) = Literal (f a) b c +modifyAnn f (Constructor a b c d e) = Constructor (f a) b c d e +modifyAnn f (Accessor a b c d) = Accessor (f a) b c d +modifyAnn f (ObjectUpdate a b c d e) = ObjectUpdate (f a) b c d e +modifyAnn f (Abs a b c d) = Abs (f a) b c d +modifyAnn f (App a b c d) = App (f a) b c d +modifyAnn f (Var a b c) = Var (f a) b c +modifyAnn f (Case a b c d) = Case (f a) b c d +modifyAnn f (Let a b c d) = Let (f a) b c d diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index d0426b6f..4ae83fec 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -26,6 +26,8 @@ import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), Co import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent) import Language.PureScript.PSString (PSString) +import Language.PureScript.Types () + import Text.ParserCombinators.ReadP (readP_to_S) parseVersion' :: String -> Maybe Version @@ -189,8 +191,8 @@ exprFromJSON :: FilePath -> Value -> Parser (Expr Ann) exprFromJSON modulePath = withObject "Expr" exprFromObj where exprFromObj o = do - type_ <- o .: "type" - case type_ of + kind_ <- o .: "kind" + case kind_ of "Var" -> varFromObj o "Literal" -> literalExprFromObj o "Constructor" -> constructorFromObj o @@ -200,61 +202,72 @@ exprFromJSON modulePath = withObject "Expr" exprFromObj "App" -> appFromObj o "Case" -> caseFromObj o "Let" -> letFromObj o - _ -> fail ("not recognized expression type: \"" ++ T.unpack type_ ++ "\"") + _ -> fail ("not recognized expression kind: \"" ++ T.unpack kind_ ++ "\"") + + tyFromObj o = o .: "type" >>= parseJSON varFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o qi <- o .: "value" >>= qualifiedFromJSON Ident - return $ Var ann qi + return $ Var ann ty qi literalExprFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o lit <- o .: "value" >>= literalFromJSON (exprFromJSON modulePath) - return $ Literal ann lit + return $ Literal ann ty lit constructorFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath tyn <- o .: "typeName" >>= properNameFromJSON + ty <- tyFromObj o con <- o .: "constructorName" >>= properNameFromJSON is <- o .: "fieldNames" >>= listParser identFromJSON - return $ Constructor ann tyn con is + return $ Constructor ann ty tyn con is accessorFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o f <- o .: "fieldName" e <- o .: "expression" >>= exprFromJSON modulePath - return $ Accessor ann f e + return $ Accessor ann ty f e objectUpdateFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o e <- o .: "expression" >>= exprFromJSON modulePath copy <- o .: "copy" >>= parseJSON us <- o .: "updates" >>= recordFromJSON (exprFromJSON modulePath) - return $ ObjectUpdate ann e copy us + return $ ObjectUpdate ann ty e copy us absFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o idn <- o .: "argument" >>= identFromJSON e <- o .: "body" >>= exprFromJSON modulePath - return $ Abs ann idn e + return $ Abs ann ty idn e appFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o e <- o .: "abstraction" >>= exprFromJSON modulePath e' <- o .: "argument" >>= exprFromJSON modulePath - return $ App ann e e' + return $ App ann ty e e' caseFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o cs <- o .: "caseExpressions" >>= listParser (exprFromJSON modulePath) cas <- o .: "caseAlternatives" >>= listParser (caseAlternativeFromJSON modulePath) - return $ Case ann cs cas + return $ Case ann ty cs cas letFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath + ty <- tyFromObj o bs <- o .: "binds" >>= listParser (bindFromJSON modulePath) e <- o .: "expression" >>= exprFromJSON modulePath - return $ Let ann bs e + return $ Let ann ty bs e caseAlternativeFromJSON :: FilePath -> Value -> Parser (CaseAlternative Ann) caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativeFromObj diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs deleted file mode 100644 index 9941fd41..00000000 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ /dev/null @@ -1,568 +0,0 @@ -module Language.PureScript.CoreFn.Laziness - ( applyLazinessTransform - ) where - -import Protolude hiding (force) -import Protolude.Unsafe (unsafeHead) - -import Control.Arrow ((&&&)) -import Data.Array qualified as A -import Data.Coerce (coerce) -import Data.Graph (SCC(..), stronglyConnComp) -import Data.List (foldl1', (!!)) -import Data.IntMap.Monoidal qualified as IM -import Data.IntSet qualified as IS -import Data.Map.Monoidal qualified as M -import Data.Semigroup (Max(..)) -import Data.Set qualified as S - -import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSourceSpan) -import Language.PureScript.Constants.Libs qualified as C -import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn) -import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName) -import Language.PureScript.PSString (mkString) - --- This module is responsible for ensuring that the bindings in recursive --- binding groups are initialized in a valid order, introducing run-time --- laziness and initialization checks as necessary. --- --- PureScript is a call-by-value language with strict data constructors, this --- transformation notwithstanding. The only laziness introduced here is in the --- initialization of a binding. PureScript is uninterested in the order in --- which bindings are written by the user. The compiler has always attempted to --- emit the bindings in an order that makes sense for the backend, but without --- this transformation, recursive bindings are emitted in an arbitrary order, --- which can cause unexpected behavior at run time if a binding is dereferenced --- before it has initialized. --- --- To prevent unexpected errors, this transformation does a syntax-driven --- analysis of a single recursive binding group to attempt to statically order --- the bindings, and when that fails, falls back to lazy initializers that will --- succeed or fail deterministically with a clear error at run time. --- --- Example: --- --- x = f \_ -> --- x --- --- becomes (with some details of the $runtime_lazy function elided): --- --- -- the binding of x has been rewritten as a lazy initializer --- $lazy_x = $runtime_lazy \_ -> --- f \_ -> --- $lazy_x 2 -- the reference to x has been rewritten as a force call --- x = $lazy_x 1 --- --- Central to this analysis are the concepts of delay and force, which are --- attributes given to every subexpression in the binding group. Delay and --- force are defined by the following traversal. This traversal is used twice: --- once to collect all the references made by each binding in the group, and --- then again to rewrite some references to force calls. (The implications of --- delay and force on initialization order are specified later.) - --- | --- Visits every `Var` in an expression with the provided function, including --- the amount of delay and force applied to that `Var`, and substitutes the --- result back into the tree (propagating an `Applicative` effect). --- --- Delay is a non-negative integer that represents the number of lambdas that --- enclose an expression. Force is a non-negative integer that represents the --- number of values that are being applied to an expression. Delay is always --- statically determinable, but force can be *unknown*, so it's represented --- here with a Maybe. In a function application `f a b`, `f` has force 2, but --- `a` and `b` have unknown force--it depends on what `f` does with them. --- --- The rules of assigning delay and force are simple: --- * The expressions that are assigned to bindings in this group have --- delay 0, force 0. --- * In a function application, the function expression has force 1 higher --- than the force of the application expression, and the argument --- expression has unknown force. --- * UNLESS this argument is being directly provided to a constructor (in --- other words, the function expression is either a constructor itself or --- a constructor that has already been partially applied), in which case --- the force of both subexpressions is unchanged. We can assume that --- constructors don't apply any additional force to their arguments. --- * If the force of a lambda is zero, the delay of the body of the lambda is --- incremented; otherwise, the force of the body of the lambda is --- decremented. (Applying one argument to a lambda cancels out one unit of --- delay.) --- * In the argument of a Case and the bindings of a Let, force is unknown. --- * Everywhere else, preserve the delay and force of the enclosing --- expression. --- --- Here are some illustrative examples of the above rules. We will use a --- pseudocode syntax to annotate a subexpression with delay and force: --- `expr#d!f` means `expr` has delay d and force f. `!*` is used to denote --- unknown force. --- --- x = y#0!0 --- x = y#0!2 a#0!* b#0!* --- x = (\_ -> y#1!0)#0!0 --- x = \_ _ -> y#2!1 a#2!* --- x = (\_ -> y#0!0)#0!1 z#0!* --- x = Just { a: a#0!0, b: b#0!0 } --- x = let foo = (y#1!* a b#1!*)#1!* in foo + 1 --- --- (Note that this analysis is quite ignorant of any actual control flow --- choices made at run time. It doesn't even track what happens to a reference --- after it has been locally bound by a Let or Case. Instead, it just assumes --- the worst--once locally bound to a new name, it imagines that absolutely --- anything could happen to that new name and thus to the underlying reference. --- But the value-to-weight ratio of this approach is perhaps surprisingly --- high.) --- --- Every subexpression gets a delay and a force, but we are only interested --- in references to other bindings in the binding group, so the traversal only --- exposes `Var`s to the provided function. --- -onVarsWithDelayAndForce :: forall f. Applicative f => (Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)) -> Expr Ann -> f (Expr Ann) -onVarsWithDelayAndForce f = snd . go 0 $ Just 0 - where - go :: Int -> Maybe Int -> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann)) - go delay force = (handleBind, handleExpr') - where - (handleBind, handleExpr, handleBinder, handleCaseAlternative) = traverseCoreFn handleBind handleExpr' handleBinder handleCaseAlternative - handleExpr' = \case - Var a i -> f delay force a i - Abs a i e -> Abs a i <$> snd (if force == Just 0 then go (succ delay) force else go delay $ fmap pred force) e - -- A clumsy hack to preserve TCO in a particular idiom of unsafePartial once seen in Data.Map.Internal, possibly still used elsewhere. - App a1 e1@(Var _ C.I_unsafePartial) (Abs a2 i e2) -> App a1 e1 . Abs a2 i <$> handleExpr' e2 - App a e1 e2 -> - -- `handleApp` is just to handle the constructor application exception - -- somewhat gracefully (i.e., without requiring a deep inspection of - -- the function expression at every step). If we didn't care about - -- constructors, this could have been simply: - -- App a <$> snd (go delay (fmap succ force)) e1 <*> snd (go delay Nothing) e2 - handleApp 1 [(a, e2)] e1 - Case a vs alts -> Case a <$> traverse (snd $ go delay Nothing) vs <*> traverse handleCaseAlternative alts - Let a ds e -> Let a <$> traverse (fst $ go delay Nothing) ds <*> handleExpr' e - other -> handleExpr other - - handleApp len args = \case - App a e1 e2 -> handleApp (len + 1) ((a, e2) : args) e1 - Var a@(_, _, Just meta) i | isConstructorLike meta - -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> handleExpr' e2) (f delay force a i) args - e -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> snd (go delay Nothing) e2) (snd (go delay (fmap (+ len) force)) e) args - isConstructorLike = \case - IsConstructor{} -> True - IsNewtype -> True - _ -> False - --- Once we assign a delay and force value to every `Var` in the binding group, --- we can consider how to order the bindings to allow them all to successfully --- initialize. There is one principle here: each binding must be initialized --- before the identifier being bound is ready for use. If the preorder thus --- induced has cycles, those cycles need to be resolved with laziness. All of --- the details concern what "ready for use" means. --- --- The definition of delay and force suggests that "ready for use" depends on --- those attributes. If a lambda is bound to the name x, then the references in --- the lambda don't need to be initialized before x is initialized. This is --- represented by the fact that those references have non-zero delay. But if --- the expression bound to x is instead the application of a function y that is --- also bound in this binding group, then not only does y need to be --- initialized before x, so do some of the non-zero delay references in y. This --- is represented by the fact that the occurrence of y in the expression bound --- to x has non-zero force. --- --- An example, reusing the pseudocode annotations defined above: --- --- x _ = y#1!0 --- y = x#0!1 a --- --- y doesn't need to be initialized before x is, because the reference to y in --- x's initializer has delay 1. But y does need to be initialized before x is --- ready for use with force 1, because force 1 is enough to overcome the delay --- of that reference. And since y has a delay-0 reference to x with force 1, y --- will need to be ready for use before it is initialized; thus, y needs to be --- made lazy. --- --- So just as function applications "cancel out" lambdas, a known applied force --- cancels out an equal amount of delay, causing some references that may not --- have been needed earlier to enter play. (And to be safe, we must assume that --- unknown force cancels out *any* amount of delay.) There is another, subtler --- aspect of this: if there are not enough lambdas to absorb every argument --- applied to a function, those arguments will end up applied to the result of --- the function. Likewise, if there is excess force left over after some of it --- has been canceled by delay, that excess is carried to the references --- activated. (Again, an unknown amount of force must be assumed to lead to an --- unknown amount of excess force.) --- --- Another example: --- --- f = g#0!2 a b --- g x = h#1!2 c x --- h _ _ _ = f#3!0 --- --- Initializing f will lead to an infinite loop in this example. f invokes g --- with two arguments. g absorbs one argument, and the second ends up being --- applied to the result of h c x, resulting in h being invoked with three --- arguments. Invoking h with three arguments results in dereferencing f, which --- is not yet ready. To capture this loop in our analysis, we say that making --- f ready for use with force 0 requires making g ready for use with force 2, --- which requires making h ready for use with force 3 (two units of force from --- the lexical position of h, plus one unit of excess force carried forward), --- which cyclically requires f to be ready for use with force 0. --- --- These preceding observations are captured and generalized by the following --- rules: --- --- USE-INIT: Before a reference to x is ready for use with any force, x must --- be initialized. --- --- We will make x lazy iff this rule induces a cycle--i.e., initializing x --- requires x to be ready for use first. --- --- USE-USE: Before a reference to x is ready for use with force f: --- * if a reference in the initializer of x has delay d and force f', --- * and either d <= f or f is unknown, --- * then that reference must itself be ready for use with --- force f – d + f' (or with unknown force if f or f' is unknown). --- --- USE-IMMEDIATE: Initializing a binding x is equivalent to requiring a --- reference to x to be ready for use with force 0, per USE-USE. --- --- Equivalently: before x is initialized, any reference in the initializer --- of x with delay 0 and force f must be ready for use with force f. --- --- Examples: --- --- Assume x is bound in a recursive binding group with the below bindings. --- --- All of the following initializers require x to be ready for use with some --- amount of force, and therefore require x to be initialized first. --- --- a = x#0!0 --- b = (\_ -> x#0!0) 1 --- c = foo x#0!* --- d = (\_ -> foo x#0!*) 1 --- --- In the following initializers, before p can be initialized, x must be --- ready for use with force f – d + f'. (And both x and q must be --- initialized, of course; but x being ready for use with that force may --- induce additional constraints.) --- --- p = ... q#0!f ... --- q = ... x#d!f' ... (where d <= f) --- --- Excess force stacks, of course: in the following initializers, before r --- can be initialized, x must be ready for use with force --- f — d + f' — d' + f'': --- --- r = ... s#0!f ... --- s = ... t#d!f' ... (where d <= f) --- t = ... x#d'!f'' ... (where d' <= f – d + f') --- --- --- To satisfy these rules, we will construct a graph between (identifier, --- delay) pairs, with edges induced by the USE-USE rule, and effectively run a --- topsort to get the initialization preorder. For this part, it's simplest to --- think of delay as an element of the naturals extended with a positive --- infinity, corresponding to an unknown amount of force. (We'll do arithmetic --- on these extended naturals as you would naively expect; we won't do anything --- suspect like subtracting infinity from infinity.) With that in mind, we can --- construct the graph as follows: for each reference from i1 to i2 with delay --- d and force f, draw an infinite family of edges from (i1, d + n) to (i2, f + --- n) for all 0 <= n <= ∞, where n represents the excess force carried over --- from a previous edge. Unfortunately, as an infinite graph, we can't expect --- the tools in Data.Graph to help us traverse it; we will have to be a little --- bit clever. --- --- The following data types and functions are for searching this infinite graph --- and carving from it a finite amount of data to work with. Specifically, we --- want to know for each identifier i, which other identifiers are --- irreflexively reachable from (i, 0) (and thus must be initialized before i --- is), and with what maximum force (in the event of a loop, not every --- reference to i in the reachable identifier needs to be rewritten to a force --- call; only the ones with delay up to the maximum force used during i's --- initialization). We also want the option of aborting a given reachability --- search, for one of two reasons. --- --- * If we encounter a reference with unknown force, abort. --- * If we encounter a cycle where force on a single identifier is --- increasing, abort. (Because of USE-USE, as soon as an identifier is --- revisited with greater force than its first visit, the difference is --- carried forward as excess, so it is possible to retrace that path to get --- an arbitrarily high amount of force.) --- --- Both reasons mean that it is theoretically possible for the identifier in --- question to need every other identifier in the binding group to be --- initialized before it is. (Every identifier in a recursive binding group is --- necessarily reachable from every other, ignoring delay and force, which is --- what arbitrarily high force lets you do.) --- --- In order to reuse parts of this reachability computation across identifiers, --- we are going to represent it with a rose tree data structure interleaved with --- a monad capturing the abort semantics. (The monad is Maybe, but we don't --- need to know that here!) - -type MaxRoseTree m a = m (IM.MonoidalIntMap (MaxRoseNode m a)) -data MaxRoseNode m a = MaxRoseNode a (MaxRoseTree m a) - --- Dissecting this data structure: --- --- m (...) --- ^ represents whether to abort or continue the search --- --- IM.MonoidalIntMap (...) --- ^ the keys of this map are other identifiers reachable from the current --- one (we'll map the identifiers in this binding group to Ints for ease of --- computation) --- --- the values of this map are: --- --- MaxRoseNode a (...) --- ^ this will store the force applied to the next identifier --- (MaxRoseTree m a) --- ^ and this, the tree of identifiers reachable from there --- --- We're only interested in continuing down the search path that applies the --- most force to a given identifier! So when we combine two MaxRoseTrees, --- we want to resolve any key collisions in their MonoidalIntMaps with this --- semigroup: - -instance Ord a => Semigroup (MaxRoseNode m a) where - l@(MaxRoseNode l1 _) <> r@(MaxRoseNode r1 _) = if r1 > l1 then r else l - --- And that's why this is called a MaxRoseTree. --- --- Traversing this tree to get a single MonoidalIntMap with the entire closure --- plus force information is fairly straightforward: - -mrtFlatten :: (Monad m, Ord a) => MaxRoseTree m a -> m (IM.MonoidalIntMap (Max a)) -mrtFlatten = (getAp . IM.foldMapWithKey (\i (MaxRoseNode a inner) -> Ap $ (IM.singleton i (Max a) <>) <$> mrtFlatten inner) =<<) - --- The use of the `Ap` monoid ensures that if any child of this tree aborts, --- the entire tree aborts. --- --- One might ask, why interleave the abort monad with the tree at all if we're --- just going to flatten it out at the end? The point is to flatten it out at --- the end, but *not* during the generation of the tree. Attempting to flatten --- the tree as we generate it can result in an infinite loop, because a subtree --- needs to be exhaustively searched for abort conditions before it can be used --- in another tree. With this approach, we can use lazy trees as building --- blocks and, as long as they get rewritten to be finite or have aborts before --- they're flattened, the analysis still terminates. - --- | --- Given a maximum index and a function that returns a map of edges to next --- indices, returns an array for each index up to maxIndex of maps from the --- indices reachable from the current index, to the maximum force applied to --- those indices. -searchReachable - :: forall m force - . (Alternative m, Monad m, Enum force, Ord force) - => Int - -> ((Int, force) -> m (IM.MonoidalIntMap (Max force))) - -> A.Array Int (m (IM.MonoidalIntMap (Max force))) -searchReachable maxIdx lookupEdges = mrtFlatten . unsafeHead <$> mem - where - -- This is a finite array of infinite lists, used to memoize all the search - -- trees. `unsafeHead` is used above to pull the first tree out of each list - -- in the array--the one corresponding to zero force, which is what's needed - -- to initialize the corresponding identifier. (`unsafeHead` is safe here, of - -- course: infinite lists.) - mem :: A.Array Int [MaxRoseTree m force] - mem = A.listArray (0, maxIdx) - [ [cutLoops <*> fmap (IM.mapWithKey memoizedNode) . lookupEdges $ (i, f) | f <- [toEnum 0..]] - | i <- [0..maxIdx] - ] - - memoizedNode :: Int -> Max force -> MaxRoseNode m force - memoizedNode i (Max force) = MaxRoseNode force $ mem A.! i !! fromEnum force - - -- And this is the function that prevents the search from actually being - -- infinite. It applies a filter to a `MaxRoseTree` at every level, looking for - -- indices anywhere in the tree that match the current vertex. If a match is - -- found with greater force than the current force, that part of the tree is - -- rewritten to abort; otherwise, that part of the tree is rewritten to be - -- empty (there's nothing new in that part of the search). - -- - -- A new version of `cutLoops` is applied for each node in the search, so - -- each edge in a search path will add another filter on a new index. Since - -- there are a finite number of indices in our universe, this guarantees that - -- the analysis terminates, because no single search path can have length - -- greater than `maxIdx`. - cutLoops :: (Int, force) -> MaxRoseTree m force -> MaxRoseTree m force - cutLoops (i, force) = go - where - go = (=<<) . IM.traverseWithKey $ \i' (MaxRoseNode force' inner) -> - MaxRoseNode force' <$> if i == i' then guard (force >= force') $> pure IM.empty else pure $ go inner - --- One last data structure to define and then it's on to the main event. --- --- The laziness transform effectively takes a list of eager bindings (x = ...) --- and splits some of them into lazy definitions ($lazy_x = ...) and lazy --- bindings (x = $lazy_x ...). It's convenient to work with these three --- declarations as the following sum type: - -data RecursiveGroupItem e = EagerBinding Ann e | LazyDefinition e | LazyBinding Ann - deriving Functor - --- | --- Transform a recursive binding group, reordering the bindings within when a --- correct initialization order can be statically determined, and rewriting --- bindings and references to be lazy otherwise. --- -applyLazinessTransform :: ModuleName -> [((Ann, Ident), Expr Ann)] -> ([((Ann, Ident), Expr Ann)], Any) -applyLazinessTransform mn rawItems = let - - -- Establish the mapping from names to ints. - rawItemsByName :: M.MonoidalMap Ident (Ann, Expr Ann) - rawItemsByName = M.fromList $ (snd . fst &&& first fst) <$> rawItems - - maxIdx = M.size rawItemsByName - 1 - - rawItemsByIndex :: A.Array Int (Ann, Expr Ann) - rawItemsByIndex = A.listArray (0, maxIdx) $ M.elems rawItemsByName - - names :: S.Set Ident - names = M.keysSet rawItemsByName - - -- Now do the first delay/force traversal of all the bindings to find - -- references to other names in this binding group. - -- - -- The parts of this type mean: - -- D is the maximum force (or Nothing if unknown) with which the identifier C - -- is referenced in any delay-B position inside the expression A. - -- - -- where A, B, C, and D are as below: - -- A B (keys) C (keys) D - findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) - findReferences = (getConst .) . onVarsWithDelayAndForce $ \delay force _ -> \case - Qualified qb ident | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names - -> Const . IM.singleton delay . IM.singleton i $ coerceForce force - _ -> Const IM.empty - - -- The parts of this type mean: - -- D is the maximum force (or Nothing if unknown) with which the identifier C - -- is referenced in any delay-B position inside the binding of identifier A. - -- - -- where A, B, C, and D are as below: - -- A B (keys) C (keys) D - refsByIndex :: A.Array Int (IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int)))) - refsByIndex = findReferences . snd <$> rawItemsByIndex - - -- Using the approach explained above, traverse the reference graph generated - -- by `refsByIndex` and find all reachable names. - -- - -- The parts of this type mean: - -- D is the maximum force with which the identifier C is referenced, - -- directly or indirectly, during the initialization of identifier A. B is - -- Nothing if the analysis of A was inconclusive and A might need the entire - -- binding group. - -- - -- where A, B, C, and D are as below: - -- A B C (keys) D - reachablesByIndex :: A.Array Int (Maybe (IM.MonoidalIntMap (Max Int))) - reachablesByIndex = searchReachable maxIdx $ \(i, force) -> - getAp . flip IM.foldMapWithKey (dropKeysAbove force $ refsByIndex A.! i) $ \delay -> - IM.foldMapWithKey $ \i' force' -> - Ap $ IM.singleton i' . Max . (force - delay +) <$> uncoerceForce force' - - -- If `reachablesByIndex` is a sort of labeled relation, this function - -- produces part of the reverse relation, but only for the edges from the - -- given vertex. - -- - -- The parts of this type mean: - -- The identifier A is reachable from the identifier B with maximum force C - -- (B is also the index provided to the function). - -- - -- where A, B, and C are as below: - -- (B) A B (singleton key) C - reverseReachablesFor :: Int -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) - reverseReachablesFor i = case reachablesByIndex A.! i of - Nothing -> IM.fromAscList $ (, IM.singleton i $ Ap Nothing) <$> [0..maxIdx] - Just im -> IM.singleton i . Ap . Just <$> im - - -- We can use `reachablesByIndex` to build a finite graph and topsort it; - -- in the process, we'll pack the nodes of the graph with data we'll want - -- next. Remember that if our reachability computation aborted, we have to - -- assume that every other identifier is reachable from that one--hence the - -- `maybe [0..maxIdx]`. - sccs = stronglyConnComp $ do - (i, mbReachable) <- A.assocs reachablesByIndex - pure ((reverseReachablesFor i, (S.elemAt i names, rawItemsByIndex A.! i)), i, maybe [0..maxIdx] (IS.toList . IM.keysSet) mbReachable) - - (replacements, items) = flip foldMap sccs $ \case - -- The easy case: this binding doesn't need to be made lazy after all! - AcyclicSCC (_, (ident, (a, e))) -> pure [(ident, EagerBinding a e)] - -- The tough case: we have a loop. - -- We need to do two things here: - -- * Collect the reversed reachables relation for each vertex in this - -- loop; we'll use this to replace references with force calls - -- * Copy the vertex list into two lists: a list of lazy definitions and - -- a list of lazy bindings - -- Both of these results are monoidal, so the outer `foldMap` will - -- concatenate them pairwise. - CyclicSCC vertices -> (foldMap fst vertices, map (fmap (LazyDefinition . snd) . snd) vertices ++ map (fmap (LazyBinding . fst) . snd) vertices) - - -- We have `replacements` expressed in terms of indices; we want to map it - -- back to names before traversing the bindings again. - replacementsByName :: M.MonoidalMap Ident (M.MonoidalMap Ident (Ap Maybe (Max Int))) - replacementsByName = M.fromAscList . map (bimap (flip S.elemAt names) (M.fromAscList . map (first (flip S.elemAt names)) . IM.toAscList)) . IM.toAscList $ replacements - - -- And finally, this is the second delay/force traversal where we take - -- `replacementsByName` and use it to rewrite references with force calls, - -- but only if the delay of those references is at most the maximum amount - -- of force used by the initialization of the referenced binding to - -- reference the outer binding. A reference made with a higher delay than - -- that can safely continue to use the original reference, since it won't be - -- needed until after the referenced binding is done initializing. - replaceReferencesWithForceCall :: (Ident, RecursiveGroupItem (Expr Ann)) -> (Ident, RecursiveGroupItem (Expr Ann)) - replaceReferencesWithForceCall pair@(ident, item) = case ident `M.lookup` replacementsByName of - Nothing -> pair - Just m -> let - rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ \delay _ ann -> pure . \case - Qualified qb ident' | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m - -> makeForceCall ann ident' - q -> Var ann q - in (ident, rewriteExpr <$> item) - - -- All that's left to do is run the above replacement on every item, - -- translate items from our `RecursiveGroupItem` representation back into the - -- form CoreFn expects, and inform the caller whether we made any laziness - -- transformations after all. (That last bit of information is used to - -- determine if the runtime factory function needs to be injected.) - in (uncurry fromRGI . replaceReferencesWithForceCall <$> items, Any . not $ IM.null replacements) - - where - - nullAnn = ssAnn nullSourceSpan - runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . Qualified (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" - strLit = Literal nullAnn . StringLiteral . mkString - - lazifyIdent = \case - Ident txt -> InternalIdent $ Lazy txt - _ -> internalError "Unexpected argument to lazifyIdent" - - makeForceCall :: Ann -> Ident -> Expr Ann - makeForceCall (ss, _, _) ident - -- We expect the functions produced by `runtimeLazy` to accept one - -- argument: the line number on which this reference is made. The runtime - -- code uses this number to generate a message that identifies where the - -- evaluation looped. - = App nullAnn (Var nullAnn . Qualified ByNullSourcePos $ lazifyIdent ident) - . Literal nullAnn . NumericLiteral . Left . toInteger . sourcePosLine - $ spanStart ss - - fromRGI :: Ident -> RecursiveGroupItem (Expr Ann) -> ((Ann, Ident), Expr Ann) - fromRGI i = \case - EagerBinding a e -> ((a, i), e) - -- We expect the `runtimeLazy` factory to accept three arguments: the - -- identifier being initialized, the name of the module, and of course a - -- thunk that actually contains the initialization code. - LazyDefinition e -> ((nullAnn, lazifyIdent i), foldl1' (App nullAnn) [runFn3, runtimeLazy, strLit $ runIdent i, strLit $ runModuleName mn, Abs nullAnn UnusedIdent e]) - LazyBinding a -> ((a, i), makeForceCall a i) - - dropKeysAbove :: Int -> IM.MonoidalIntMap a -> IM.MonoidalIntMap a - dropKeysAbove n = fst . IM.split (n + 1) - - coerceForce :: Maybe Int -> Ap Maybe (Max Int) - coerceForce = coerce - - uncoerceForce :: Ap Maybe (Max Int) -> Maybe Int - uncoerceForce = coerce diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 722893c4..f5439ee0 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -25,7 +25,7 @@ optimizeModuleDecls = map transformBinds optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of - (App a (App _ (Var _ fn) x) y) - | C.I_functionApply <- fn -> App a x y - | C.I_functionApplyFlipped <- fn -> App a y x + (App a t1 (App _ t2 (Var _ t3 fn) x) y) + | C.I_functionApply <- fn -> App a t1 x y -- NOTE @klntsky not sure about the type here, needs reviewed. I *think* the type shouldn't change? + | C.I_functionApplyFlipped <- fn -> App a t1 y x _ -> e diff --git a/src/Language/PureScript/CoreFn/Typed/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs similarity index 97% rename from src/Language/PureScript/CoreFn/Typed/Pretty.hs rename to src/Language/PureScript/CoreFn/Pretty.hs index a578f6cf..9951334a 100644 --- a/src/Language/PureScript/CoreFn/Typed/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,4 +1,4 @@ -module Language.PureScript.CoreFn.Typed.Pretty where +module Language.PureScript.CoreFn.Pretty where import Prelude hiding ((<>)) @@ -10,8 +10,8 @@ import Data.Monoid qualified as Monoid ((<>)) import Data.Text qualified as T import Language.PureScript.Environment -import Language.PureScript.CoreFn.Typed.Expr -import Language.PureScript.CoreFn.Typed.Module +import Language.PureScript.CoreFn.Expr +import Language.PureScript.CoreFn.Module import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders import Language.PureScript.Crash (internalError) @@ -109,12 +109,12 @@ prettyPrintDeclaration :: Int -> Bind a -> Box prettyPrintDeclaration d b = case b of NonRec _ ident expr -> vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here ] Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), + text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr ]) bindings @@ -153,6 +153,9 @@ prettyPrintModule (Module modSS modComments modName modPath modImports modExport prettyPrintModule' :: Module a -> String prettyPrintModule' = render . prettyPrintModule + +renderExpr :: Int -> Expr a -> String +renderExpr i e = render $ prettyPrintValue i e {- prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v prettyPrintResult gs = diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 1b20ac4e..b7a1fc70 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -162,50 +162,59 @@ recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value recordToJSON f = toJSON . map (toJSON *** f) exprToJSON :: Expr Ann -> Value -exprToJSON (Var ann i) = object [ "type" .= toJSON "Var" +exprToJSON (Var ann ty i) = object [ "kind" .= toJSON "Var" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "value" .= qualifiedToJSON runIdent i ] -exprToJSON (Literal ann l) = object [ "type" .= "Literal" +exprToJSON (Literal ann ty l) = object [ "kind" .= "Literal" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "value" .= literalToJSON exprToJSON l ] -exprToJSON (Constructor ann d c is) = object [ "type" .= "Constructor" +exprToJSON (Constructor ann ty d c is) = object [ "kind" .= "Constructor" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "typeName" .= properNameToJSON d , "constructorName" .= properNameToJSON c , "fieldNames" .= map identToJSON is ] -exprToJSON (Accessor ann f r) = object [ "type" .= "Accessor" +exprToJSON (Accessor ann ty f r) = object [ "kind" .= "Accessor" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "fieldName" .= f , "expression" .= exprToJSON r ] -exprToJSON (ObjectUpdate ann r copy fs) - = object [ "type" .= "ObjectUpdate" +exprToJSON (ObjectUpdate ann ty r copy fs) + = object [ "kind" .= "ObjectUpdate" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "expression" .= exprToJSON r , "copy" .= toJSON copy , "updates" .= recordToJSON exprToJSON fs ] -exprToJSON (Abs ann p b) = object [ "type" .= "Abs" +exprToJSON (Abs ann ty p b) = object [ "kind" .= "Abs" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "argument" .= identToJSON p , "body" .= exprToJSON b ] -exprToJSON (App ann f x) = object [ "type" .= "App" +exprToJSON (App ann ty f x) = object [ "kind" .= "App" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "abstraction" .= exprToJSON f , "argument" .= exprToJSON x ] -exprToJSON (Case ann ss cs) = object [ "type" .= "Case" +exprToJSON (Case ann ty ss cs) = object [ "kind" .= "Case" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "caseExpressions" .= map exprToJSON ss , "caseAlternatives" .= map caseAlternativeToJSON cs ] -exprToJSON (Let ann bs e) = object [ "type" .= "Let" +exprToJSON (Let ann ty bs e) = object [ "kind" .= "Let" + , "type" .= toJSON ty , "annotation" .= annToJSON ann , "binds" .= map bindToJSON bs , "expression" .= exprToJSON e diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index f0684d34..288faf12 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -21,13 +21,13 @@ everywhereOnValues f g h = (f', g', h') f' (NonRec a name e) = f (NonRec a name (g' e)) f' (Rec es) = f (Rec (map (second g') es)) - g' (Literal ann e) = g (Literal ann (handleLiteral g' e)) - g' (Accessor ann prop e) = g (Accessor ann prop (g' e)) - g' (ObjectUpdate ann obj copy vs) = g (ObjectUpdate ann (g' obj) copy (map (fmap g') vs)) - g' (Abs ann name e) = g (Abs ann name (g' e)) - g' (App ann v1 v2) = g (App ann (g' v1) (g' v2)) - g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts)) - g' (Let ann ds e) = g (Let ann (map f' ds) (g' e)) + g' (Literal ann t e) = g (Literal ann t (handleLiteral g' e)) + g' (Accessor ann t prop e) = g (Accessor ann t prop (g' e)) + g' (ObjectUpdate ann t obj copy vs) = g (ObjectUpdate ann t (g' obj) copy (map (fmap g') vs)) + g' (Abs ann t name e) = g (Abs ann t name (g' e)) + g' (App ann t v1 v2) = g (App ann t (g' v1) (g' v2)) + g' (Case ann t vs alts) = g (Case ann t (map g' vs) (map handleCaseAlternative alts)) + g' (Let ann t ds e) = g (Let ann t (map f' ds) (g' e)) g' e = g e h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b)) @@ -64,13 +64,13 @@ traverseCoreFn f g h i = (f', g', h', i') f' (NonRec a name e) = NonRec a name <$> g e f' (Rec es) = Rec <$> traverse (traverse g) es - g' (Literal ann e) = Literal ann <$> handleLiteral g e - g' (Accessor ann prop e) = Accessor ann prop <$> g e - g' (ObjectUpdate ann obj copy vs) = (\obj' -> ObjectUpdate ann obj' copy) <$> g obj <*> traverse (traverse g) vs - g' (Abs ann name e) = Abs ann name <$> g e - g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 - g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts - g' (Let ann ds e) = Let ann <$> traverse f ds <*> g' e + g' (Literal ann t e) = Literal ann t <$> handleLiteral g e + g' (Accessor ann t prop e) = Accessor ann t prop <$> g e + g' (ObjectUpdate ann t obj copy vs) = (\obj' -> ObjectUpdate ann t obj' copy) <$> g obj <*> traverse (traverse g) vs + g' (Abs ann t name e) = Abs ann t name <$> g e + g' (App ann t v1 v2) = App ann t <$> g v1 <*> g v2 + g' (Case ann t vs alts) = Case ann t <$> traverse g vs <*> traverse i alts + g' (Let ann t ds e) = Let ann t <$> traverse f ds <*> g' e g' e = pure e h' (LiteralBinder a b) = LiteralBinder a <$> handleLiteral h b diff --git a/src/Language/PureScript/CoreFn/Typed.hs b/src/Language/PureScript/CoreFn/Typed.hs deleted file mode 100644 index b0bcc66b..00000000 --- a/src/Language/PureScript/CoreFn/Typed.hs +++ /dev/null @@ -1,495 +0,0 @@ -{- This module is a part of a hack intended to solve a problem arising from the structure of the PS compiler pipeline: - - We need CoreFn `Expr (Type Ann)` which contains annotates AST nodes with inferred type information - - PS performs typechecking on the Language.PureScript.AST Expr type, which we don't have access to in the `codegen` function part of the pipeline - - We need to modify the AST -> CoreFn desguaring phase so that it annotates the AST w/ type information - - The most sensible way to do that is to do inference & conversion all at once during typechecking - - We can't do that without disassembling the `moduleToCoreFn` function from the Desugar module - -This is a very rough draft ATM. In a more polished version these should all be rewritten to `Reader Env (...)` functions - --} - -module Language.PureScript.CoreFn.Typed (moduleToCoreFn) where - -import Prelude -import Protolude (ordNub, orEmpty) - - -import Data.Function (on) -import Data.Maybe (mapMaybe) -import Data.Tuple (swap) -import Data.List.NonEmpty qualified as NEL -import Data.Map qualified as M - -import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) -import Language.PureScript.AST.Traversals (everythingOnValues) -import Language.PureScript.CoreFn.Ann (Ann, ssAnn) -import Language.PureScript.CoreFn.Binders (Binder(..)) -import Language.PureScript.CoreFn.Typed.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, PurusType) -import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) -import Language.PureScript.CoreFn.Typed.Module (Module(..)) -import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean) -import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, mkQualified) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) -import Language.PureScript.AST.Binders qualified as A -import Language.PureScript.AST.Declarations qualified as A -import Language.PureScript.AST.SourcePos qualified as A -import Language.PureScript.Constants.Prim qualified as C -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Strict (MonadState, gets, modify) -import Control.Monad.Writer.Class ( MonadWriter ) -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible) -import Control.Monad.Error (MonadError) -import Language.PureScript.TypeChecker.Types - ( kindType, - checkTypeKind, - freshTypeWithKind, - SplitBindingGroup(SplitBindingGroup), - TypedValue'(TypedValue'), - BindingGroupType(RecursiveBindingGroup), - typesOf, - typeDictionaryForBindingGroup, - checkTypedBindingGroupElement, - typeForBindingGroupElement, - infer, - check ) -import Data.List.NonEmpty qualified as NE -import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) -import Control.Monad (forM, (<=<)) -import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) -import Language.PureScript.Errors (MultipleErrors, parU) -import Debug.Trace (traceM) -import Language.PureScript.Pretty.Types ( prettyPrintType ) -type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - -purusTy :: Type a -> PurusType -purusTy = fmap (const ()) - - -unFun :: Type a -> Either (Type a) (Type a,Type a) -unFun = \case - TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) - other -> Left other - --- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module --- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. - --- | Desugars a module from AST to CoreFn representation. -moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) -moduleToCoreFn (A.Module _ _ _ _ Nothing) = - internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do - setModuleName - let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) - imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls - exps' = ordNub $ concatMap exportToCoreFn exps - reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) - externs = ordNub $ mapMaybe externToCoreFn decls - decls' <- concat <$> traverse (declToCoreFn mn) decls - - {- - let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) - imports' = dedupeImports imports - exps' = ordNub $ concatMap exportToCoreFn exps - reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) - externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap (declToCoreFn env mn) decls - in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' -} - pure $ Module modSS coms mn (spanName modSS) imports exps' reExps externs decls' - where - setModuleName = modify $ \cs -> - cs {checkCurrentModule = Just mn} - -- Creates a map from a module name to the re-export references defined in - -- that module. -reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] -reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') - -toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) -toReExportRef (A.ReExportRef _ src ref) = - fmap - (, ref) - (A.exportSourceImportedFrom src) -toReExportRef _ = Nothing - - -- Remove duplicate imports -dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] -dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap - -ssA :: SourceSpan -> Ann -ssA ss = (ss, [], Nothing) - - -lookupType :: M m => ModuleName -> ProperName 'TypeName -> m SourceType -lookupType mn tn = do - env <- gets checkEnv - case M.lookup (mkQualified tn mn) (types env) of - Nothing -> error $ "No type found for " <> show tn - Just (ty,kind) -> pure ty - -lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType -lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do - env <- gets checkEnv - case M.lookup (mkQualified ctorName mn) (dataConstructors env) of - Nothing -> error $ "No constr decl info found for " <> show ctorName - Just (_declType,_tyName,ty,_idents) -> pure ty - -moduleName :: M m => m ModuleName -moduleName = gets checkCurrentModule >>= \case - Just mn -> pure mn - Nothing -> error "No module name found in checkState" - --- Desugars member declarations from AST to CoreFn representation. -declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] -declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dataCtorFields ctor of - [(_,wrappedTy)] -> do - -- declTy <- lookupType mn name // might need this? - let innerFunTy = purusFun wrappedTy wrappedTy - pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] - _ -> error "Found newtype with multiple fields" - where - declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor -declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = - error $ "Found newtype with multiple constructors: " ++ show d -declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = - traverse go ctors - where - go ctorDecl = do - env <- gets checkEnv - let ctor = A.dataCtorName ctorDecl - (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - -- ctorDeclTy <- lookupCtorDeclTy mn ctorDecl - pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields -declToCoreFn mn (A.DataBindingGroupDeclaration ds) = - concat <$> traverse (declToCoreFn mn) ds -declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do - traceM $ "decltoCoreFn " <> show name - env <- gets checkEnv - let mValDeclTy = lookupValue env (mkQualified name mn) - case mValDeclTy of - Just(valDeclTy,nameKind,nameVis) -> bindLocalVariables [(ss,name,valDeclTy,nameVis)] $ do - expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? - pure $ [NonRec (ssA ss) name expr] - Nothing -> error $ "No type found for value declaration " <> show name -declToCoreFn mn (A.BindingGroupDeclaration ds) = do - let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds - types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident - recBody <- traverse goRecBindings types - pure [Rec recBody] - where - goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) - goRecBindings ((ann,ident),(expr,ty)) = do - expr' <- exprToCoreFn mn (fst ann) (Just ty) expr - pure ((ssA $ fst ann,ident), expr') -declToCoreFn _ _ = pure [] - -traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) -traverseLit f = \case - NumericLiteral x -> pure $ NumericLiteral x - StringLiteral x -> pure $ StringLiteral x - CharLiteral x -> pure $ CharLiteral x - BooleanLiteral x -> pure $ BooleanLiteral x - ArrayLiteral xs -> ArrayLiteral <$> traverse f xs - ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs - -inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType -inferType (Just t) _ = pure t -inferType Nothing e = infer e >>= \case - TypedValue' _ _ t -> pure t - --- Desugars expressions from AST to CoreFn representation. -exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) -exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = do - litT <- purusTy <$> inferType mTy astLit - lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit - pure $ Literal (ss, [], Nothing) litT lit' - -exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = do - expT <- purusTy <$> inferType mTy accessor - expr <- exprToCoreFn mn ss Nothing v - pure $ Accessor (ssA ss) expT name expr - -exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do - expT <- purusTy <$> inferType mTy objUpd - obj' <- exprToCoreFn mn ss Nothing obj - vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs - pure $ - ObjectUpdate - (ssA ss) - expT - obj' - (mTy >>= unchangedRecordFields (fmap fst vs)) - vs' - where - -- Return the unchanged labels of a closed record, or Nothing for other types or open records. - unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] - unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = - collect row - where - collect :: Type a -> Maybe [PSString] - collect (REmptyKinded _ _) = Just [] - collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r - collect _ = Nothing - unchangedRecordFields _ _ = Nothing -exprToCoreFn mn ss mTy lam@(A.Abs (A.VarBinder ssb name) v) = do - traceM $ "exprToCoreFn lam " <> (show name) - (unFun <$> inferType mTy lam) >>= \case - Right (a,b) -> do - traceM $ "function lam " <> prettyPrintType 0 (purusFun a b) - let toBind = [(ssb, name, a, Defined )] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body - Left ty -> do - traceM $ "??? lam " <> prettyPrintType 0 ty - body <- exprToCoreFn mn ss (Just ty) v - pure $ Abs (ssA ssb) (purusTy ty) name body - -exprToCoreFn _ _ _ (A.Abs _ _) = - internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" -exprToCoreFn mn ss mTy app@(A.App v1 v2) = do - appT <- inferType mTy app - v1' <- exprToCoreFn mn ss Nothing v1 - v2' <- exprToCoreFn mn ss Nothing v2 - pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' - where - isDictCtor = \case - A.Constructor _ (Qualified _ name) -> isDictTypeName name - _ -> False - isSynthetic = \case - A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 - A.Accessor _ v3 -> isSynthetic v3 - A.Var NullSourceSpan _ -> True - A.Unused{} -> True - _ -> False -exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ - error "Don't know what to do w/ exprToCoreFn A.Unused" - -- pure $ Var (ss, com, Nothing) C.I_undefined -exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> - pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident -exprToCoreFn mn _ _ (A.Var ss ident) = - gets checkEnv >>= \env -> case lookupValue env ident of - Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident - Nothing -> error $ "No known type for identifier " <> show ident -exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do - ifteTy <- inferType mTy ifte - condE <- exprToCoreFn mn ss (Just tyBoolean) cond - thE <- exprToCoreFn mn ss Nothing th - elE <- exprToCoreFn mn ss Nothing el - pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] - [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it - (Right thE) - , CaseAlternative [NullBinder (ssAnn ss)] -- * - (Right elE) ] -exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = do - env <- gets checkEnv - let ctorMeta = getConstructorMeta env name - ctorType <- inferType mTy ctor - pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name -exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = do - caseTy <- inferType mTy astCase - vs' <- traverse (exprToCoreFn mn ss Nothing) vs - alts' <- traverse (altToCoreFn mn ss) alts - pure $ Case (ssA ss) (purusTy caseTy) vs' alts' -exprToCoreFn mn ss _ (A.TypedValue _ v ty) = - exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = do - letTy <- inferType mTy astLet - (ds', expr) <- transformLetBindings mn ss [] ds v - pure $ Let (ss, [], getLetMeta w) (purusTy letTy) ds' expr -exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = - exprToCoreFn mn ss ty v -exprToCoreFn _ _ _ e = - error $ "Unexpected value in exprToCoreFn mn: " ++ show e - -transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) -transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) --- for typed values (this might be wrong?) -transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do - TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do - ((args, elabTy), kind) <- kindOfWithScopedVars ty - checkTypeKind ty kind - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy - if checkType - then withScopedTypeVars mn args $ bindNames dict $ check val ty' - else return (TypedValue' checkType val elabTy) - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val' ty'')]) - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret --- untyped values -transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = do - valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) - bindNames dict $ infer val - warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret -transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = do - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds - ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] - bindNames dict $ do - makeBindingGroupVisible - thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret -transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" - - --- Desugars case alternatives from AST to CoreFn representation. -altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann) -altToCoreFn mn ss (A.CaseAlternative bs vs) = do - env <- gets checkEnv - let binders = binderToCoreFn env mn ss <$> bs - ege <- go vs - pure $ CaseAlternative binders ege - where - go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) - go [A.MkUnguarded e] = do - expr <- exprToCoreFn mn ss Nothing e - pure $ Right expr - go gs = do - ges <- forM gs $ \case - A.GuardedExpr g e -> do - let cond = guardToExpr g - condE <- exprToCoreFn mn ss Nothing cond - eE <- exprToCoreFn mn ss Nothing e - pure (condE,eE) - pure . Left $ ges - guardToExpr [A.ConditionGuard cond] = cond - guardToExpr _ = internalError "Guard not correctly desugared" - --- This should ONLY ever be used to create a type in contexts where one doesn't make sense -tUnknown :: forall a. a -> Type a -tUnknown x = TUnknown x (-1) - --- I'm not sure how to type Binders. Likely we need a new syntatic construct? But if the sub-terms are well-typed we should be able to give binder a placeholder type? idk --- Desugars case binders from AST to CoreFn representation. -binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann -binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = - let lit' = binderToCoreFn env mn ss <$> lit - ty = tUnknown (ss,[]) - in LiteralBinder (ss, [], Nothing) lit' -binderToCoreFn _ mn ss A.NullBinder = - let ty = tUnknown (ss,[]) - in NullBinder (ss, [], Nothing) -binderToCoreFn _ mn _ss (A.VarBinder ss name) = - let ty = tUnknown (ss,[]) - in VarBinder (ss, [], Nothing) name -binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = - let (_, tctor, _, _) = lookupConstructor env dctor - ty = tUnknown (ss,[]) - args = binderToCoreFn env mn _ss <$> bs - in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args -binderToCoreFn env mn _ss (A.NamedBinder ss name b) = - let ty = tUnknown (ss,[]) - arg = binderToCoreFn env mn _ss b - in NamedBinder (ss, [], Nothing) name arg -binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = - binderToCoreFn env mn ss b -binderToCoreFn env mn ss (A.TypedBinder _ b) = - binderToCoreFn env mn ss b -binderToCoreFn _ _ _ A.OpBinder{} = - internalError "OpBinder should have been desugared before binderToCoreFn" -binderToCoreFn _ _ _ A.BinaryNoParensBinder{} = - internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" -binderToCoreFn _ _ _ A.ParensInBinder{} = - internalError "ParensInBinder should have been desugared before binderToCoreFn" - --- Gets metadata for let bindings. -getLetMeta :: A.WhereProvenance -> Maybe Meta -getLetMeta A.FromWhere = Just IsWhere -getLetMeta A.FromLet = Nothing - --- Gets metadata for values. -getValueMeta :: Environment -> Qualified Ident -> Maybe Meta -getValueMeta env name = - case lookupValue env name of - Just (_, External, _) -> Just IsForeign - _ -> Nothing - --- Gets metadata for data constructors. -getConstructorMeta :: Environment -> Qualified (ProperName 'ConstructorName) -> Meta -getConstructorMeta env ctor = - case lookupConstructor env ctor of - (Newtype, _, _, _) -> IsNewtype - dc@(Data, _, _, fields) -> - let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType - in IsConstructor constructorType fields - where - - numConstructors - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> Int - numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env - - typeConstructor - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) - typeConstructor _ = internalError "Invalid argument to typeConstructor" - --- | Find module names from qualified references to values. This is used to --- ensure instances are imported from any module that is referenced by the --- current module, not just from those that are imported explicitly (#667). -findQualModules :: [A.Declaration] -> [ModuleName] -findQualModules decls = - let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in f `concatMap` decls - -fqDecls :: A.Declaration -> [ModuleName] -fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q -fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q -fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q -fqDecls _ = [] - -fqValues :: A.Expr -> [ModuleName] -fqValues (A.Var _ q) = getQual' q -fqValues (A.Constructor _ q) = getQual' q -fqValues _ = [] - -fqBinders :: A.Binder -> [ModuleName] -fqBinders (A.ConstructorBinder _ q _) = getQual' q -fqBinders _ = [] - -getQual' :: Qualified a -> [ModuleName] -getQual' = maybe [] return . getQual - --- | Desugars import declarations from AST to CoreFn representation. -importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) --- TODO: We probably *DO* want types here -importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) -importToCoreFn _ = Nothing - --- | Desugars foreign declarations from AST to CoreFn representation. -externToCoreFn :: A.Declaration -> Maybe Ident -externToCoreFn (A.ExternDeclaration _ name _) = Just name -externToCoreFn _ = Nothing - --- | Desugars export declarations references from AST to CoreFn representation. --- CoreFn modules only export values, so all data constructors, instances and --- values are flattened into one list. -exportToCoreFn :: A.DeclarationRef -> [Ident] -exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors -exportToCoreFn (A.TypeRef _ _ Nothing) = [] -exportToCoreFn (A.TypeOpRef _ _) = [] -exportToCoreFn (A.ValueRef _ name) = [name] -exportToCoreFn (A.ValueOpRef _ _) = [] -exportToCoreFn (A.TypeClassRef _ _) = [] -exportToCoreFn (A.TypeInstanceRef _ name _) = [name] -exportToCoreFn (A.ModuleRef _ _) = [] -exportToCoreFn (A.ReExportRef _ _ _) = [] - --- | Converts a ProperName to an Ident. -properToIdent :: ProperName a -> Ident -properToIdent = Ident . runProperName diff --git a/src/Language/PureScript/CoreFn/Typed/Expr.hs b/src/Language/PureScript/CoreFn/Typed/Expr.hs deleted file mode 100644 index 3e969e8f..00000000 --- a/src/Language/PureScript/CoreFn/Typed/Expr.hs +++ /dev/null @@ -1,147 +0,0 @@ -module Language.PureScript.CoreFn.Typed.Expr where -import Prelude - -import Control.Arrow ((***)) - -import GHC.Generics -import Data.Aeson (FromJSON, ToJSON) - - -import Language.PureScript.AST.Literals (Literal) -import Language.PureScript.CoreFn.Binders (Binder) -import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (Type) - - -type PurusType = Type () - --- | --- Data type for expressions and terms --- -data Expr a - -- | - -- A literal value - -- - = Literal a PurusType (Literal (Expr a)) - -- | - -- A data constructor (type name, constructor name, field names) - -- - | Constructor a PurusType (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] - -- | - -- A record property accessor - -- - | Accessor a PurusType PSString (Expr a) - -- | - -- Partial record update (original value, fields to copy (if known), fields to update) - -- - | ObjectUpdate a PurusType (Expr a) (Maybe [PSString]) [(PSString, Expr a)] - -- | - -- Function introduction - -- - | Abs a PurusType Ident (Expr a) - -- | - -- Function application - -- - | App a PurusType (Expr a) (Expr a) - -- | - -- Variable - -- - | Var a PurusType (Qualified Ident) - -- | - -- A case expression - -- - | Case a PurusType [Expr a] [CaseAlternative a] - -- | - -- A let binding - -- - | Let a PurusType [Bind a] (Expr a) - deriving (Eq, Ord, Show, Functor, Generic) - -instance FromJSON a => FromJSON (Expr a) -instance ToJSON a => ToJSON (Expr a) - -exprType :: Expr a -> PurusType -exprType = \case - Literal _ ty _ -> ty - Constructor _ ty _ _ _ -> ty - Accessor _ ty _ _ -> ty - ObjectUpdate _ ty _ _ _ -> ty - Abs _ ty _ _ -> ty - App _ ty _ _ -> ty - Var _ ty __ -> ty - Case _ ty _ _ -> ty - Let _ ty _ _ -> ty - --- | --- A let or module binding. --- -data Bind a - -- | - -- Non-recursive binding for a single value - -- - = NonRec a Ident (Expr a) - -- | - -- Mutually recursive binding group for several values - -- - | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor, Generic) - -instance FromJSON a => FromJSON (Bind a) -instance ToJSON a => ToJSON (Bind a) - --- | --- A guard is just a boolean-valued expression that appears alongside a set of binders --- -type Guard a = Expr a - --- | --- An alternative in a case statement --- -data CaseAlternative a = CaseAlternative - { -- | - -- A collection of binders with which to match the inputs - -- - caseAlternativeBinders :: [Binder a] - -- | - -- The result expression or a collect of guarded expressions - -- - , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Eq, Ord, Show, Generic) - -instance FromJSON a => FromJSON (CaseAlternative a) -instance ToJSON a => ToJSON (CaseAlternative a) - -instance Functor CaseAlternative where - - fmap f (CaseAlternative cabs car) = CaseAlternative - (fmap (fmap f) cabs) - (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car) - --- | --- Extract the annotation from a term --- -extractAnn :: Expr a -> a -extractAnn (Literal a _ _) = a -extractAnn (Constructor a _ _ _ _) = a -extractAnn (Accessor a _ _ _) = a -extractAnn (ObjectUpdate a _ _ _ _) = a -extractAnn (Abs a _ _ _) = a -extractAnn (App a _ _ _) = a -extractAnn (Var a _ _) = a -extractAnn (Case a _ _ _) = a -extractAnn (Let a _ _ _) = a - - --- | --- Modify the annotation on a term --- -modifyAnn :: (a -> a) -> Expr a -> Expr a -modifyAnn f (Literal a b c) = Literal (f a) b c -modifyAnn f (Constructor a b c d e) = Constructor (f a) b c d e -modifyAnn f (Accessor a b c d) = Accessor (f a) b c d -modifyAnn f (ObjectUpdate a b c d e) = ObjectUpdate (f a) b c d e -modifyAnn f (Abs a b c d) = Abs (f a) b c d -modifyAnn f (App a b c d) = App (f a) b c d -modifyAnn f (Var a b c) = Var (f a) b c -modifyAnn f (Case a b c d) = Case (f a) b c d -modifyAnn f (Let a b c d) = Let (f a) b c d diff --git a/src/Language/PureScript/CoreFn/Typed/Module.hs b/src/Language/PureScript/CoreFn/Typed/Module.hs deleted file mode 100644 index 439416d1..00000000 --- a/src/Language/PureScript/CoreFn/Typed/Module.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Language.PureScript.CoreFn.Typed.Module where - -import Prelude - -import Data.Map.Strict (Map) - -import Language.PureScript.AST.SourcePos (SourceSpan) -import Language.PureScript.Comments (Comment) -import Language.PureScript.CoreFn.Typed.Expr (Bind) -import Language.PureScript.Names (Ident, ModuleName) - --- | --- The CoreFn module representation --- -data Module a = Module - { moduleSourceSpan :: SourceSpan - , moduleComments :: [Comment] - , moduleName :: ModuleName - , modulePath :: FilePath - , moduleImports :: [(a, ModuleName)] - , moduleExports :: [Ident] - , moduleReExports :: Map ModuleName [Ident] - , moduleForeign :: [Ident] - , moduleDecls :: [Bind a] - } deriving (Functor, Show) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 157d03a6..aa5ee7ae 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -33,12 +33,12 @@ import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..) import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Convert qualified as Docs -import Language.PureScript.Environment (initEnvironment) +import Language.PureScript.Environment (initEnvironment, Environment(..)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) import Language.PureScript.Linter (Name(..), lint, lintImports) import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) -import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName) +import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName, showIdent, showQualified) import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) @@ -48,14 +48,15 @@ import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF -import Language.PureScript.CoreFn.Typed qualified as CFT -import Language.PureScript.CoreFn.Typed.Pretty qualified as CFT -import Language.PureScript.CoreFn.Typed.Module qualified as CFT +import Language.PureScript.CoreFn qualified as CFT +import Language.PureScript.CoreFn.Pretty qualified as CFT +import Language.PureScript.CoreFn.Module qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) -- Temporary import Debug.Trace (traceM) +import Language.PureScript.CoreFn.Pretty (ppType) -- | Rebuild a single module. -- @@ -91,7 +92,6 @@ rebuildModuleWithIndex -> Maybe (Int, Int) -> m ExternsFile rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do - traceM "hi" progress $ CompilingModule moduleName moduleIndex let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m @@ -118,11 +118,11 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps - ((coreFnTyped,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') - traceM "boom?" - mapM_ (traceM . show) . CFT.moduleDecls $ coreFnTyped - traceM $ CFT.prettyPrintModule' coreFnTyped - let corefn = CF.moduleToCoreFn env' mod' + ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') + traceM $ prettyEnv (checkEnv chkSt) + --mapM_ (traceM . show) . CFT.moduleDecls $ coreFn + traceM $ CFT.prettyPrintModule' coreFn + let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized exts = moduleToExternsFile mod' env' renamedIdents @@ -143,6 +143,18 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ evalSupplyT nextVar''' $ codegen renamed docs exts return exts + where + prettyEnv :: Environment -> String + prettyEnv Environment{..} = M.foldlWithKey' goPretty "" names + where + goPretty acc ident (ty,_,_) = + acc + <> "\n" + <> T.unpack (showQualified showIdent ident) + <> " :: " + <> ppType 10 ty + + -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. -- diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 1cca61b2..6739b4bf 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -32,12 +32,10 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Text.Encoding qualified as TE import Data.Time.Clock (UTCTime) -import Data.Version (showVersion) +import Data.Version (showVersion, makeVersion) import Language.JavaScript.Parser qualified as JS import Language.PureScript.AST (SourcePos(..)) import Language.PureScript.Bundle qualified as Bundle -import Language.PureScript.CodeGen.JS qualified as J -import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps) import Language.PureScript.CodeGen.UPLC qualified as PC import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.ToJSON qualified as CFJ @@ -59,6 +57,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix import System.IO (stderr) +import Language.PureScript.CoreFn.ToJSON (moduleToJSON) -- | Determines when to rebuild a module data RebuildPolicy @@ -204,8 +203,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = targetFilename mn = \case JS -> outputFilename mn "index.js" JSSourceMap -> outputFilename mn "index.js.map" - CoreFn -> outputFilename mn "corefn.json" + -- CoreFn -> outputFilename mn "corefn.json" Docs -> outputFilename mn "docs.json" + UPLC -> outputFilename mn "index.cfn" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -251,11 +251,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts codegenTargets <- lift $ asks optionsCodegenTargets - when (S.member CoreFn codegenTargets) $ do - let coreFnFile = targetFilename mn CoreFn + when (S.member UPLC codegenTargets) $ do + let coreFnFile = targetFilename mn UPLC json = CFJ.moduleToJSON Paths.version m lift $ writeJSONFile coreFnFile json - when (S.member JS codegenTargets) $ do + {- + when (S.member JS codegenTargets) $ do foreignInclude <- case mn `M.lookup` foreigns of Just _ | not $ requiresForeign m -> do @@ -264,7 +265,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = return $ Just "./foreign.js" Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing - rawJs <- J.moduleToJs m foreignInclude + rawJs <- J.moduleToJs m foreignInclude dir <- lift $ makeIO "get the current directory" getCurrentDirectory let sourceMaps = S.member JSSourceMap codegenTargets (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) @@ -276,11 +277,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = lift $ do writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + -} when (S.member Docs codegenTargets) $ do lift $ writeJSONFile (outputFilename mn "docs.json") docs when (S.member UPLC codegenTargets) $ do - uplc <- PC.moduleToUPLC m - lift $ PC.printUPLC uplc + lift $ writeJSONFile (targetFilename mn UPLC) (moduleToJSON (makeVersion [0,0,1]) m) + -- uplc <- PC.moduleToUPLC m + -- lift $ PC.printUPLC uplc ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index f3a50d86..059b27fb 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -20,7 +20,7 @@ data Options = Options defaultOptions :: Options defaultOptions = Options False False (S.singleton JS) -data CodegenTarget = JS | JSSourceMap | CoreFn | Docs | UPLC +data CodegenTarget = JS | JSSourceMap | Docs | UPLC deriving (Eq, Ord, Show) codegenTargets :: Map String CodegenTarget @@ -28,6 +28,6 @@ codegenTargets = Map.fromList [ ("js", JS) , ("uplc", UPLC) , ("sourcemaps", JSSourceMap) - , ("corefn", CoreFn) + -- , ("corefn", CoreFn) , ("docs", Docs) ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index f40b9b93..fafc3a2f 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -17,6 +17,7 @@ module Language.PureScript.Pretty.Types ) where import Prelude hiding ((<>)) +import Prelude qualified as P import Control.Arrow ((<+>)) import Control.Lens (_2, (%~)) @@ -36,7 +37,6 @@ import Language.PureScript.Label (Label(..)) import Text.PrettyPrint.Boxes (Box(..), hcat, hsep, left, moveRight, nullBox, render, text, top, vcat, (<>)) -import Debug.Trace data PrettyPrintType = PPTUnknown Int @@ -121,7 +121,7 @@ constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTy -- Generate a pretty-printed string representing a Row -- prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box -prettyPrintRowWith tro open close labels rest = trace ("prettyPrintRowWith: \n" `mappend` show labels `mappend` "\n" `mappend` show rest) $ +prettyPrintRowWith tro open close labels rest = case (labels, rest) of ([], Nothing) -> if troRowAsDiff tro then text [ open, ' ' ] <> text "..." <> text [ ' ', close ] else text [ open, close ] @@ -195,7 +195,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = | suggesting = Just $ text "_" | otherwise = Just $ text $ 't' : show u match (PPSkolem name s) - | suggesting = Just $ text $ T.unpack name + | suggesting = Just $ text $ "skolem[" P.<> show s P.<> "]=" P.<> T.unpack name | otherwise = Just $ text $ T.unpack name ++ show s match (PPRecord labels tail_) = Just $ prettyPrintRowWith tro '{' '}' labels tail_ match (PPRow labels tail_) = Just $ prettyPrintRowWith tro '(' ')' labels tail_ diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index a54e39f1..cd7bdfd8 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -161,28 +161,28 @@ renameInDecls = -- Renames within a value. -- renameInValue :: Expr Ann -> Rename (Expr Ann) -renameInValue (Literal ann l) = - Literal ann <$> renameInLiteral renameInValue l +renameInValue (Literal ann t l) = + Literal ann t <$> renameInLiteral renameInValue l renameInValue c@Constructor{} = return c -renameInValue (Accessor ann prop v) = - Accessor ann prop <$> renameInValue v -renameInValue (ObjectUpdate ann obj copy vs) = - (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs -renameInValue (Abs ann name v) = - newScope $ Abs ann <$> updateScope name <*> renameInValue v -renameInValue (App ann v1 v2) = - App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = +renameInValue (Accessor ann t prop v) = + Accessor ann t prop <$> renameInValue v +renameInValue (ObjectUpdate ann t obj copy vs) = + (\obj' -> ObjectUpdate ann t obj' copy) <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs +renameInValue (Abs ann t name v) = + newScope $ Abs ann t <$> updateScope name <*> renameInValue v +renameInValue (App ann t v1 v2) = + App ann t <$> renameInValue v1 <*> renameInValue v2 +renameInValue (Var ann t (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = -- This should only rename identifiers local to the current module: either -- they aren't qualified, or they are but they have a name that should not -- have appeared in a module's externs, so they must be from this module's -- top-level scope. - Var ann . Qualified qb <$> lookupIdent name + Var ann t . Qualified qb <$> lookupIdent name renameInValue v@Var{} = return v -renameInValue (Case ann vs alts) = - newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts -renameInValue (Let ann ds v) = - newScope $ Let ann <$> renameInDecls ds <*> renameInValue v +renameInValue (Case ann t vs alts) = + newScope $ Case ann t <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts +renameInValue (Let ann t ds v) = + newScope $ Let ann t <$> renameInDecls ds <*> renameInValue v -- | -- Renames within literals. From 822c6d40f8da26697a1f14b14c61c2a87d31a5ac Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 17 Jan 2024 20:57:40 -0500 Subject: [PATCH 09/44] Let bindings/declaration groups debugging, working on quantifier preservation issues --- src/Language/PureScript/CoreFn/Desugar.hs | 141 ++++++++++++++++------ src/Language/PureScript/CoreFn/Pretty.hs | 2 +- src/Language/PureScript/Environment.hs | 1 + src/Language/PureScript/Make.hs | 1 + src/Language/PureScript/Pretty/Values.hs | 7 +- 5 files changed, 110 insertions(+), 42 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index baed6715..b05de1fd 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -21,7 +21,7 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, mkQualified, showIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST.Binders qualified as A @@ -29,9 +29,9 @@ import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A import Language.PureScript.Constants.Prim qualified as C import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Strict (MonadState, gets, modify) +import Control.Monad.State.Strict (MonadState, gets, modify, MonadIO (liftIO)) import Control.Monad.Writer.Class ( MonadWriter ) -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible) +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables) import Control.Monad.Error (MonadError) import Language.PureScript.TypeChecker.Types ( kindType, @@ -54,7 +54,7 @@ import Language.PureScript.Errors (MultipleErrors, parU) import Debug.Trace (traceM) import Language.PureScript.CoreFn.Pretty import qualified Data.Text as T -import Language.PureScript.Pretty.Types +import Language.PureScript.Pretty.Values (renderValue) type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) purusTy :: Type a -> PurusType @@ -65,6 +65,8 @@ unFun = \case TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) other -> Left other + + -- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module -- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. @@ -104,14 +106,40 @@ ssA :: SourceSpan -> Ann ssA ss = (ss, [], Nothing) -lookupType :: M m => ModuleName -> Ident -> m (SourceType,NameVisibility) -lookupType mn tn = do +lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibility) +lookupType sp tn = do + mn <- Language.PureScript.CoreFn.Desugar.moduleName env <- gets checkEnv - case M.lookup (mkQualified tn mn) (names env) of - Nothing -> error $ "No type found for " <> show tn + printEnv >>= traceM + case M.lookup (Qualified (BySourcePos sp) tn) (names env) of + Nothing -> case M.lookup (mkQualified tn mn) (names env) of + Nothing -> error $ "No type found for " <> show tn + Just (ty,nk,nv) -> do + traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty + pure (ty,nv) Just (ty,nk,nv) -> do traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty pure (ty,nv) + where + printEnv :: m String + printEnv = do + env <- gets checkEnv + let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env + pure $ concatMap (\(i,st) -> "ENV:= " <> T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st <> "\n") ns + + + +lookupType' :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibility) +lookupType' sp tn = do + traceM $ "lookupType': " <> show tn + env <- gets checkEnv + --traceM $ show env + case M.lookup (Qualified (BySourcePos sp) tn) (names env) of + Nothing -> error $ "(2) No type found for " <> show tn + Just (ty,nk,nv) -> do + traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty + pure (ty,nv) + lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do @@ -154,21 +182,24 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do --traceM $ "decltoCoreFn " <> show name -- env <- gets checkEnv - (valDeclTy,nv) <- lookupType mn name + (valDeclTy,nv) <- lookupType (spanStart ss) name traceM $ "decltoCoreFn " <> show name <> " :: " <> ppType 10 valDeclTy bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? - pure $ [NonRec (ssA ss) name expr] + pure [NonRec (ssA ss) name expr] declToCoreFn mn (A.BindingGroupDeclaration ds) = do let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds - -- types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident - types <- traverse lookupTypes stripped - recBody <- traverse goRecBindings types + types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident + -- types <- traverse lookupTypes stripped + recBody <- bindLocalVariables (prepareBind <$> types) $ traverse goRecBindings types pure [Rec recBody] where - lookupTypes :: ((A.SourceAnn, Ident), A.Expr) -> m ((A.SourceAnn, Ident), (A.Expr, SourceType)) - lookupTypes ((ann,ident),exp) = lookupType mn ident >>= \(ty,_) -> pure ((ann,ident),(exp,ty)) + prepareBind :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> (SourceSpan, Ident, SourceType, NameVisibility) + prepareBind (((ss',_),ident),(e,sty)) = (ss',ident,sty,Defined) + + -- lookupTypes :: ((A.SourceAnn, Ident), A.Expr) -> m ((A.SourceAnn, Ident), (A.Expr, SourceType)) + -- lookupTypes ((ann,ident),exp) = lookupType mn ident >>= \(ty,_) -> pure ((ann,ident),(exp,ty)) goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) goRecBindings ((ann,ident),(expr,ty)) = do @@ -225,24 +256,26 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do collect _ = Nothing unchangedRecordFields _ _ = Nothing exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do - traceM $ "exprToCoreFn lam " <> " :: " <> ppType 10 ty - -- (lam', lamTy) <- instantiatePolyTypeWithUnknowns lam ty - traceM $ "IPTU lamTy: " <> ppType 10 ty - case unFun ty of - Right (a,b) -> do - let toBind = [(ssb, name, a, Defined )] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (purusTy ty) name body - Left e -> case e of - ForAll ann vis var mbK qty mSkol -> do - freshTy <- case mbK of - Nothing -> freshType - Just k -> freshTypeWithKind k - bindLocalVariables [(ssb, (Ident var), freshTy, Defined)] $ do - body <- exprToCoreFn mn ss (Just qty) v - pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbK) (purusTy qty) mSkol) name body - _ -> error "All lambda abstractions should have either a function type or a quantified function type" + traceM $ "exprToCoreFn lam " <> T.unpack (showIdent name) <> " :: " <> ppType 10 ty + + case ty of + ft@(ForAll ann vis var mbk qty mSkol) -> case unFun qty of + Right (a,b) -> do + traceM "ForAll branch" + traceM $ "arg: " <> ppType 10 a + traceM $ "result: " <> ppType 10 b + let toBind = [(ssb, name, a, Defined)] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body + Left e -> error $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e + other -> case unFun other of + Right (a,b) -> do + let toBind = [(ssb, name, a, Defined )] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (purusFun a b) name body + Left e -> error $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e -- error "boom" {- (unFun <$> inferType (Just ty) lam) >>= \case @@ -277,8 +310,8 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) = do exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ error "Don't know what to do w/ exprToCoreFn A.Unused" -- pure $ Var (ss, com, Nothing) C.I_undefined -exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> - pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident +-- exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> +-- pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident exprToCoreFn mn _ _ (A.Var ss ident) = gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident @@ -289,7 +322,7 @@ exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do thE <- exprToCoreFn mn ss Nothing th elE <- exprToCoreFn mn ss Nothing el pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] - [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] -- no clue what the binder type should be but we'll probably never inspect it + [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] (Right thE) , CaseAlternative [NullBinder (ssAnn ss)] -- * (Right elE) ] @@ -307,10 +340,38 @@ exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = exprToCoreFn mn ss (Just ty) v exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = do - letTy <- inferType mTy astLet - (ds', expr) <- transformLetBindings mn ss [] ds v - pure $ Let (ss, [], getLetMeta w) (purusTy letTy) ds' expr +exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = case NE.nonEmpty ds of + Nothing -> error "declarations in a let binding can't be empty" + Just ds' -> do + traceM $ "exprToCoreFn LET: " <> show astLet + types <- typesOf RecursiveBindingGroup mn $ fmap stripDecls ds + traceM $ concatMap (\x -> show x <> "\n\n") types + bindLocalVariables (prepareBind <$> types) $ do + printEnv + expr <- exprToCoreFn mn ss Nothing v + decls <- concat <$> traverse (declToCoreFn mn) (toValueDecl <$> types) + -- (ds', expr) <- transformLetBindings mn ss [] ds v + pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr + where + toValueDecl :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> A.Declaration + toValueDecl ((ss',ident),(exp,ty)) = A.ValueDecl ss' ident Public [] [A.MkUnguarded exp] + + printEnv :: m () + printEnv = do + env <- gets checkEnv + let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env + mapM_ (\(i,st) -> traceM $ T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st) ns + + prepareBind :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> (SourceSpan, Ident, SourceType, NameVisibility) + prepareBind (((ss',_),ident),(e,sty)) = (ss',ident,sty,Defined) + + transformBind :: ((Ann, Ident), Expr Ann) -> (SourceSpan, Ident, SourceType, NameVisibility) + transformBind (((ss',_,_),ident),expr) = (ss',ident,const (ss',[]) <$> exprType expr, Defined) + -- Everything here *should* be a value declaration. I hope? + stripDecls :: A.Declaration-> ((A.SourceAnn, Ident), A.Expr) + stripDecls = \case + A.ValueDecl ann ident nKind [] [A.MkUnguarded e] -> ((ann,ident), e) + other -> error $ "let bindings should only contain value declarations w/ desugared binders and a single expr. this doesn't: " <> show other exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = exprToCoreFn mn ss ty v exprToCoreFn _ _ _ e = diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 9951334a..29d9e8d5 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -75,7 +75,7 @@ prettyPrintValue :: Int -> Expr a -> Box prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps prettyPrintValue d (App ann _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ " -> ") // (prettyPrintValue (d-1) val) +prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") // (prettyPrintValue (d-1) val) prettyPrintValue d (Case ann ty values binders) = (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index ef0b7ea5..4e4e3902 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -378,6 +378,7 @@ pattern a :-> b = getFunArgTy :: Type () -> Type () getFunArgTy = \case a :-> _ -> a + ForAll _ _ _ _ (a :-> _) _ -> a other -> other -- To make reading the kind signatures below easier diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index aa5ee7ae..a808e992 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -118,6 +118,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps + traceM "PURUS START HERE" ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') traceM $ prettyEnv (checkEnv chkSt) --mapM_ (traceM . show) . CFT.moduleDecls $ coreFn diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4d5a5ec6..f8bca7e4 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -5,6 +5,7 @@ module Language.PureScript.Pretty.Values ( prettyPrintValue , prettyPrintBinder , prettyPrintBinderAtom + , renderValue ) where import Prelude hiding ((<>)) @@ -24,7 +25,7 @@ import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintOb import Language.PureScript.Types (Constraint(..)) import Language.PureScript.PSString (PSString, prettyPrintString) -import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, vsep, (//), (<>)) +import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, vsep, (//), (<>), render) -- TODO(Christoph): remove T.unpack s @@ -50,6 +51,10 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val + +renderValue :: Int -> Expr -> String +renderValue d e = render (prettyPrintValue d e) + -- | Pretty-print an expression prettyPrintValue :: Int -> Expr -> Box prettyPrintValue d _ | d < 0 = text "..." From 23fac0a6837c669c3d949dc0d3d48a1e08ccd93b Mon Sep 17 00:00:00 2001 From: gnumonik Date: Fri, 19 Jan 2024 23:43:53 -0500 Subject: [PATCH 10/44] Working on conversion of typeclass dictionaries. (Pretty messy, using this as a temporary work branch) --- purescript.cabal | 1 + src/Language/PureScript/CoreFn/Desugar.hs | 261 ++++++++++++++++------ src/Language/PureScript/Environment.hs | 8 +- 3 files changed, 192 insertions(+), 78 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 2357dc5d..b5ed6000 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -191,6 +191,7 @@ common defaults parsec >=3.1.15.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, process ==1.6.13.1, + pretty-simple, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index b05de1fd..bc868f28 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude @@ -19,11 +20,11 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean) +import Language.PureScript.Environment (pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, dictTypeName, TypeClassData (typeClassArguments), function) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent, coerceProperName) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) +import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), Constraint (..), TypeVarVisibility (..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -31,7 +32,7 @@ import Language.PureScript.Constants.Prim qualified as C import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Strict (MonadState, gets, modify, MonadIO (liftIO)) import Control.Monad.Writer.Class ( MonadWriter ) -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables) +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables, debugEnv) import Control.Monad.Error (MonadError) import Language.PureScript.TypeChecker.Types ( kindType, @@ -55,8 +56,33 @@ import Debug.Trace (traceM) import Language.PureScript.CoreFn.Pretty import qualified Data.Text as T import Language.PureScript.Pretty.Values (renderValue) +import Language.PureScript.TypeClassDictionaries (NamedDict) +import Text.Pretty.Simple (pShowNoColor, pShow) +import qualified Data.Text.Lazy as LT +import Language.PureScript.AST.SourcePos (SourcePos(SourcePos)) +import Language.PureScript.TypeChecker.Monad + type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + +pTrace :: (Monad m, Show a) => a -> m () +pTrace = traceM . LT.unpack . pShow + + +wrapTrace :: Monad m => String -> m a -> m a +wrapTrace msg act = do + traceM startMsg + res <- act + traceM endMsg + pure res + where + padding = replicate 10 '=' + pad str = padding <> str <> padding + startMsg = pad $ "BEGIN " <> msg + endMsg = pad $ "END " <> msg +() :: String -> String -> String +x y = x <> "\n" <> y + purusTy :: Type a -> PurusType purusTy = fmap (const ()) @@ -65,7 +91,15 @@ unFun = \case TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) other -> Left other +getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData +getTypeClassData nm = do + env <- getEnv + case M.lookup nm (typeClasses env) of + Nothing -> error $ "No type class data for " show nm " found in" show (typeClasses env) + Just cls -> pure cls +getTypeClassArgs :: M m => Qualified (ProperName 'ClassName) -> m [(T.Text,Maybe SourceType)] +getTypeClassArgs nm = getTypeClassData nm >>= (pure . typeClassArguments) -- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module -- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. @@ -75,6 +109,7 @@ moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do + -- traceM $ LT.unpack (pShowNoColor mod) setModuleName let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls @@ -110,7 +145,7 @@ lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibil lookupType sp tn = do mn <- Language.PureScript.CoreFn.Desugar.moduleName env <- gets checkEnv - printEnv >>= traceM + -- printEnv >>= traceM case M.lookup (Qualified (BySourcePos sp) tn) (names env) of Nothing -> case M.lookup (mkQualified tn mn) (names env) of Nothing -> error $ "No type found for " <> show tn @@ -129,18 +164,6 @@ lookupType sp tn = do -lookupType' :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibility) -lookupType' sp tn = do - traceM $ "lookupType': " <> show tn - env <- gets checkEnv - --traceM $ show env - case M.lookup (Qualified (BySourcePos sp) tn) (names env) of - Nothing -> error $ "(2) No type found for " <> show tn - Just (ty,nk,nv) -> do - traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty - pure (ty,nv) - - lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do env <- gets checkEnv @@ -149,7 +172,6 @@ lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do Just (_declType,_tyName,ty,_idents) -> pure ty - moduleName :: M m => m ModuleName moduleName = gets checkCurrentModule >>= \case Just mn -> pure mn @@ -157,8 +179,9 @@ moduleName = gets checkCurrentModule >>= \case -- Desugars member declarations from AST to CoreFn representation. declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] -declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dataCtorFields ctor of +declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name args [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of [(_,wrappedTy)] -> do + traceM (show ctor) -- declTy <- lookupType mn name // might need this? let innerFunTy = purusFun wrappedTy wrappedTy pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ @@ -168,7 +191,9 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = case A.dat declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d -declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = +declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do + + traceM $ show ctors traverse go ctors where go ctorDecl = do @@ -177,21 +202,23 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) -- ctorDeclTy <- lookupCtorDeclTy mn ctorDecl pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields -declToCoreFn mn (A.DataBindingGroupDeclaration ds) = +declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DATA GROUP DECL" $ do concat <$> traverse (declToCoreFn mn) ds -declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do +declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do --traceM $ "decltoCoreFn " <> show name -- env <- gets checkEnv (valDeclTy,nv) <- lookupType (spanStart ss) name - traceM $ "decltoCoreFn " <> show name <> " :: " <> ppType 10 valDeclTy + traceM $ ppType 10 valDeclTy + traceM $ renderValue 100 e + pTrace e bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? pure [NonRec (ssA ss) name expr] -declToCoreFn mn (A.BindingGroupDeclaration ds) = do +declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDING GROUP" $ do let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident - -- types <- traverse lookupTypes stripped + --types <- traverse lookupTypes stripped recBody <- bindLocalVariables (prepareBind <$> types) $ traverse goRecBindings types pure [Rec recBody] where @@ -223,17 +250,17 @@ inferType Nothing e = infer e >>= \case -- Desugars expressions from AST to CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) -exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = do +exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do litT <- purusTy <$> inferType mTy astLit lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit pure $ Literal (ss, [], Nothing) litT lit' -exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = do +exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do expT <- purusTy <$> inferType mTy accessor expr <- exprToCoreFn mn ss Nothing v pure $ Accessor (ssA ss) expT name expr -exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do +exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do expT <- purusTy <$> inferType mTy objUpd obj' <- exprToCoreFn mn ss Nothing obj vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs @@ -255,9 +282,42 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = do collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r collect _ = Nothing unchangedRecordFields _ _ = Nothing +exprToCoreFn mn ss (Just (ForAll ann vis var mbk (a :-> b) mSkol)) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn LAM FORALL " <> T.unpack (showIdent name)) $ do + traceM $ renderValue 10 v + env <- gets checkEnv + pTrace (M.keys $ names env) -- mapM_ traceM (debugEnv env) + let toBind = [(ssb, name, a, Defined)] + withScopedTypeVars mn [(var,kindType)] $ bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body +exprToCoreFn mn ss (Just fa@(ForAll ann vis var mbk (ConstrainedType cann c@Constraint{..} r) mSkol)) lam@(A.Abs (A.VarBinder vbss name@(Ident "dict")) _) = wrapTrace ("exprToCoreFn LAM FORALL CONSTRAINED " <> T.unpack (showIdent name)) $ do + traceM $ show name + --traceM $ ppType 100 fa + --traceM $ ppType 100 r + traceM $ renderValue 100 lam + -- NOTE: This won't work for MPTCs, just trying to see if it works for the single arg case right now + let dictTyName :: Qualified (ProperName TypeName) = dictTypeName . coerceProperName <$> constraintClass + dictTy = srcTypeConstructor dictTyName + innerTy = srcTypeApp dictTy (srcTypeVar var) + --traceM $ ppType 100 dictTy + bindLocalVariables [(NullSourceSpan,name,innerTy,Defined)] $ exprToCoreFn mn ss (Just (ForAll ann vis var mbk (function innerTy r) mSkol)) lam +exprToCoreFn mn ss (Just ab@(a :-> b)) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn LAM " <> T.unpack (showIdent name)) $ do + traceM $ ppType 100 ab + traceM $ renderValue 100 lam + let toBind = [(ssb,name,a,Defined)] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (purusFun a b) name body +exprToCoreFn mn ss (Just ct@(ConstrainedType cann c@Constraint{..} r)) lam@(A.Abs (A.VarBinder _ name) _) = wrapTrace ("exprToCoreFn LAM CONSTRAINED" <> T.unpack (showIdent name)) $ do + traceM $ ppType 100 ct + traceM $ ppType 100 r + traceM $ renderValue 100 lam + exprToCoreFn mn ss (Just r) lam >>= \case + Abs ss' r' name' lam' -> pure $ Abs ss' (ConstrainedType () (const () <$> c) r') name' lam' + _ -> error "Internal error: Something went horribly wrong in exprToCoreFn with a constrained type (should be impossible)" +{- exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do traceM $ "exprToCoreFn lam " <> T.unpack (showIdent name) <> " :: " <> ppType 10 ty - case ty of ft@(ForAll ann vis var mbk qty mSkol) -> case unFun qty of Right (a,b) -> do @@ -265,17 +325,29 @@ exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do traceM $ "arg: " <> ppType 10 a traceM $ "result: " <> ppType 10 b let toBind = [(ssb, name, a, Defined)] - bindLocalVariables toBind $ do + withScopedTypeVars mn [] $ bindLocalVariables toBind $ do body <- exprToCoreFn mn ss (Just b) v pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body - Left e -> error $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e + Left e -> error + $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e + <> "\n" <> show e + ConstrainedType ann c ty -> case unFun ty of + Right (a,b) -> do + traceM $ "Constrained type branch" + let toBind = [(ssb,name,a,Defined)] + bindLocalVariables toBind $ do + body <- exprToCoreFn mn ss (Just b) v + pure $ Abs (ssA ssb) (purusFun a b) name body other -> case unFun other of Right (a,b) -> do + traceM "Normal function branch" let toBind = [(ssb, name, a, Defined )] bindLocalVariables toBind $ do body <- exprToCoreFn mn ss (Just b) v pure $ Abs (ssA ssb) (purusFun a b) name body - Left e -> error $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e + Left e -> error + $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e + <> "\n" <> show e -- error "boom" {- (unFun <$> inferType (Just ty) lam) >>= \case @@ -290,14 +362,50 @@ exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do body <- exprToCoreFn mn ss Nothing v pure $ Abs (ssA ssb) (purusTy ty) name body -} +-} exprToCoreFn _ _ _ lam@(A.Abs _ _) = internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn" <> show lam -exprToCoreFn mn ss mTy app@(A.App v1 v2) = do - appT <- inferType mTy app - v1' <- exprToCoreFn mn ss Nothing v1 - v2' <- exprToCoreFn mn ss Nothing v2 - pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' +exprToCoreFn mn ss mTy app@(A.App v1 v2) + | isDictCtor v2 && isDictInstCase v1 = wrapTrace ("exprToCoreFn APP DICT") $ do + v2' <- exprToCoreFn mn ss Nothing v2 + toBind <- mkDictInstBinder v1 + v1' <- bindLocalVariables toBind $ exprToCoreFn mn ss Nothing v1 + appT <- inferType mTy app + pure $ App (ss, [], Just IsSyntheticApp) (purusTy appT) v1' v2' + + + | otherwise = wrapTrace ("exprToCoreFn APP") $ do + appT <- inferType mTy app + traceM $ "AppTy: " <> ppType 10 appT + traceM $ "expr: " <> renderValue 10 app + traceM $ "fun expr: " <> renderValue 10 v1 + traceM $ "arg expr: " <> renderValue 10 v2 + v1' <- exprToCoreFn mn ss Nothing v1 + + traceM $ "FunTy: " <> ppType 10 (exprType v1') + v2' <- exprToCoreFn mn ss Nothing v2 + + traceM $ "ArgTy: " <> ppType 10 (exprType v2') + pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' where + + mkDictInstBinder = \case + A.TypedValue _ e _ -> mkDictInstBinder e + A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var ss (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder ctorSS cn@(Qualified cnameQB cname) _] [A.MkUnguarded _acsr]]) -> do + let className :: Qualified (ProperName 'ClassName) = coerceProperName <$> cn + args' <- getTypeClassArgs className + let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show i)) [1..] args' + dictTyCon = srcTypeConstructor (coerceProperName <$> cn) + dictTyFreeVars = foldl srcTypeApp dictTyCon args + ty = quantify dictTyFreeVars + pure [(A.NullSourceSpan,Ident "dict",ty,Defined)] + _ -> error "invalid dict accesor expr" + + isDictInstCase = \case + A.TypedValue _ e _ -> isDictInstCase e + A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var ss (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name + _ -> False + isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name _ -> False @@ -312,11 +420,11 @@ exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ -- pure $ Var (ss, com, Nothing) C.I_undefined -- exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> -- pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident -exprToCoreFn mn _ _ (A.Var ss ident) = +exprToCoreFn mn _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident Nothing -> error $ "No known type for identifier " <> show ident -exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do +exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace ("exprToCoreFn IFTE") $ do ifteTy <- inferType mTy ifte condE <- exprToCoreFn mn ss (Just tyBoolean) cond thE <- exprToCoreFn mn ss Nothing th @@ -326,32 +434,29 @@ exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = do (Right thE) , CaseAlternative [NullBinder (ssAnn ss)] -- * (Right elE) ] -exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = do +exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do env <- gets checkEnv let ctorMeta = getConstructorMeta env name ctorType <- inferType mTy ctor pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name -exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = do +exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace ("exprToCoreFn CASE") $ do + traceM $ renderValue 100 astCase caseTy <- inferType mTy astCase + traceM $ ppType 100 caseTy + pTrace vs vs' <- traverse (exprToCoreFn mn ss Nothing) vs - alts' <- traverse (altToCoreFn mn ss) alts + alts' <- traverse (altToCoreFn mn ss (Just caseTy)) alts pure $ Case (ssA ss) (purusTy caseTy) vs' alts' -exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = +exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace ("exprToCoreFn TV1") $ exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = +exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace ("exprToCoreFn TV2") $ exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = case NE.nonEmpty ds of +exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = wrapTrace ("exprToCoreFn LET") $ case NE.nonEmpty ds of Nothing -> error "declarations in a let binding can't be empty" Just ds' -> do - traceM $ "exprToCoreFn LET: " <> show astLet - types <- typesOf RecursiveBindingGroup mn $ fmap stripDecls ds - traceM $ concatMap (\x -> show x <> "\n\n") types - bindLocalVariables (prepareBind <$> types) $ do - printEnv - expr <- exprToCoreFn mn ss Nothing v - decls <- concat <$> traverse (declToCoreFn mn) (toValueDecl <$> types) - -- (ds', expr) <- transformLetBindings mn ss [] ds v - pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr + traceM $ "exprToCoreFn LET: " + (decls,expr) <- transformLetBindings mn ss [] ds v -- typesOf RecursiveBindingGroup mn $ fmap stripDecls ds + pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr where toValueDecl :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> A.Declaration toValueDecl ((ss',ident),(exp,ty)) = A.ValueDecl ss' ident Public [] [A.MkUnguarded exp] @@ -372,7 +477,7 @@ exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = case NE.nonEmpty ds of stripDecls = \case A.ValueDecl ann ident nKind [] [A.MkUnguarded e] -> ((ann,ident), e) other -> error $ "let bindings should only contain value declarations w/ desugared binders and a single expr. this doesn't: " <> show other -exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = +exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ exprToCoreFn mn ss ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e @@ -381,30 +486,44 @@ transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) -- for typed values (this might be wrong?) transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do - TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do + traceM $ "transformLetBindings 1 " <> T.unpack (showIdent ident) + {- -TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do + traceM $ "transformLetBindings 1.1" ((args, elabTy), kind) <- kindOfWithScopedVars ty + traceM $ "transformLetBindings 1.2" checkTypeKind ty kind + traceM $ "transformLetBindings 1.3" let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) + traceM $ "transformLetBindings 1.4" ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy + traceM $ "transformLetBindings 1.5" if checkType then withScopedTypeVars mn args $ bindNames dict $ check val ty' else return (TypedValue' checkType val elabTy) - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val' ty'')]) + -} + traceM $ "transformLetBindings 1.6" + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + traceM $ "transformLetBindings 1.7" + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) + traceM $ "transformLetBindings 1.8" let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret --- untyped values +-- TODO / FIXME: Rewrite the below definitions to avoid doing any type checking transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = do + traceM $ "transformLetBindings 2 " <> T.unpack (showIdent ident) valTy <- freshTypeWithKind kindType TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val + traceM "transformLetBindings 2.1" warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + traceM "transformLetBindings 2.2" bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = do + traceM $ "transformLetBindings bindingGroup" SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict @@ -418,8 +537,8 @@ transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings -- Desugars case alternatives from AST to CoreFn representation. -altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann) -altToCoreFn mn ss (A.CaseAlternative bs vs) = do +altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.CaseAlternative -> m (CaseAlternative Ann) +altToCoreFn mn ss mTy (A.CaseAlternative bs vs) = wrapTrace "altToCoreFn" $ do env <- gets checkEnv let binders = binderToCoreFn env mn ss <$> bs ege <- go vs @@ -427,7 +546,7 @@ altToCoreFn mn ss (A.CaseAlternative bs vs) = do where go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) go [A.MkUnguarded e] = do - expr <- exprToCoreFn mn ss Nothing e + expr <- exprToCoreFn mn ss mTy e pure $ Right expr go gs = do ges <- forM gs $ \case @@ -440,31 +559,25 @@ altToCoreFn mn ss (A.CaseAlternative bs vs) = do guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" --- This should ONLY ever be used to create a type in contexts where one doesn't make sense -tUnknown :: forall a. a -> Type a -tUnknown x = TUnknown x (-1) --- I'm not sure how to type Binders. Likely we need a new syntatic construct? But if the sub-terms are well-typed we should be able to give binder a placeholder type? idk +-- TODO/FIXME This needs to be monad and/or we need to pass in the type of the binder if known. +-- Also might need to pattern match on the NullSourceSpan (Ident "dict") that they use to identify +-- a var that represents a type class dictionary. ugh. -- Desugars case binders from AST to CoreFn representation. binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = let lit' = binderToCoreFn env mn ss <$> lit - ty = tUnknown (ss,[]) in LiteralBinder (ss, [], Nothing) lit' binderToCoreFn _ mn ss A.NullBinder = - let ty = tUnknown (ss,[]) - in NullBinder (ss, [], Nothing) + NullBinder (ss, [], Nothing) binderToCoreFn _ mn _ss (A.VarBinder ss name) = - let ty = tUnknown (ss,[]) - in VarBinder (ss, [], Nothing) name + VarBinder (ss, [], Nothing) name binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - ty = tUnknown (ss,[]) args = binderToCoreFn env mn _ss <$> bs in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args binderToCoreFn env mn _ss (A.NamedBinder ss name b) = - let ty = tUnknown (ss,[]) - arg = binderToCoreFn env mn _ss b + let arg = binderToCoreFn env mn _ss b in NamedBinder (ss, [], Nothing) name arg binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = binderToCoreFn env mn ss b diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 4e4e3902..2ff9bff8 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -369,10 +369,10 @@ purusFun = f . g tyFunctionNoAnn = TypeConstructor () C.Function -- This is borderline necessary -pattern (:->) :: Type () -> Type () -> Type () -pattern a :-> b = - TypeApp () - (TypeApp () (TypeConstructor () C.Function) a) +pattern (:->) :: Type a -> Type a -> Type a +pattern a :-> b <- + TypeApp _ + (TypeApp _ (TypeConstructor _ C.Function) a) b getFunArgTy :: Type () -> Type () From f3a86eb421bd3b48a1168cc0dd7025fdaf04114d Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 23 Jan 2024 22:16:44 -0500 Subject: [PATCH 11/44] Adjusted typeclass desugaring to use real source locations in the case expressions, necessary for fully typing the desugared typeclass declarations --- src/Language/PureScript/Sugar/TypeClasses.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4f3129ba..30a5a1d5 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -300,7 +300,8 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati dictIdent = Ident "dict" dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] - acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) + -- N.B. changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work + acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified {- -ByNullSourcePos -} (BySourcePos $ spanStart ss) dictObjIdent)) visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] [MkUnguarded ( From 28a850e71f5b563299ca153eb5de1b12c5024a19 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 23 Jan 2024 22:17:17 -0500 Subject: [PATCH 12/44] Conversion to typed CoreFn for desugared typeclass dictionaries seems to work --- src/Language/PureScript/CoreFn/Desugar.hs | 146 +++++++++++++++---- src/Language/PureScript/TypeChecker/Types.hs | 7 +- 2 files changed, 121 insertions(+), 32 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index bc868f28..6f1bc3d6 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -2,7 +2,7 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..)) import Data.Function (on) @@ -20,11 +20,11 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, dictTypeName, TypeClassData (typeClassArguments), function) +import Language.PureScript.Environment (tyArray, pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, dictTypeName, TypeClassData (typeClassArguments), function, kindRow, tyFunction, tyRecord, tyString, tyChar, tyInt, tyNumber) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent, coerceProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent, coerceProperName, Name (DctorName)) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), Constraint (..), TypeVarVisibility (..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify) +import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), Constraint (..), TypeVarVisibility (..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -32,7 +32,7 @@ import Language.PureScript.Constants.Prim qualified as C import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Strict (MonadState, gets, modify, MonadIO (liftIO)) import Control.Monad.Writer.Class ( MonadWriter ) -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables, debugEnv) +import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables, debugEnv, instantiateForBinders, kindOf) import Control.Monad.Error (MonadError) import Language.PureScript.TypeChecker.Types ( kindType, @@ -46,13 +46,13 @@ import Language.PureScript.TypeChecker.Types checkTypedBindingGroupElement, typeForBindingGroupElement, infer, - check, tvToExpr, instantiatePolyTypeWithUnknowns ) + check, tvToExpr, instantiatePolyTypeWithUnknowns, inferBinder ) import Data.List.NonEmpty qualified as NE import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards, freshType) -import Control.Monad (forM, (<=<)) +import Control.Monad (forM, (<=<), (>=>), unless) import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) import Language.PureScript.Errors (MultipleErrors, parU) -import Debug.Trace (traceM) +import Debug.Trace (traceM, trace) import Language.PureScript.CoreFn.Pretty import qualified Data.Text as T import Language.PureScript.Pretty.Values (renderValue) @@ -61,6 +61,7 @@ import Text.Pretty.Simple (pShowNoColor, pShow) import qualified Data.Text.Lazy as LT import Language.PureScript.AST.SourcePos (SourcePos(SourcePos)) import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Errors (errorMessage',SimpleErrorMessage(..)) type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -148,21 +149,21 @@ lookupType sp tn = do -- printEnv >>= traceM case M.lookup (Qualified (BySourcePos sp) tn) (names env) of Nothing -> case M.lookup (mkQualified tn mn) (names env) of - Nothing -> error $ "No type found for " <> show tn + Nothing -> do + pEnv <- printEnv + error $ "No type found for " <> show tn <> "\n in env:\n" <> pEnv Just (ty,nk,nv) -> do traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty pure (ty,nv) Just (ty,nk,nv) -> do traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty pure (ty,nv) - where - printEnv :: m String - printEnv = do - env <- gets checkEnv - let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env - pure $ concatMap (\(i,st) -> "ENV:= " <> T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st <> "\n") ns - +printEnv :: M m => m String +printEnv = do + env <- gets checkEnv + let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env + pure $ concatMap (\(i,st) -> "ENV:= " <> T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st <> "\n") ns lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do @@ -183,7 +184,7 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name args [ctor]) = wrapTra [(_,wrappedTy)] -> do traceM (show ctor) -- declTy <- lookupType mn name // might need this? - let innerFunTy = purusFun wrappedTy wrappedTy + let innerFunTy = quantify $ purusFun wrappedTy wrappedTy pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] _ -> error "Found newtype with multiple fields" @@ -290,6 +291,7 @@ exprToCoreFn mn ss (Just (ForAll ann vis var mbk (a :-> b) mSkol)) lam@(A.Abs (A withScopedTypeVars mn [(var,kindType)] $ bindLocalVariables toBind $ do body <- exprToCoreFn mn ss (Just b) v pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body +-- TODO/FIXME: Make it work with MPTCs exprToCoreFn mn ss (Just fa@(ForAll ann vis var mbk (ConstrainedType cann c@Constraint{..} r) mSkol)) lam@(A.Abs (A.VarBinder vbss name@(Ident "dict")) _) = wrapTrace ("exprToCoreFn LAM FORALL CONSTRAINED " <> T.unpack (showIdent name)) $ do traceM $ show name --traceM $ ppType 100 fa @@ -423,7 +425,10 @@ exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ exprToCoreFn mn _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident - Nothing -> error $ "No known type for identifier " <> show ident + Nothing -> do + -- pEnv <- printEnv + traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) + error "boom" exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace ("exprToCoreFn IFTE") $ do ifteTy <- inferType mTy ifte condE <- exprToCoreFn mn ss (Just tyBoolean) cond @@ -442,11 +447,15 @@ exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn C exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace ("exprToCoreFn CASE") $ do traceM $ renderValue 100 astCase caseTy <- inferType mTy astCase + ts <- traverse (infer >=> pure . tvType) vs -- instantiateForBinders vs alts -- might be wrong, instantiation might screw up the tyvars NOTE/FIXME: Definitely wrong traceM $ ppType 100 caseTy pTrace vs - vs' <- traverse (exprToCoreFn mn ss Nothing) vs - alts' <- traverse (altToCoreFn mn ss (Just caseTy)) alts + vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe? + alts' <- traverse (altToCoreFn mn ss caseTy ts) alts pure $ Case (ssA ss) (purusTy caseTy) vs' alts' + where + tvType (TypedValue' _ _ t) = t + exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace ("exprToCoreFn TV1") $ exprToCoreFn mn ss (Just ty) v exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace ("exprToCoreFn TV2") $ @@ -537,18 +546,21 @@ transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings -- Desugars case alternatives from AST to CoreFn representation. -altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.CaseAlternative -> m (CaseAlternative Ann) -altToCoreFn mn ss mTy (A.CaseAlternative bs vs) = wrapTrace "altToCoreFn" $ do +altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> SourceType -> [SourceType] -> A.CaseAlternative -> m (CaseAlternative Ann) +altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCoreFn" $ do env <- gets checkEnv - let binders = binderToCoreFn env mn ss <$> bs - ege <- go vs + bTypes <- M.unions <$> zipWithM inferBinder' boundTypes bs + let toBind = (\(n',(ss',ty')) -> (ss',n',ty',Defined)) <$> M.toList bTypes + binders = binderToCoreFn env mn ss <$> bs + traceM $ concatMap (\x -> show x <> "\n") toBind + ege <- go toBind vs pure $ CaseAlternative binders ege where - go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) - go [A.MkUnguarded e] = do - expr <- exprToCoreFn mn ss mTy e + go :: [(SourceSpan, Ident, SourceType, NameVisibility)] -> [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) + go toBind [A.MkUnguarded e] = wrapTrace "altToCoreFn GO" $ do + expr <- bindLocalVariables toBind $ exprToCoreFn mn ss (Just ret) e pure $ Right expr - go gs = do + go _ gs = do ges <- forM gs $ \case A.GuardedExpr g e -> do let cond = guardToExpr g @@ -570,7 +582,7 @@ binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = in LiteralBinder (ss, [], Nothing) lit' binderToCoreFn _ mn ss A.NullBinder = NullBinder (ss, [], Nothing) -binderToCoreFn _ mn _ss (A.VarBinder ss name) = +binderToCoreFn _ mn _ss vb@(A.VarBinder ss name) = trace ("binderToCoreFn: " <> show vb ) $ VarBinder (ss, [], Nothing) name binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor @@ -677,3 +689,79 @@ exportToCoreFn (A.ReExportRef _ _ _) = [] -- | Converts a ProperName to an Ident. properToIdent :: ProperName a -> Ident properToIdent = Ident . runProperName + +-- We need a version that *doesn't* instantiate polytypes to unknowns + +-- | Infer the types of variables brought into scope by a binder +inferBinder' + :: forall m + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => SourceType + -> A.Binder + -> m (M.Map Ident (SourceSpan, SourceType)) +inferBinder' _ A.NullBinder = return M.empty +inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty +inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty +inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty +inferBinder' val (A.VarBinder ss name) = return $ M.singleton name (ss, val) +inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder CTOR: " <> show ctor) $ do + env <- getEnv + case M.lookup ctor (dataConstructors env) of + Just (_, _, ty, _) -> do + traceM (ppType 100 ty) + -- (_, fn') <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty + -- traceM (ppType 100 fn') + let (args, ret) = peelArgs ty + expected = length args + actual = length binders + -- unless (expected == actual) . throwError . errorMessage' ss $ IncorrectConstructorArity ctor expected actual + unifyTypes ret val + M.unions <$> zipWithM inferBinder' (reverse args) binders + _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor + where + peelArgs :: Type a -> ([Type a], Type a) + peelArgs = go [] + where + go args (ForAll _ _ _ _ innerTy _) = go args innerTy + go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret + go args ret = (args, ret) +-- TODO/FIXME: The cases below need to be scrutinized/rewritten to avoid any subtle polytype instantiation +inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = do + row <- freshTypeWithKind (kindRow kindType) + rest <- freshTypeWithKind (kindRow kindType) + m1 <- inferRowProperties row rest props + unifyTypes val (srcTypeApp tyRecord row) + return m1 + where + inferRowProperties :: SourceType -> SourceType -> [(PSString, A.Binder)] -> m (M.Map Ident (SourceSpan, SourceType)) + inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty + inferRowProperties nrow row ((name, binder):binders) = do + propTy <- freshTypeWithKind kindType + m1 <- inferBinder' propTy binder + m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders + return $ m1 `M.union` m2 +inferBinder' val (A.LiteralBinder _ (ArrayLiteral binders)) = do + el <- freshTypeWithKind kindType + m1 <- M.unions <$> traverse (inferBinder' el) binders + unifyTypes val (srcTypeApp tyArray el) + return m1 +inferBinder' val (A.NamedBinder ss name binder) = + warnAndRethrowWithPositionTC ss $ do + m <- inferBinder' val binder + return $ M.insert name (ss, val) m +inferBinder' val (A.PositionedBinder pos _ binder) = + warnAndRethrowWithPositionTC pos $ inferBinder' val binder +inferBinder' val (A.TypedBinder ty binder) = do + (elabTy, kind) <- kindOf ty + checkTypeKind ty kind + ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy + unifyTypes val ty1 + inferBinder' ty1 binder +inferBinder' _ A.OpBinder{} = + internalError "OpBinder should have been desugared before inferBinder'" +inferBinder' _ A.BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before inferBinder'" +inferBinder' _ A.ParensInBinder{} = + internalError "ParensInBinder should have been desugared before inferBinder'" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a468a961..ddc38a41 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -12,6 +12,7 @@ module Language.PureScript.TypeChecker.Types , kindType , TypedValue' (..) , instantiatePolyTypeWithUnknowns + , instantiateForBinders , tvToExpr , SplitBindingGroup(..) , typeDictionaryForBindingGroup @@ -725,9 +726,9 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- checkBinders :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [SourceType] - -> SourceType - -> [CaseAlternative] + => [SourceType] -- the types of the scrutinee values + -> SourceType -- return type of case expr + -> [CaseAlternative] -- the binders -> m [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do From 282d951ea9b5600d19d56690786ccde2f7f49ff3 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 24 Jan 2024 21:09:51 -0500 Subject: [PATCH 13/44] Typed CoreFn conversion now works with MPTCs, cleaned up a bunch of ugly CoreFn desugaring code --- src/Language/PureScript/CoreFn/Desugar.hs | 152 ++++++------------- src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- 3 files changed, 46 insertions(+), 110 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 6f1bc3d6..cd9d5944 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude @@ -62,10 +64,43 @@ import qualified Data.Text.Lazy as LT import Language.PureScript.AST.SourcePos (SourcePos(SourcePos)) import Language.PureScript.TypeChecker.Monad import Language.PureScript.Errors (errorMessage',SimpleErrorMessage(..)) +import qualified Data.Kind as K type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +-- We strip leading quantifiers, returning the non-quantified inner type, a function to replace the stripped quantifiers, and a monadic action that binds all the relevant tyvars +-- N.B. This is kind of like `instantiatePolyTypeWithUnknowns` except we don't instantiate to unknowns. This should be fine, we're working on an already-checked syntax tree. + +{- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: + - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous + typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. + Constraints are eliminated by replacing the constraint argument w/ the appropriate dictionary type. + + - T[1] is a function to transform the eventual expression such that it is properly typed. Basically: It puts the quantifiers back, (hopefully) in the right order and with + the correct visibility, skolem scope, etc. + + - T[2] is a monadic action which binds local variables or type variables so that we can use type inference machinery on the expression corresponding to this type. +-} +instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) +instantiatePolyType mn = \case + ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of + (inner,g,act) -> + let f = \case + Abs ann' ty' ident' expr' -> Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' + other -> other + act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) + in (inner, f . g, act') + ConstrainedType ann c@Constraint{..} t -> case instantiatePolyType mn t of + (inner,g,act) -> + let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass + dictTyCon = srcTypeConstructor dictTyName + dictTy = foldl srcTypeApp dictTyCon constraintArgs + act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma + in (function dictTy inner,g,act') + other -> (other,id,id) + + pTrace :: (Monad m, Show a) => a -> m () pTrace = traceM . LT.unpack . pShow @@ -283,90 +318,15 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r collect _ = Nothing unchangedRecordFields _ _ = Nothing -exprToCoreFn mn ss (Just (ForAll ann vis var mbk (a :-> b) mSkol)) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn LAM FORALL " <> T.unpack (showIdent name)) $ do - traceM $ renderValue 10 v - env <- gets checkEnv - pTrace (M.keys $ names env) -- mapM_ traceM (debugEnv env) - let toBind = [(ssb, name, a, Defined)] - withScopedTypeVars mn [(var,kindType)] $ bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body --- TODO/FIXME: Make it work with MPTCs -exprToCoreFn mn ss (Just fa@(ForAll ann vis var mbk (ConstrainedType cann c@Constraint{..} r) mSkol)) lam@(A.Abs (A.VarBinder vbss name@(Ident "dict")) _) = wrapTrace ("exprToCoreFn LAM FORALL CONSTRAINED " <> T.unpack (showIdent name)) $ do - traceM $ show name - --traceM $ ppType 100 fa - --traceM $ ppType 100 r - traceM $ renderValue 100 lam - -- NOTE: This won't work for MPTCs, just trying to see if it works for the single arg case right now - let dictTyName :: Qualified (ProperName TypeName) = dictTypeName . coerceProperName <$> constraintClass - dictTy = srcTypeConstructor dictTyName - innerTy = srcTypeApp dictTy (srcTypeVar var) - --traceM $ ppType 100 dictTy - bindLocalVariables [(NullSourceSpan,name,innerTy,Defined)] $ exprToCoreFn mn ss (Just (ForAll ann vis var mbk (function innerTy r) mSkol)) lam -exprToCoreFn mn ss (Just ab@(a :-> b)) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn LAM " <> T.unpack (showIdent name)) $ do - traceM $ ppType 100 ab - traceM $ renderValue 100 lam - let toBind = [(ssb,name,a,Defined)] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body -exprToCoreFn mn ss (Just ct@(ConstrainedType cann c@Constraint{..} r)) lam@(A.Abs (A.VarBinder _ name) _) = wrapTrace ("exprToCoreFn LAM CONSTRAINED" <> T.unpack (showIdent name)) $ do - traceM $ ppType 100 ct - traceM $ ppType 100 r - traceM $ renderValue 100 lam - exprToCoreFn mn ss (Just r) lam >>= \case - Abs ss' r' name' lam' -> pure $ Abs ss' (ConstrainedType () (const () <$> c) r') name' lam' - _ -> error "Internal error: Something went horribly wrong in exprToCoreFn with a constrained type (should be impossible)" -{- -exprToCoreFn mn ss (Just ty) lam@(A.Abs (A.VarBinder ssb name) v) = do - traceM $ "exprToCoreFn lam " <> T.unpack (showIdent name) <> " :: " <> ppType 10 ty - case ty of - ft@(ForAll ann vis var mbk qty mSkol) -> case unFun qty of - Right (a,b) -> do - traceM "ForAll branch" - traceM $ "arg: " <> ppType 10 a - traceM $ "result: " <> ppType 10 b - let toBind = [(ssb, name, a, Defined)] - withScopedTypeVars mn [] $ bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (ForAll () vis var (purusTy <$> mbk) (purusFun a b) mSkol) name body - Left e -> error - $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e - <> "\n" <> show e - ConstrainedType ann c ty -> case unFun ty of - Right (a,b) -> do - traceM $ "Constrained type branch" - let toBind = [(ssb,name,a,Defined)] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body - other -> case unFun other of - Right (a,b) -> do - traceM "Normal function branch" - let toBind = [(ssb, name, a, Defined )] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body - Left e -> error - $ "All lambda abstractions should have either a function type or a quantified function type: " <> ppType 10 e - <> "\n" <> show e - -- error "boom" - - {- (unFun <$> inferType (Just ty) lam) >>= \case - Right (a,b) -> do - traceM $ "function lam " <> ppType 10 ty -- prettyPrintType 0 (purusFun a b) - let toBind = [(ssb, name, a, Defined )] - bindLocalVariables toBind $ do - body <- exprToCoreFn mn ss Nothing v -- (Just b) v - pure $ Abs (ssA ssb) {- (purusFun a b) -} (purusTy ty) name body - Left _ty -> do - traceM $ "??? lam " <> prettyPrintType 0 _ty - body <- exprToCoreFn mn ss Nothing v - pure $ Abs (ssA ssb) (purusTy ty) name body --} --} -exprToCoreFn _ _ _ lam@(A.Abs _ _) = - internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn" <> show lam +exprToCoreFn mn ss (Just t) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> T.unpack (showIdent name)) $ do + let (inner,f,bindAct) = instantiatePolyType mn t + case inner of + a :-> b -> do + body <- bindAct $ exprToCoreFn mn ssb (Just b) v + pure . f $ Abs (ssA ssb) (purusFun a b) name body + other -> error $ "Invalid function type " <> ppType 100 other +exprToCoreFn _ _ t lam@(A.Abs _ _) = + internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (fmap (const ()) <$> t) exprToCoreFn mn ss mTy app@(A.App v1 v2) | isDictCtor v2 && isDictInstCase v1 = wrapTrace ("exprToCoreFn APP DICT") $ do v2' <- exprToCoreFn mn ss Nothing v2 @@ -466,26 +426,6 @@ exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = wrapTrace ("exprToCoreFn LET") $ traceM $ "exprToCoreFn LET: " (decls,expr) <- transformLetBindings mn ss [] ds v -- typesOf RecursiveBindingGroup mn $ fmap stripDecls ds pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr - where - toValueDecl :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> A.Declaration - toValueDecl ((ss',ident),(exp,ty)) = A.ValueDecl ss' ident Public [] [A.MkUnguarded exp] - - printEnv :: m () - printEnv = do - env <- gets checkEnv - let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env - mapM_ (\(i,st) -> traceM $ T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st) ns - - prepareBind :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> (SourceSpan, Ident, SourceType, NameVisibility) - prepareBind (((ss',_),ident),(e,sty)) = (ss',ident,sty,Defined) - - transformBind :: ((Ann, Ident), Expr Ann) -> (SourceSpan, Ident, SourceType, NameVisibility) - transformBind (((ss',_,_),ident),expr) = (ss',ident,const (ss',[]) <$> exprType expr, Defined) - -- Everything here *should* be a value declaration. I hope? - stripDecls :: A.Declaration-> ((A.SourceAnn, Ident), A.Expr) - stripDecls = \case - A.ValueDecl ann ident nKind [] [A.MkUnguarded e] -> ((ann,ident), e) - other -> error $ "let bindings should only contain value declarations w/ desugared binders and a single expr. this doesn't: " <> show other exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ exprToCoreFn mn ss ty v exprToCoreFn _ _ _ e = @@ -571,10 +511,6 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" - --- TODO/FIXME This needs to be monad and/or we need to pass in the type of the binder if known. --- Also might need to pattern match on the NullSourceSpan (Ident "dict") that they use to identify --- a var that represents a type class dictionary. ugh. -- Desugars case binders from AST to CoreFn representation. binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 2ff9bff8..54859f7b 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -378,7 +378,7 @@ pattern a :-> b <- getFunArgTy :: Type () -> Type () getFunArgTy = \case a :-> _ -> a - ForAll _ _ _ _ (a :-> _) _ -> a + ForAll _ _ _ _ t _ -> getFunArgTy t other -> other -- To make reading the kind signatures below easier diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 30a5a1d5..7c2fc013 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -300,7 +300,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati dictIdent = Ident "dict" dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] - -- N.B. changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work + -- NOTE: changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified {- -ByNullSourcePos -} (BySourcePos $ spanStart ss) dictObjIdent)) visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] From cdd4bb1defbc8fccf8e1e53375ba560e938385c6 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 25 Jan 2024 16:39:14 -0500 Subject: [PATCH 14/44] Substantial cleanup + documentation pass --- purescript.cabal | 1 + src/Language/PureScript/CoreFn/Desugar.hs | 594 ++++++------------ .../PureScript/CoreFn/Desugar/Utils.hs | 288 +++++++++ 3 files changed, 489 insertions(+), 394 deletions(-) create mode 100644 src/Language/PureScript/CoreFn/Desugar/Utils.hs diff --git a/purescript.cabal b/purescript.cabal index b5ed6000..31f72e7d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -240,6 +240,7 @@ library Language.PureScript.CoreFn.Binders Language.PureScript.CoreFn.CSE Language.PureScript.CoreFn.Desugar + Language.PureScript.CoreFn.Desugar.Utils Language.PureScript.CoreFn.Expr Language.PureScript.CoreFn.FromJSON Language.PureScript.CoreFn.Meta diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index cd9d5944..55840de4 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,41 +1,39 @@ +{- HLINT ignore "Use void" -} +{- HLINT ignore "Use <$" -} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} + module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude import Protolude (ordNub, orEmpty, zipWithM, MonadError (..)) -import Data.Function (on) import Data.Maybe (mapMaybe) -import Data.Tuple (swap) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) -import Language.PureScript.AST.Traversals (everythingOnValues) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) -import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, PurusType, exprType) -import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) +import Language.PureScript.CoreFn.Meta (Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (tyArray, pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, dictTypeName, TypeClassData (typeClassArguments), function, kindRow, tyFunction, tyRecord, tyString, tyChar, tyInt, tyNumber) +import Language.PureScript.Environment (tyArray, pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, kindRow, tyFunction, tyRecord, tyString, tyChar, tyInt, tyNumber) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, mkQualified, showIdent, runIdent, coerceProperName, Name (DctorName)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified, showIdent, runIdent, coerceProperName, Name (DctorName)) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), Constraint (..), TypeVarVisibility (..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) +import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A import Language.PureScript.Constants.Prim qualified as C -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Strict (MonadState, gets, modify, MonadIO (liftIO)) +import Control.Monad.State.Strict (MonadState, gets, modify) import Control.Monad.Writer.Class ( MonadWriter ) -import Language.PureScript.TypeChecker (CheckState (checkEnv, checkCurrentModule), withBindingGroupVisible, bindLocalVariables, withScopedTypeVars, bindNames, replaceAllTypeSynonyms, kindOfWithScopedVars, warnAndRethrowWithPositionTC, makeBindingGroupVisible, bindLocalTypeVariables, debugEnv, instantiateForBinders, kindOf) -import Control.Monad.Error (MonadError) +import Language.PureScript.TypeChecker.Kinds ( kindOf ) +import Language.PureScript.TypeChecker.Synonyms + ( replaceAllTypeSynonyms ) import Language.PureScript.TypeChecker.Types ( kindType, checkTypeKind, @@ -47,105 +45,69 @@ import Language.PureScript.TypeChecker.Types typeDictionaryForBindingGroup, checkTypedBindingGroupElement, typeForBindingGroupElement, - infer, - check, tvToExpr, instantiatePolyTypeWithUnknowns, inferBinder ) + infer ) import Data.List.NonEmpty qualified as NE -import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards, freshType) -import Control.Monad (forM, (<=<), (>=>), unless) +import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) +import Control.Monad (forM, (<=<), (>=>)) import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) -import Language.PureScript.Errors (MultipleErrors, parU) -import Debug.Trace (traceM, trace) -import Language.PureScript.CoreFn.Pretty -import qualified Data.Text as T +import Language.PureScript.Errors + ( MultipleErrors, parU, errorMessage', SimpleErrorMessage(..) ) +import Debug.Trace (traceM) +import Language.PureScript.CoreFn.Pretty ( ppType ) +import Data.Text qualified as T import Language.PureScript.Pretty.Values (renderValue) -import Language.PureScript.TypeClassDictionaries (NamedDict) -import Text.Pretty.Simple (pShowNoColor, pShow) -import qualified Data.Text.Lazy as LT -import Language.PureScript.AST.SourcePos (SourcePos(SourcePos)) import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Errors (errorMessage',SimpleErrorMessage(..)) -import qualified Data.Kind as K - -type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - - --- We strip leading quantifiers, returning the non-quantified inner type, a function to replace the stripped quantifiers, and a monadic action that binds all the relevant tyvars --- N.B. This is kind of like `instantiatePolyTypeWithUnknowns` except we don't instantiate to unknowns. This should be fine, we're working on an already-checked syntax tree. - -{- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous - typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. - Constraints are eliminated by replacing the constraint argument w/ the appropriate dictionary type. - - - T[1] is a function to transform the eventual expression such that it is properly typed. Basically: It puts the quantifiers back, (hopefully) in the right order and with - the correct visibility, skolem scope, etc. - - - T[2] is a monadic action which binds local variables or type variables so that we can use type inference machinery on the expression corresponding to this type. + ( bindLocalVariables, + bindNames, + getEnv, + makeBindingGroupVisible, + warnAndRethrowWithPositionTC, + withBindingGroupVisible, + CheckState(checkEnv, checkCurrentModule) ) +import Language.PureScript.CoreFn.Desugar.Utils + ( binderToCoreFn, + dedupeImports, + exportToCoreFn, + externToCoreFn, + findQualModules, + getConstructorMeta, + getLetMeta, + getModuleName, + getTypeClassArgs, + getValueMeta, + importToCoreFn, + inferType, + instantiatePolyType, + pTrace, + printEnv, + properToIdent, + purusTy, + reExportsToCoreFn, + showIdent', + ssA, + toReExportRef, + traverseLit, + wrapTrace, + M ) + +{- + CONVERSION MACHINERY + + NOTE: We run this *after* the initial typechecking/desugaring phase, using the Environment returned from that + initial pass. It's important to keep that in mind, for a few reasons: + - We know that everything is well-typed/scoped/properly renamed/desugared/etc. This assumption lets us safely do a bunch of things that wouldn't otherwise be safe. + - We have access to all of the type signatures for top-level declarations + - We have to fix the "lies" in the type signatures that emerge after desugaring, e.g. types w/ a class constraint represent values that take an additional dict argument + + NOTE: All of the "pure" conversion functions (i.e. which don't require the typechecker monad stack) are in Language.PureScript.CoreFn.Desugar.Utils. + This module is hard enough to understand, best to minimize its size. -} -instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) -instantiatePolyType mn = \case - ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of - (inner,g,act) -> - let f = \case - Abs ann' ty' ident' expr' -> Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' - other -> other - act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) - in (inner, f . g, act') - ConstrainedType ann c@Constraint{..} t -> case instantiatePolyType mn t of - (inner,g,act) -> - let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass - dictTyCon = srcTypeConstructor dictTyName - dictTy = foldl srcTypeApp dictTyCon constraintArgs - act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma - in (function dictTy inner,g,act') - other -> (other,id,id) - - -pTrace :: (Monad m, Show a) => a -> m () -pTrace = traceM . LT.unpack . pShow - - -wrapTrace :: Monad m => String -> m a -> m a -wrapTrace msg act = do - traceM startMsg - res <- act - traceM endMsg - pure res - where - padding = replicate 10 '=' - pad str = padding <> str <> padding - startMsg = pad $ "BEGIN " <> msg - endMsg = pad $ "END " <> msg -() :: String -> String -> String -x y = x <> "\n" <> y - -purusTy :: Type a -> PurusType -purusTy = fmap (const ()) - -unFun :: Type a -> Either (Type a) (Type a,Type a) -unFun = \case - TypeApp _ (TypeApp _ (TypeConstructor _ C.Function) a) b -> Right (a,b) - other -> Left other - -getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData -getTypeClassData nm = do - env <- getEnv - case M.lookup nm (typeClasses env) of - Nothing -> error $ "No type class data for " show nm " found in" show (typeClasses env) - Just cls -> pure cls - -getTypeClassArgs :: M m => Qualified (ProperName 'ClassName) -> m [(T.Text,Maybe SourceType)] -getTypeClassArgs nm = getTypeClassData nm >>= (pure . typeClassArguments) - --- We're going to run this *after* a pass of the unmodified typechecker, using the Env of the already-typechecked-by-the-default-checker module --- That *should* allow us to avoid repeating the entire TC process, and simply infer/lookup types when we need them. Hopefully. -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do - -- traceM $ LT.unpack (pShowNoColor mod) +moduleToCoreFn (A.Module modSS coms mn decls (Just exps)) = do setModuleName let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls @@ -157,78 +119,52 @@ moduleToCoreFn mod@(A.Module modSS coms mn decls (Just exps)) = do where setModuleName = modify $ \cs -> cs {checkCurrentModule = Just mn} - -- Creates a map from a module name to the re-export references defined in - -- that module. -reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] -reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') -toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) -toReExportRef (A.ReExportRef _ src ref) = - fmap - (, ref) - (A.exportSourceImportedFrom src) -toReExportRef _ = Nothing - - -- Remove duplicate imports -dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] -dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap - -ssA :: SourceSpan -> Ann -ssA ss = (ss, [], Nothing) +{- | Given a SourcePos and Identifier, look up the type of that identifier, also returning its NameVisiblity. + NOTE: Local variables should all be qualified by their SourcePos, whereas imports (and maybe top level decls in the module? can't remember) + are qualified by their ModuleName. What we do here is first look for a "local" type for the identifier using the provided source position, + then, if that fails, look up the identifier in the "global" scope using a module name. + I *think* this is fine but I'm not *certain*. +-} lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibility) lookupType sp tn = do - mn <- Language.PureScript.CoreFn.Desugar.moduleName + mn <- getModuleName env <- gets checkEnv - -- printEnv >>= traceM case M.lookup (Qualified (BySourcePos sp) tn) (names env) of Nothing -> case M.lookup (mkQualified tn mn) (names env) of Nothing -> do pEnv <- printEnv error $ "No type found for " <> show tn <> "\n in env:\n" <> pEnv - Just (ty,nk,nv) -> do + Just (ty,_,nv) -> do traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty pure (ty,nv) - Just (ty,nk,nv) -> do + Just (ty,_,nv) -> do traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty pure (ty,nv) -printEnv :: M m => m String -printEnv = do - env <- gets checkEnv - let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env - pure $ concatMap (\(i,st) -> "ENV:= " <> T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st <> "\n") ns - -lookupCtorDeclTy :: M m => ModuleName -> A.DataConstructorDeclaration -> m SourceType -lookupCtorDeclTy mn (A.DataConstructorDeclaration ann ctorName fields)= do - env <- gets checkEnv - case M.lookup (mkQualified ctorName mn) (dataConstructors env) of - Nothing -> error $ "No constr decl info found for " <> show ctorName - Just (_declType,_tyName,ty,_idents) -> pure ty - +{- Converts declarations from their AST to CoreFn representation, deducing types when possible & inferring them when not possible. -moduleName :: M m => m ModuleName -moduleName = gets checkCurrentModule >>= \case - Just mn -> pure mn - Nothing -> error "No module name found in checkState" + TODO: The module name can be retrieved from the monadic context and doesn't need to be passed around +-} --- Desugars member declarations from AST to CoreFn representation. +-- newtype T = T Foo turns into T :: Foo -> Foo declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] -declToCoreFn mn (A.DataDeclaration (ss, com) Newtype name args [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of +declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of [(_,wrappedTy)] -> do traceM (show ctor) - -- declTy <- lookupType mn name // might need this? let innerFunTy = quantify $ purusFun wrappedTy wrappedTy - pure [NonRec ((ss, [], declMeta)) (properToIdent $ A.dataCtorName ctor) $ + pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] _ -> error "Found newtype with multiple fields" where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor +-- Reject newtypes w/ multiple constructors declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d +-- Data declarations get turned into value declarations for the constructor(s) declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do - traceM $ show ctors traverse go ctors where @@ -236,13 +172,11 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ( env <- gets checkEnv let ctor = A.dataCtorName ctorDecl (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - -- ctorDeclTy <- lookupCtorDeclTy mn ctorDecl pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields -declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DATA GROUP DECL" $ do - concat <$> traverse (declToCoreFn mn) ds -declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do - --traceM $ "decltoCoreFn " <> show name - -- env <- gets checkEnv +-- NOTE: This should be OK because you can data declarations can only appear at the top-level. +declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DATA GROUP DECL" $ concat <$> traverse (declToCoreFn mn) ds +-- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here? +declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do (valDeclTy,nv) <- lookupType (spanStart ss) name traceM $ ppType 10 valDeclTy traceM $ renderValue 100 e @@ -250,19 +184,15 @@ declToCoreFn mn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = wrapTrace bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? pure [NonRec (ssA ss) name expr] - +-- Recursive binding groups. This is tricky. Calling `typedOf` saves us a lot of work, but it's hard to tell whether that's 100% safe here declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDING GROUP" $ do let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds - types <- typesOf RecursiveBindingGroup mn stripped -- kind of redundant, this has already been performed in normal typechecking so we could just look up the types for each value decl ident - --types <- traverse lookupTypes stripped + types <- typesOf RecursiveBindingGroup mn stripped -- NOTE: If something weird breaks, look here. It's possible that `typesOf` makes calls to type CHECKING machinery that we don't want to ever invoke. recBody <- bindLocalVariables (prepareBind <$> types) $ traverse goRecBindings types pure [Rec recBody] where prepareBind :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> (SourceSpan, Ident, SourceType, NameVisibility) - prepareBind (((ss',_),ident),(e,sty)) = (ss',ident,sty,Defined) - - -- lookupTypes :: ((A.SourceAnn, Ident), A.Expr) -> m ((A.SourceAnn, Ident), (A.Expr, SourceType)) - -- lookupTypes ((ann,ident),exp) = lookupType mn ident >>= \(ty,_) -> pure ((ann,ident),(exp,ty)) + prepareBind (((ss',_),ident),(_,sty)) = (ss',ident,sty,Defined) goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) goRecBindings ((ann,ident),(expr,ty)) = do @@ -270,32 +200,19 @@ declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDIN pure ((ssA $ fst ann,ident), expr') declToCoreFn _ _ = pure [] -traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) -traverseLit f = \case - NumericLiteral x -> pure $ NumericLiteral x - StringLiteral x -> pure $ StringLiteral x - CharLiteral x -> pure $ CharLiteral x - BooleanLiteral x -> pure $ BooleanLiteral x - ArrayLiteral xs -> ArrayLiteral <$> traverse f xs - ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs - -inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType -inferType (Just t) _ = pure t -inferType Nothing e = infer e >>= \case - TypedValue' _ _ t -> pure t - --- Desugars expressions from AST to CoreFn representation. +-- Desugars expressions from AST to typed CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) +-- Literal case is straightforward exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do litT <- purusTy <$> inferType mTy astLit lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit pure $ Literal (ss, [], Nothing) litT lit' - +-- Accessor case is straightforward exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do expT <- purusTy <$> inferType mTy accessor expr <- exprToCoreFn mn ss Nothing v pure $ Accessor (ssA ss) expT name expr - +-- Object update is straightforward (this is basically a monadic wrapper around the old non-typed exprToCoreFn) exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do expT <- purusTy <$> inferType mTy objUpd obj' <- exprToCoreFn mn ss Nothing obj @@ -318,17 +235,21 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r collect _ = Nothing unchangedRecordFields _ _ = Nothing -exprToCoreFn mn ss (Just t) lam@(A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> T.unpack (showIdent name)) $ do - let (inner,f,bindAct) = instantiatePolyType mn t +-- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here. +exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> T.unpack (showIdent name)) $ do + let (inner,f,bindAct) = instantiatePolyType mn t -- Strip the quantifiers & constrained type wrappers and get the innermost not-polymorphic type, a function that puts the quantifiers back, and a monadic action to bind the necessary vars/tyvars case inner of a :-> b -> do body <- bindAct $ exprToCoreFn mn ssb (Just b) v pure . f $ Abs (ssA ssb) (purusFun a b) name body other -> error $ "Invalid function type " <> ppType 100 other +-- By the time we receive the AST, only Lambdas w/ a VarBinder should remain exprToCoreFn _ _ t lam@(A.Abs _ _) = - internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (fmap (const ()) <$> t) + internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t) +-- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. +-- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType exprToCoreFn mn ss mTy app@(A.App v1 v2) - | isDictCtor v2 && isDictInstCase v1 = wrapTrace ("exprToCoreFn APP DICT") $ do + | isDictCtor v2 && isDictInstCase v1 = wrapTrace "exprToCoreFn APP DICT" $ do v2' <- exprToCoreFn mn ss Nothing v2 toBind <- mkDictInstBinder v1 v1' <- bindLocalVariables toBind $ exprToCoreFn mn ss Nothing v1 @@ -336,7 +257,7 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) pure $ App (ss, [], Just IsSyntheticApp) (purusTy appT) v1' v2' - | otherwise = wrapTrace ("exprToCoreFn APP") $ do + | otherwise = wrapTrace "exprToCoreFn APP" $ do appT <- inferType mTy app traceM $ "AppTy: " <> ppType 10 appT traceM $ "expr: " <> renderValue 10 app @@ -350,13 +271,12 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) traceM $ "ArgTy: " <> ppType 10 (exprType v2') pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' where - mkDictInstBinder = \case A.TypedValue _ e _ -> mkDictInstBinder e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var ss (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder ctorSS cn@(Qualified cnameQB cname) _] [A.MkUnguarded _acsr]]) -> do + A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do let className :: Qualified (ProperName 'ClassName) = coerceProperName <$> cn args' <- getTypeClassArgs className - let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show i)) [1..] args' + let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show @Int i)) [1..] args' dictTyCon = srcTypeConstructor (coerceProperName <$> cn) dictTyFreeVars = foldl srcTypeApp dictTyCon args ty = quantify dictTyFreeVars @@ -365,7 +285,7 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) isDictInstCase = \case A.TypedValue _ e _ -> isDictInstCase e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var ss (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name + A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name _ -> False isDictCtor = \case @@ -377,19 +297,20 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) A.Var NullSourceSpan _ -> True A.Unused{} -> True _ -> False -exprToCoreFn mn ss _ (A.Unused _) = -- ????? need to figure out what this _is_ +-- Dunno what to do here. Haven't encountered an Unused so far, will need to see one to figure out how to handle them +exprToCoreFn _ _ _ (A.Unused _) = -- ????? need to figure out what this _is_ error "Don't know what to do w/ exprToCoreFn A.Unused" - -- pure $ Var (ss, com, Nothing) C.I_undefined --- exprToCoreFn mn _ (Just ty) (A.Var ss ident) = gets checkEnv >>= \env -> --- pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident -exprToCoreFn mn _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ +-- Variables should *always* be bound & typed in the Environment before we encounter them. +-- NOTE: Not sure if we should ignore a type passed in? Generally we shouldn't *pass* types here, but bind variables +exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident Nothing -> do -- pEnv <- printEnv traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) error "boom" -exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace ("exprToCoreFn IFTE") $ do +-- If-Then-Else Turns into a case expression +exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do ifteTy <- inferType mTy ifte condE <- exprToCoreFn mn ss (Just tyBoolean) cond thE <- exprToCoreFn mn ss Nothing th @@ -397,99 +318,55 @@ exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace ("exprToCoreFn pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] (Right thE) - , CaseAlternative [NullBinder (ssAnn ss)] -- * + , CaseAlternative [NullBinder (ssAnn ss)] (Right elE) ] -exprToCoreFn mn _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do +-- Constructor case is straightforward, we should already have all of the type info +exprToCoreFn _ _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do env <- gets checkEnv let ctorMeta = getConstructorMeta env name ctorType <- inferType mTy ctor pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name -exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace ("exprToCoreFn CASE") $ do +-- Case expressions +exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do traceM $ renderValue 100 astCase - caseTy <- inferType mTy astCase - ts <- traverse (infer >=> pure . tvType) vs -- instantiateForBinders vs alts -- might be wrong, instantiation might screw up the tyvars NOTE/FIXME: Definitely wrong + caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. + ts <- traverse (infer >=> pure . tvType) vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list) traceM $ ppType 100 caseTy pTrace vs - vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe? - alts' <- traverse (altToCoreFn mn ss caseTy ts) alts + vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe zipWithM + alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s) pure $ Case (ssA ss) (purusTy caseTy) vs' alts' where tvType (TypedValue' _ _ t) = t - -exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace ("exprToCoreFn TV1") $ +-- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct. +exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $ exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace ("exprToCoreFn TV2") $ +exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $ exprToCoreFn mn ss (Just ty) v -exprToCoreFn mn ss mTy astLet@(A.Let w ds v) = wrapTrace ("exprToCoreFn LET") $ case NE.nonEmpty ds of +-- Let bindings. Complicated. +exprToCoreFn mn ss _ (A.Let w ds v) = wrapTrace "exprToCoreFn LET" $ case NE.nonEmpty ds of Nothing -> error "declarations in a let binding can't be empty" - Just ds' -> do - traceM $ "exprToCoreFn LET: " - (decls,expr) <- transformLetBindings mn ss [] ds v -- typesOf RecursiveBindingGroup mn $ fmap stripDecls ds + Just _ -> do + traceM "exprToCoreFn LET" + (decls,expr) <- transformLetBindings mn ss [] ds v -- see transformLetBindings pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ exprToCoreFn mn ss ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e -transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) -transformLetBindings mn ss seen [] ret =(seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) --- for typed values (this might be wrong?) -transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = do - traceM $ "transformLetBindings 1 " <> T.unpack (showIdent ident) - {- -TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do - traceM $ "transformLetBindings 1.1" - ((args, elabTy), kind) <- kindOfWithScopedVars ty - traceM $ "transformLetBindings 1.2" - checkTypeKind ty kind - traceM $ "transformLetBindings 1.3" - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) - traceM $ "transformLetBindings 1.4" - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy - traceM $ "transformLetBindings 1.5" - if checkType - then withScopedTypeVars mn args $ bindNames dict $ check val ty' - else return (TypedValue' checkType val elabTy) - -} - traceM $ "transformLetBindings 1.6" - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do - traceM $ "transformLetBindings 1.7" - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) - traceM $ "transformLetBindings 1.8" - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret --- TODO / FIXME: Rewrite the below definitions to avoid doing any type checking -transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = do - traceM $ "transformLetBindings 2 " <> T.unpack (showIdent ident) - valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) - bindNames dict $ infer val - traceM "transformLetBindings 2.1" - warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - traceM "transformLetBindings 2.2" - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret -transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = do - traceM $ "transformLetBindings bindingGroup" - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds - ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] - bindNames dict $ do - makeBindingGroupVisible - thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret -transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" - - -- Desugars case alternatives from AST to CoreFn representation. -altToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> SourceType -> [SourceType] -> A.CaseAlternative -> m (CaseAlternative Ann) +altToCoreFn :: forall m + . M m + => ModuleName + -> SourceSpan + -> SourceType -- The "return type", i.e., the type of the expr to the right of the -> in a case match branch + -> [SourceType] -- The types of the *scrutinees*, i.e. the `x` in `case x of (...)`. NOTE: Still not sure why there can be more than one + -> A.CaseAlternative + -> m (CaseAlternative Ann) altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCoreFn" $ do env <- gets checkEnv - bTypes <- M.unions <$> zipWithM inferBinder' boundTypes bs + bTypes <- M.unions <$> zipWithM inferBinder' boundTypes bs -- Inferring the types for binders requires some special machinery & knowledge of the scrutinee type. NOTE: Not sure why multiple binders? let toBind = (\(n',(ss',ty')) -> (ss',n',ty',Defined)) <$> M.toList bTypes binders = binderToCoreFn env mn ss <$> bs traceM $ concatMap (\x -> show x <> "\n") toBind @@ -498,137 +375,70 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo where go :: [(SourceSpan, Ident, SourceType, NameVisibility)] -> [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) go toBind [A.MkUnguarded e] = wrapTrace "altToCoreFn GO" $ do - expr <- bindLocalVariables toBind $ exprToCoreFn mn ss (Just ret) e + expr <- bindLocalVariables toBind $ exprToCoreFn mn ss (Just ret) e -- need to bind all variables that occur in the binders. We know the type of the right hand side (as it was passed in) pure $ Right expr + -- NOTE: Not sure whether this works / TODO: Make a test case that uses guards in case expressions go _ gs = do ges <- forM gs $ \case A.GuardedExpr g e -> do let cond = guardToExpr g condE <- exprToCoreFn mn ss Nothing cond - eE <- exprToCoreFn mn ss Nothing e + eE <- exprToCoreFn mn ss (Just ret) e pure (condE,eE) pure . Left $ ges guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" --- Desugars case binders from AST to CoreFn representation. -binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann -binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = - let lit' = binderToCoreFn env mn ss <$> lit - in LiteralBinder (ss, [], Nothing) lit' -binderToCoreFn _ mn ss A.NullBinder = - NullBinder (ss, [], Nothing) -binderToCoreFn _ mn _ss vb@(A.VarBinder ss name) = trace ("binderToCoreFn: " <> show vb ) $ - VarBinder (ss, [], Nothing) name -binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = - let (_, tctor, _, _) = lookupConstructor env dctor - args = binderToCoreFn env mn _ss <$> bs - in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args -binderToCoreFn env mn _ss (A.NamedBinder ss name b) = - let arg = binderToCoreFn env mn _ss b - in NamedBinder (ss, [], Nothing) name arg -binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = - binderToCoreFn env mn ss b -binderToCoreFn env mn ss (A.TypedBinder _ b) = - binderToCoreFn env mn ss b -binderToCoreFn _ _ _ A.OpBinder{} = - internalError "OpBinder should have been desugared before binderToCoreFn" -binderToCoreFn _ _ _ A.BinaryNoParensBinder{} = - internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" -binderToCoreFn _ _ _ A.ParensInBinder{} = - internalError "ParensInBinder should have been desugared before binderToCoreFn" - --- Gets metadata for let bindings. -getLetMeta :: A.WhereProvenance -> Maybe Meta -getLetMeta A.FromWhere = Just IsWhere -getLetMeta A.FromLet = Nothing - --- Gets metadata for values. -getValueMeta :: Environment -> Qualified Ident -> Maybe Meta -getValueMeta env name = - case lookupValue env name of - Just (_, External, _) -> Just IsForeign - _ -> Nothing - --- Gets metadata for data constructors. -getConstructorMeta :: Environment -> Qualified (ProperName 'ConstructorName) -> Meta -getConstructorMeta env ctor = - case lookupConstructor env ctor of - (Newtype, _, _, _) -> IsNewtype - dc@(Data, _, _, fields) -> - let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType - in IsConstructor constructorType fields - where - - numConstructors - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> Int - numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env - - typeConstructor - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) - -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) - typeConstructor _ = internalError "Invalid argument to typeConstructor" - --- | Find module names from qualified references to values. This is used to --- ensure instances are imported from any module that is referenced by the --- current module, not just from those that are imported explicitly (#667). -findQualModules :: [A.Declaration] -> [ModuleName] -findQualModules decls = - let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in f `concatMap` decls - -fqDecls :: A.Declaration -> [ModuleName] -fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q -fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q -fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q -fqDecls _ = [] - -fqValues :: A.Expr -> [ModuleName] -fqValues (A.Var _ q) = getQual' q -fqValues (A.Constructor _ q) = getQual' q -fqValues _ = [] - -fqBinders :: A.Binder -> [ModuleName] -fqBinders (A.ConstructorBinder _ q _) = getQual' q -fqBinders _ = [] +{- Dirty hacks. If something breaks, odds are pretty good that it has something do with something here. -getQual' :: Qualified a -> [ModuleName] -getQual' = maybe [] return . getQual + These two functions are adapted from utilities in Language.PureScript.TypeChecker.Types: + - transformLetBindings is a modification of inferLetBindings + - inferBinder' is a modification of inferBinder' --- | Desugars import declarations from AST to CoreFn representation. -importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) --- TODO: We probably *DO* want types here -importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) -importToCoreFn _ = Nothing + We need functions that perform the same tasks as those in TypeChecker.Types, but we cannot use the + existing functions because they call instantiatePolyTypeWithUnknowns. Instantiating a polytype to + an unknown type is correct *during the initial typechecking phase*, but it is disastrous for us + because we need to preserve the quantifiers explicitly in the typed AST. --- | Desugars foreign declarations from AST to CoreFn representation. -externToCoreFn :: A.Declaration -> Maybe Ident -externToCoreFn (A.ExternDeclaration _ name _) = Just name -externToCoreFn _ = Nothing - --- | Desugars export declarations references from AST to CoreFn representation. --- CoreFn modules only export values, so all data constructors, instances and --- values are flattened into one list. -exportToCoreFn :: A.DeclarationRef -> [Ident] -exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors -exportToCoreFn (A.TypeRef _ _ Nothing) = [] -exportToCoreFn (A.TypeOpRef _ _) = [] -exportToCoreFn (A.ValueRef _ name) = [name] -exportToCoreFn (A.ValueOpRef _ _) = [] -exportToCoreFn (A.TypeClassRef _ _) = [] -exportToCoreFn (A.TypeInstanceRef _ name _) = [name] -exportToCoreFn (A.ModuleRef _ _) = [] -exportToCoreFn (A.ReExportRef _ _ _) = [] + Both of these functions work for reasonably simple examples, but may fail in more complex cases. + The primary reason for this is: I'm not sure how to write PS source that contains some of the + weirder cases in the AST. We'll have to deal with any problems once we have examples that + clearly isolate the problematic syntax nodes. +-} --- | Converts a ProperName to an Ident. -properToIdent :: ProperName a -> Ident -properToIdent = Ident . runProperName --- We need a version that *doesn't* instantiate polytypes to unknowns +transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) +transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) +transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = + wrapTrace ("transformLetBindings VALDEC TYPED" <> showIdent' ident) $ bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +-- TODO / FIXME: Rewrite the below definitions to avoid doing any type checking +transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident) $ do + valTy <- freshTypeWithKind kindType + TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) + bindNames dict $ infer val + warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do + traceM "transformLetBindings bindingGroup" + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds + ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict + let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + bindNames dict $ do + makeBindingGroupVisible + thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret +transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" --- | Infer the types of variables brought into scope by a binder +-- | Infer the types of variables brought into scope by a binder *without* instantiating polytypes to unknowns. inferBinder' :: forall m . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -636,35 +446,30 @@ inferBinder' -> A.Binder -> m (M.Map Ident (SourceSpan, SourceType)) inferBinder' _ A.NullBinder = return M.empty -inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty -inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty -inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty -inferBinder' val (A.VarBinder ss name) = return $ M.singleton name (ss, val) -inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder CTOR: " <> show ctor) $ do +inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ unifyTypes val tyString >> return M.empty +inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ unifyTypes val tyChar >> return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ unifyTypes val tyInt >> return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ unifyTypes val tyNumber >> return M.empty +inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty +inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name)) $ return $ M.singleton name (ss, val) +inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do env <- getEnv case M.lookup ctor (dataConstructors env) of Just (_, _, ty, _) -> do traceM (ppType 100 ty) - -- (_, fn') <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty - -- traceM (ppType 100 fn') let (args, ret) = peelArgs ty - expected = length args - actual = length binders - -- unless (expected == actual) . throwError . errorMessage' ss $ IncorrectConstructorArity ctor expected actual unifyTypes ret val M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - peelArgs :: Type a -> ([Type a], Type a) + peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. peelArgs = go [] where go args (ForAll _ _ _ _ innerTy _) = go args innerTy go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) -- TODO/FIXME: The cases below need to be scrutinized/rewritten to avoid any subtle polytype instantiation -inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = do +inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do row <- freshTypeWithKind (kindRow kindType) rest <- freshTypeWithKind (kindRow kindType) m1 <- inferRowProperties row rest props @@ -678,21 +483,22 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = do m1 <- inferBinder' propTy binder m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders return $ m1 `M.union` m2 -inferBinder' val (A.LiteralBinder _ (ArrayLiteral binders)) = do +inferBinder' val (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do el <- freshTypeWithKind kindType m1 <- M.unions <$> traverse (inferBinder' el) binders unifyTypes val (srcTypeApp tyArray el) return m1 -inferBinder' val (A.NamedBinder ss name binder) = +-- NOTE/TODO/FIXME: I'm not sure how to construct an expression with the following binders, which makes it hard to tell whether this works! +inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $ warnAndRethrowWithPositionTC ss $ do m <- inferBinder' val binder return $ M.insert name (ss, val) m -inferBinder' val (A.PositionedBinder pos _ binder) = +inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POSITIONEDBINDER" $ warnAndRethrowWithPositionTC pos $ inferBinder' val binder -inferBinder' val (A.TypedBinder ty binder) = do +inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do (elabTy, kind) <- kindOf ty checkTypeKind ty kind - ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy + ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy -- FIXME: This is almost certainly wrong (but I dunno how to get a typed binder to test it on) unifyTypes val ty1 inferBinder' ty1 binder inferBinder' _ A.OpBinder{} = diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs new file mode 100644 index 00000000..a5002a14 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -0,0 +1,288 @@ +{- HLINT ignore "Use void" -} +{- HLINT ignore "Use <$" -} +{- HLINT ignore "Use <&>" -} +module Language.PureScript.CoreFn.Desugar.Utils where + +import Prelude +import Protolude (MonadError (..)) + +import Data.Function (on) +import Data.Tuple (swap) +import Data.Map qualified as M + +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.Traversals (everythingOnValues) +import Language.PureScript.CoreFn.Ann (Ann) +import Language.PureScript.CoreFn.Binders (Binder(..)) +import Language.PureScript.CoreFn.Expr (Expr(..), PurusType) +import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment ( DataDeclType(..), Environment(..), NameKind(..), lookupConstructor, lookupValue, NameVisibility (..), dictTypeName, TypeClassData (typeClassArguments), function) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName) +import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp) +import Language.PureScript.AST.Binders qualified as A +import Language.PureScript.AST.Declarations qualified as A +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.State.Strict (MonadState, gets) +import Control.Monad.Writer.Class ( MonadWriter ) +import Language.PureScript.TypeChecker.Types + ( kindType, + TypedValue'(TypedValue'), + infer ) +import Language.PureScript.Errors + ( MultipleErrors ) +import Debug.Trace (traceM, trace) +import Language.PureScript.CoreFn.Pretty ( ppType ) +import Data.Text qualified as T +import Text.Pretty.Simple (pShow) +import Data.Text.Lazy qualified as LT +import Language.PureScript.TypeChecker.Monad + ( bindLocalVariables, + getEnv, + withScopedTypeVars, + CheckState(checkCurrentModule, checkEnv) ) + + +{- UTILITIES -} + +-- | Type synonym for a monad that has all of the required typechecker functionality +type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + +-- | Traverse a literal. Note that literals are usually have a type like `Literal (Expr a)`. That is: The `a` isn't typically an annotation, it's an expression type +traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) +traverseLit f = \case + NumericLiteral x -> pure $ NumericLiteral x + StringLiteral x -> pure $ StringLiteral x + CharLiteral x -> pure $ CharLiteral x + BooleanLiteral x -> pure $ BooleanLiteral x + ArrayLiteral xs -> ArrayLiteral <$> traverse f xs + ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs + +-- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) +inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType +inferType (Just t) _ = pure t +inferType Nothing e = infer e >>= \case + TypedValue' _ _ t -> pure t + +{- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: + - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous + typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. + Constraints are eliminated by replacing the constraint argument w/ the appropriate dictionary type. + + - T[1] is a function to transform the eventual expression such that it is properly typed. Basically: It puts the quantifiers back, (hopefully) in the right order and with + the correct visibility, skolem scope, etc. + + - T[2] is a monadic action which binds local variables or type variables so that we can use type inference machinery on the expression corresponding to this type. +-} +instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) +instantiatePolyType mn = \case + ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of + (inner,g,act) -> + let f = \case + Abs ann' ty' ident' expr' -> Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' + other -> other + act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) + in (inner, f . g, act') + ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of + (inner,g,act) -> + let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass + dictTyCon = srcTypeConstructor dictTyName + dictTy = foldl srcTypeApp dictTyCon constraintArgs + act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma + in (function dictTy inner,g,act') + other -> (other,id,id) + + +-- Gives much more readable output (with colors for brackets/parens!) than plain old `show` +pTrace :: (Monad m, Show a) => a -> m () +pTrace = traceM . LT.unpack . pShow + +-- | Given a string and a monadic action, produce a trace with the given message before & after the action (with pretty lines to make it more readable) +wrapTrace :: Monad m => String -> m a -> m a +wrapTrace msg act = do + traceM startMsg + res <- act + traceM endMsg + pure res + where + padding = replicate 10 '=' + pad str = padding <> str <> padding + startMsg = pad $ "BEGIN " <> msg + endMsg = pad $ "END " <> msg + +-- | Generates a pretty (ish) representation of the type environment/context. For debugging. +printEnv :: M m => m String +printEnv = do + env <- gets checkEnv + let ns = map (\(i,(st,_,_)) -> (i,st)) . M.toList $ names env + pure $ concatMap (\(i,st) -> "ENV:= " <> T.unpack (runIdent . disqualify $ i) <> " :: " <> ppType 10 st <> "\n") ns + +() :: String -> String -> String +x y = x <> "\n" <> y + +-- We need a string for traces and readability is super important here +showIdent' :: Ident -> String +showIdent' = T.unpack . runIdent + +-- | Turns a `Type a` into a `Type ()`. We shouldn't need source position information for types. +purusTy :: Type a -> PurusType +purusTy = fmap (const ()) + +-- | Given a class name, return the TypeClassData associated with the name. +getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData +getTypeClassData nm = do + env <- getEnv + case M.lookup nm (typeClasses env) of + Nothing -> error $ "No type class data for " show nm " found in" show (typeClasses env) + Just cls -> pure cls + +-- | Given a class name, return the parameters to the class and their *kinds*. (Maybe SourceType is a kind. Type classes cannot be parameterized by anything other than type variables) +getTypeClassArgs :: M m => Qualified (ProperName 'ClassName) -> m [(T.Text,Maybe SourceType)] +getTypeClassArgs nm = getTypeClassData nm >>= (pure . typeClassArguments) + + +-- | Retrieves the current module name from the context. This should never fail (as we set the module name when we start converting a module) +getModuleName :: M m => m ModuleName +getModuleName = gets checkCurrentModule >>= \case + Just mn -> pure mn + Nothing -> error "No module name found in checkState" + +-- Creates a map from a module name to the re-export references defined in +-- that module. +reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] +reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') + +toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) +toReExportRef (A.ReExportRef _ src ref) = + fmap + (, ref) + (A.exportSourceImportedFrom src) +toReExportRef _ = Nothing + +-- Remove duplicate imports +dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] +dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap + +-- | Create an Ann (with no comments or metadata) from a SourceSpan +ssA :: SourceSpan -> Ann +ssA ss = (ss, [], Nothing) + +-- Gets metadata for let bindings. +getLetMeta :: A.WhereProvenance -> Maybe Meta +getLetMeta A.FromWhere = Just IsWhere +getLetMeta A.FromLet = Nothing + +-- Gets metadata for values. +getValueMeta :: Environment -> Qualified Ident -> Maybe Meta +getValueMeta env name = + case lookupValue env name of + Just (_, External, _) -> Just IsForeign + _ -> Nothing + +-- Gets metadata for data constructors. +getConstructorMeta :: Environment -> Qualified (ProperName 'ConstructorName) -> Meta +getConstructorMeta env ctor = + case lookupConstructor env ctor of + (Newtype, _, _, _) -> IsNewtype + dc@(Data, _, _, fields) -> + let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType + in IsConstructor constructorType fields + where + + numConstructors + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> Int + numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env + + typeConstructor + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) + -> (ModuleName, ProperName 'TypeName) + typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor _ = internalError "Invalid argument to typeConstructor" + +-- | Find module names from qualified references to values. This is used to +-- ensure instances are imported from any module that is referenced by the +-- current module, not just from those that are imported explicitly (#667). +findQualModules :: [A.Declaration] -> [ModuleName] +findQualModules decls = + let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) + in f `concatMap` decls + +fqDecls :: A.Declaration -> [ModuleName] +fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q +fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q +fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q +fqDecls _ = [] + +fqValues :: A.Expr -> [ModuleName] +fqValues (A.Var _ q) = getQual' q +fqValues (A.Constructor _ q) = getQual' q +fqValues _ = [] + +fqBinders :: A.Binder -> [ModuleName] +fqBinders (A.ConstructorBinder _ q _) = getQual' q +fqBinders _ = [] + +getQual' :: Qualified a -> [ModuleName] +getQual' = maybe [] return . getQual + +-- | Converts a ProperName to an Ident. +properToIdent :: ProperName a -> Ident +properToIdent = Ident . runProperName + +-- "Pure" desugaring utils + +-- Desugars case binders from AST to CoreFn representation. Doesn't need to be monadic / essentially the same as the old version. +binderToCoreFn :: Environment -> ModuleName -> SourceSpan -> A.Binder -> Binder Ann +binderToCoreFn env mn _ss (A.LiteralBinder ss lit) = + let lit' = binderToCoreFn env mn ss <$> lit + in LiteralBinder (ss, [], Nothing) lit' +binderToCoreFn _ _ ss A.NullBinder = + NullBinder (ss, [], Nothing) +binderToCoreFn _ _ _ss vb@(A.VarBinder ss name) = trace ("binderToCoreFn: " <> show vb ) $ + VarBinder (ss, [], Nothing) name +binderToCoreFn env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = + let (_, tctor, _, _) = lookupConstructor env dctor + args = binderToCoreFn env mn _ss <$> bs + in ConstructorBinder (ss, [], Just $ getConstructorMeta env dctor) (Qualified mn' tctor) dctor args +binderToCoreFn env mn _ss (A.NamedBinder ss name b) = + let arg = binderToCoreFn env mn _ss b + in NamedBinder (ss, [], Nothing) name arg +binderToCoreFn env mn _ss (A.PositionedBinder ss _ b) = + binderToCoreFn env mn ss b +binderToCoreFn env mn ss (A.TypedBinder _ b) = + binderToCoreFn env mn ss b +binderToCoreFn _ _ _ A.OpBinder{} = + internalError "OpBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" +binderToCoreFn _ _ _ A.ParensInBinder{} = + internalError "ParensInBinder should have been desugared before binderToCoreFn" + + + +-- | Desugars import declarations from AST to CoreFn representation. +importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) +-- TODO: We probably *DO* want types here +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) +importToCoreFn _ = Nothing + +-- | Desugars foreign declarations from AST to CoreFn representation. +externToCoreFn :: A.Declaration -> Maybe Ident +externToCoreFn (A.ExternDeclaration _ name _) = Just name +externToCoreFn _ = Nothing + +-- | Desugars export declarations references from AST to CoreFn representation. +-- CoreFn modules only export values, so all data constructors, instances and +-- values are flattened into one list. +exportToCoreFn :: A.DeclarationRef -> [Ident] +exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors +exportToCoreFn (A.TypeRef _ _ Nothing) = [] +exportToCoreFn (A.TypeOpRef _ _) = [] +exportToCoreFn (A.ValueRef _ name) = [name] +exportToCoreFn (A.ValueOpRef _ _) = [] +exportToCoreFn (A.TypeClassRef _ _) = [] +exportToCoreFn (A.TypeInstanceRef _ name _) = [name] +exportToCoreFn (A.ModuleRef _ _) = [] +exportToCoreFn (A.ReExportRef _ _ _) = [] From 6e2ca01e7fd3b8392d209ccb0fbee07d56e54403 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 25 Jan 2024 18:56:34 -0500 Subject: [PATCH 15/44] Nested 'let' expressions w/ mix of type sigs/no type sigs w/ quantifiers --- src/Language/PureScript/CoreFn/Desugar.hs | 73 ++++++++++++++++------- 1 file changed, 53 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 55840de4..86f5202e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -13,18 +13,51 @@ import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), nullSourceAnn) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) import Language.PureScript.CoreFn.Meta (Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (tyArray, pattern (:->), DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue, purusFun, NameVisibility (..), tyBoolean, kindRow, tyFunction, tyRecord, tyString, tyChar, tyInt, tyNumber) +import Language.PureScript.Environment ( + tyArray, + pattern (:->), + DataDeclType(..), + Environment(..), + NameKind(..), + isDictTypeName, + lookupConstructor, + lookupValue, + purusFun, + NameVisibility (..), + tyBoolean, + kindRow, + tyFunction, + tyRecord, + tyString, + tyChar, + tyInt, + tyNumber ) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified, showIdent, runIdent, coerceProperName, Name (DctorName)) +import Language.PureScript.Names ( + pattern ByNullSourcePos, Ident(..), + ModuleName, + ProperName(..), + ProperNameType(..), + Qualified(..), + QualifiedBy(..), + mkQualified, + runIdent, + coerceProperName, + Name (DctorName)) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..), srcTypeConstructor, srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) +import Language.PureScript.Types ( + pattern REmptyKinded, + SourceType, + Type(..), + srcTypeConstructor, + srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -138,10 +171,10 @@ lookupType sp tn = do pEnv <- printEnv error $ "No type found for " <> show tn <> "\n in env:\n" <> pEnv Just (ty,_,nv) -> do - traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty + traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty pure (ty,nv) Just (ty,_,nv) -> do - traceM $ "lookupType: " <> T.unpack (showIdent tn) <> " :: " <> ppType 10 ty + traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty pure (ty,nv) {- Converts declarations from their AST to CoreFn representation, deducing types when possible & inferring them when not possible. @@ -153,7 +186,7 @@ lookupType sp tn = do declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of [(_,wrappedTy)] -> do - traceM (show ctor) + -- traceM (show ctor) let innerFunTy = quantify $ purusFun wrappedTy wrappedTy pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] @@ -165,7 +198,7 @@ declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d -- Data declarations get turned into value declarations for the constructor(s) declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do - traceM $ show ctors + --traceM $ show ctors traverse go ctors where go ctorDecl = do @@ -180,7 +213,7 @@ declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace (" (valDeclTy,nv) <- lookupType (spanStart ss) name traceM $ ppType 10 valDeclTy traceM $ renderValue 100 e - pTrace e + -- pTrace e bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? pure [NonRec (ssA ss) name expr] @@ -236,7 +269,7 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect _ = Nothing unchangedRecordFields _ _ = Nothing -- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here. -exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> T.unpack (showIdent name)) $ do +exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ do let (inner,f,bindAct) = instantiatePolyType mn t -- Strip the quantifiers & constrained type wrappers and get the innermost not-polymorphic type, a function that puts the quantifiers back, and a monadic action to bind the necessary vars/tyvars case inner of a :-> b -> do @@ -339,6 +372,7 @@ exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" where tvType (TypedValue' _ _ t) = t -- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct. +-- (I think we have to do this - the inferred type is "wrong" if it contains a class constraint) exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $ exprToCoreFn mn ss (Just ty) v exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $ @@ -360,7 +394,7 @@ altToCoreFn :: forall m . M m => ModuleName -> SourceSpan - -> SourceType -- The "return type", i.e., the type of the expr to the right of the -> in a case match branch + -> SourceType -- The "return type", i.e., the type of the expr to the right of the -> in a case match branch (we always know this) -> [SourceType] -- The types of the *scrutinees*, i.e. the `x` in `case x of (...)`. NOTE: Still not sure why there can be more than one -> A.CaseAlternative -> m (CaseAlternative Ann) @@ -382,7 +416,7 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo ges <- forM gs $ \case A.GuardedExpr g e -> do let cond = guardToExpr g - condE <- exprToCoreFn mn ss Nothing cond + condE <- exprToCoreFn mn ss Nothing cond -- (Just tyBoolean)? eE <- exprToCoreFn mn ss (Just ret) e pure (condE,eE) pure . Left $ ges @@ -415,14 +449,13 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret -- TODO / FIXME: Rewrite the below definitions to avoid doing any type checking -transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident) $ do - valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) - bindNames dict $ infer val - warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val']) +transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do + e <- exprToCoreFn mn _ss Nothing val + let valTy = const nullSourceAnn <$> exprType e -- NOTE/TODO/FIXME: ugly hack, might break something that depends on accurate sourcepos info for types (might not, needs more investigation) + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Defined)) $ do + traceM "5" + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val]) + traceM "6" let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do From 51344c88f26c128c5bf6243d526f09f25014d383 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 1 Feb 2024 01:01:49 -0500 Subject: [PATCH 16/44] Mutually recursive binding groups, binders, attempt at generalizing TUnknowns, small tweak to pretty printer --- src/Language/PureScript/CoreFn/Desugar.hs | 122 +++++++++++------- .../PureScript/CoreFn/Desugar/Utils.hs | 14 +- src/Language/PureScript/CoreFn/Pretty.hs | 6 +- src/Language/PureScript/Environment.hs | 4 + 4 files changed, 95 insertions(+), 51 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 86f5202e..1be33006 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -5,7 +5,8 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, zipWithM, MonadError (..)) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), Foldable (toList)) + import Data.Maybe (mapMaybe) @@ -23,6 +24,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment ( tyArray, pattern (:->), + pattern ArrayT, DataDeclType(..), Environment(..), NameKind(..), @@ -40,6 +42,7 @@ import Language.PureScript.Environment ( tyInt, tyNumber ) import Language.PureScript.Label (Label(..)) +import Data.IntSet qualified as IS import Language.PureScript.Names ( pattern ByNullSourcePos, Ident(..), ModuleName, @@ -50,14 +53,14 @@ import Language.PureScript.Names ( mkQualified, runIdent, coerceProperName, - Name (DctorName)) + Name (DctorName), freshIdent') import Language.PureScript.PSString (PSString) import Language.PureScript.Types ( pattern REmptyKinded, SourceType, Type(..), srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, srcRCons) + srcTypeVar, srcTypeApp, quantify, eqType, srcRCons, unknowns, everywhereOnTypesM) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -81,7 +84,7 @@ import Language.PureScript.TypeChecker.Types infer ) import Data.List.NonEmpty qualified as NE import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) -import Control.Monad (forM, (<=<), (>=>)) +import Control.Monad (forM, (<=<), (>=>), foldM) import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) import Language.PureScript.Errors ( MultipleErrors, parU, errorMessage', SimpleErrorMessage(..) ) @@ -96,7 +99,7 @@ import Language.PureScript.TypeChecker.Monad makeBindingGroupVisible, warnAndRethrowWithPositionTC, withBindingGroupVisible, - CheckState(checkEnv, checkCurrentModule) ) + CheckState(checkEnv, checkCurrentModule), lookupUnkName ) import Language.PureScript.CoreFn.Desugar.Utils ( binderToCoreFn, dedupeImports, @@ -122,6 +125,8 @@ import Language.PureScript.CoreFn.Desugar.Utils traverseLit, wrapTrace, M ) +import Text.Pretty.Simple (pShow) +import Data.Text.Lazy qualified as LT {- CONVERSION MACHINERY @@ -198,7 +203,6 @@ declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d -- Data declarations get turned into value declarations for the constructor(s) declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do - --traceM $ show ctors traverse go ctors where go ctorDecl = do @@ -209,13 +213,11 @@ declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ( -- NOTE: This should be OK because you can data declarations can only appear at the top-level. declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DATA GROUP DECL" $ concat <$> traverse (declToCoreFn mn) ds -- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here? +-- NOTE: Should be impossible to have a guarded expr here, make it an error declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do (valDeclTy,nv) <- lookupType (spanStart ss) name - traceM $ ppType 10 valDeclTy - traceM $ renderValue 100 e - -- pTrace e bindLocalVariables [(ss,name,valDeclTy,nv)] $ do - expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? + expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? pure [NonRec (ssA ss) name expr] -- Recursive binding groups. This is tricky. Calling `typedOf` saves us a lot of work, but it's hard to tell whether that's 100% safe here declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDING GROUP" $ do @@ -231,10 +233,11 @@ declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDIN goRecBindings ((ann,ident),(expr,ty)) = do expr' <- exprToCoreFn mn (fst ann) (Just ty) expr pure ((ssA $ fst ann,ident), expr') +-- TODO: Avoid catchall case declToCoreFn _ _ = pure [] -- Desugars expressions from AST to typed CoreFn representation. -exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) +exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) -- Literal case is straightforward exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do litT <- purusTy <$> inferType mTy astLit @@ -258,6 +261,7 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn (mTy >>= unchangedRecordFields (fmap fst vs)) vs' where + -- TODO: Optimize/Refactor Using Data.Set -- Return the unchanged labels of a closed record, or Nothing for other types or open records. unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = @@ -273,7 +277,7 @@ exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprTo let (inner,f,bindAct) = instantiatePolyType mn t -- Strip the quantifiers & constrained type wrappers and get the innermost not-polymorphic type, a function that puts the quantifiers back, and a monadic action to bind the necessary vars/tyvars case inner of a :-> b -> do - body <- bindAct $ exprToCoreFn mn ssb (Just b) v + body <- bindAct $ bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v pure . f $ Abs (ssA ssb) (purusFun a b) name body other -> error $ "Invalid function type " <> ppType 100 other -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain @@ -281,6 +285,7 @@ exprToCoreFn _ _ t lam@(A.Abs _ _) = internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t) -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. -- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType +-- TODO: Investigate whether still necessary exprToCoreFn mn ss mTy app@(A.App v1 v2) | isDictCtor v2 && isDictInstCase v1 = wrapTrace "exprToCoreFn APP DICT" $ do v2' <- exprToCoreFn mn ss Nothing v2 @@ -344,6 +349,7 @@ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ide error "boom" -- If-Then-Else Turns into a case expression exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do + -- NOTE/TODO: Don't need to call infer separately here ifteTy <- inferType mTy ifte condE <- exprToCoreFn mn ss (Just tyBoolean) cond thE <- exprToCoreFn mn ss Nothing th @@ -363,6 +369,7 @@ exprToCoreFn _ _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CT exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do traceM $ renderValue 100 astCase caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. + traceM "CASE.1" ts <- traverse (infer >=> pure . tvType) vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list) traceM $ ppType 100 caseTy pTrace vs @@ -381,7 +388,6 @@ exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" exprToCoreFn mn ss _ (A.Let w ds v) = wrapTrace "exprToCoreFn LET" $ case NE.nonEmpty ds of Nothing -> error "declarations in a let binding can't be empty" Just _ -> do - traceM "exprToCoreFn LET" (decls,expr) <- transformLetBindings mn ss [] ds v -- see transformLetBindings pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ @@ -439,39 +445,65 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo weirder cases in the AST. We'll have to deal with any problems once we have examples that clearly isolate the problematic syntax nodes. -} - - transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = - wrapTrace ("transformLetBindings VALDEC TYPED" <> showIdent' ident) $ bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret --- TODO / FIXME: Rewrite the below definitions to avoid doing any type checking + wrapTrace ("transformLetBindings VALDEC TYPED " <> showIdent' ident <> " :: " <> ppType 100 ty ) $ + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do - e <- exprToCoreFn mn _ss Nothing val - let valTy = const nullSourceAnn <$> exprType e -- NOTE/TODO/FIXME: ugly hack, might break something that depends on accurate sourcepos info for types (might not, needs more investigation) - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Defined)) $ do - traceM "5" - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded val]) - traceM "6" + _ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} + ty <- generalizeUnknowns _ty + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)]) let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret +-- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do - traceM "transformLetBindings bindingGroup" + traceM "a" SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds - ds1' <- parU typed $ \e -> checkTypedBindingGroupElement mn e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] - bindNames dict $ do - makeBindingGroupVisible - thisDecl <- declToCoreFn mn (A.BindingGroupDeclaration ds') - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret + if null untyped + then do + traceM "b" + let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + traceM "c" + bindNames dict $ do + makeBindingGroupVisible + thisDecl <- concat <$> traverse (declToCoreFn mn) ds' + traceM "e" + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret + else error $ "untyped binding group element after initial typechecker pass: \n" <> LT.unpack (pShow untyped) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" +-- TODO: Make less convoluted +-- Problem: Doesn't give us kind information. Do we need it? +generalizeUnknowns :: forall (m :: * -> *) (a :: *). M m => Type a -> m (Type a) +generalizeUnknowns t = do + let unks = IS.toList $ unknowns t + t' <- foldM gogo t unks + pure . quantify $ t' + where + go :: T.Text -> Int -> Type a -> m (Type a) + go nm ti = \case + tu@(TUnknown ann i) -> + if i == ti + then pure $ TypeVar ann nm + else pure tu + other -> pure other + + gogo :: Type a -> IS.Key -> m (Type a) + gogo acc i = lookupUnkName i >>= \case + Just nm -> go nm i acc + Nothing -> do + fresh <- runIdent <$> freshIdent' + everywhereOnTypesM (go fresh i) acc + + -- | Infer the types of variables brought into scope by a binder *without* instantiating polytypes to unknowns. +-- TODO: Check whether unifyTypes needed inferBinder' :: forall m . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -491,17 +523,17 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder Just (_, _, ty, _) -> do traceM (ppType 100 ty) let (args, ret) = peelArgs ty - unifyTypes ret val + unifyTypes ret val -- TODO: Check whether necesseary? M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where + -- NOTE: Maybe forbid invalid return types? peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. peelArgs = go [] where go args (ForAll _ _ _ _ innerTy _) = go args innerTy go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) --- TODO/FIXME: The cases below need to be scrutinized/rewritten to avoid any subtle polytype instantiation inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do row <- freshTypeWithKind (kindRow kindType) rest <- freshTypeWithKind (kindRow kindType) @@ -516,11 +548,10 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin m1 <- inferBinder' propTy binder m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders return $ m1 `M.union` m2 -inferBinder' val (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do - el <- freshTypeWithKind kindType - m1 <- M.unions <$> traverse (inferBinder' el) binders - unifyTypes val (srcTypeApp tyArray el) - return m1 +-- TODO: Remove ArrayT pattern synonym +inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do + M.unions <$> traverse (inferBinder' val) binders +inferBinder' _ (A.LiteralBinder _ (ArrayLiteral _)) = internalError "bad type in array binder " -- NOTE/TODO/FIXME: I'm not sure how to construct an expression with the following binders, which makes it hard to tell whether this works! inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $ warnAndRethrowWithPositionTC ss $ do @@ -530,10 +561,9 @@ inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POS warnAndRethrowWithPositionTC pos $ inferBinder' val binder inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do (elabTy, kind) <- kindOf ty - checkTypeKind ty kind - ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy -- FIXME: This is almost certainly wrong (but I dunno how to get a typed binder to test it on) - unifyTypes val ty1 - inferBinder' ty1 binder + checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner + unifyTypes val elabTy -- ty1 + inferBinder' elabTy binder inferBinder' _ A.OpBinder{} = internalError "OpBinder should have been desugared before inferBinder'" inferBinder' _ A.BinaryNoParensBinder{} = diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index a5002a14..45a746dc 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -42,6 +42,7 @@ import Language.PureScript.TypeChecker.Monad getEnv, withScopedTypeVars, CheckState(checkCurrentModule, checkEnv) ) +import Language.PureScript.Pretty.Values (renderValue) {- UTILITIES -} @@ -62,8 +63,9 @@ traverseLit f = \case -- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType inferType (Just t) _ = pure t -inferType Nothing e = infer e >>= \case - TypedValue' _ _ t -> pure t +inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: " <> renderValue 100 e) >> + infer e >>= \case + TypedValue' _ _ t -> pure t {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous @@ -74,14 +76,20 @@ inferType Nothing e = infer e >>= \case the correct visibility, skolem scope, etc. - T[2] is a monadic action which binds local variables or type variables so that we can use type inference machinery on the expression corresponding to this type. + NOTE: The only local vars this will bind are "dict" identifiers introduced to type desguared typeclass constraints. + That is: If you're using this on a function type, you'll still have to bind the antecedent type to the + identifier bound in the VarBinder. -} +-- TODO: Explicitly return two sourcetypes for arg/return types instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) instantiatePolyType mn = \case ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of (inner,g,act) -> let f = \case - Abs ann' ty' ident' expr' -> Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' + Abs ann' ty' ident' expr' -> + Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' other -> other + -- FIXME: kindType? act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) in (inner, f . g, act') ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 29d9e8d5..60975d76 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -110,12 +110,14 @@ prettyPrintDeclaration d b = case b of NonRec _ ident expr -> vcat left [ text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr, -- not sure about the d here + text "\n" ] Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> vcat left [ text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr, + text "\n" ]) bindings prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 54859f7b..08a8c576 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -375,6 +375,10 @@ pattern a :-> b <- (TypeApp _ (TypeConstructor _ C.Function) a) b +pattern ArrayT :: Type a -> Type a +pattern ArrayT a <- + TypeApp _ (TypeConstructor _ C.Array) a + getFunArgTy :: Type () -> Type () getFunArgTy = \case a :-> _ -> a From 722a0cc1dc8874f0615cf9957584245212b55abb Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 1 Feb 2024 01:11:38 -0500 Subject: [PATCH 17/44] fixed small mistake, deleted some traces, added comment or two --- src/Language/PureScript/CoreFn/Desugar.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 1be33006..28889d52 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -462,19 +462,16 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU transformLetBindings mn _ss seen' rest ret -- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do - traceM "a" SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds if null untyped then do - traceM "b" let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] - traceM "c" bindNames dict $ do makeBindingGroupVisible thisDecl <- concat <$> traverse (declToCoreFn mn) ds' - traceM "e" let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret + -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope. else error $ "untyped binding group element after initial typechecker pass: \n" <> LT.unpack (pShow untyped) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" @@ -496,7 +493,7 @@ generalizeUnknowns t = do gogo :: Type a -> IS.Key -> m (Type a) gogo acc i = lookupUnkName i >>= \case - Just nm -> go nm i acc + Just nm -> everywhereOnTypesM (go nm i) acc Nothing -> do fresh <- runIdent <$> freshIdent' everywhereOnTypesM (go fresh i) acc From 02129dd3618daf5b2dd1d94fc89535776f000002 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Fri, 2 Feb 2024 20:20:29 -0500 Subject: [PATCH 18/44] Fixed mutual recursion bug in declToCoreFn, removed let generalization machinery --- src/Language/PureScript/CoreFn/Desugar.hs | 82 ++++++++----------- .../PureScript/CoreFn/Desugar/Utils.hs | 49 +++++++++-- 2 files changed, 79 insertions(+), 52 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 28889d52..24308f92 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,14 +1,11 @@ {- HLINT ignore "Use void" -} {- HLINT ignore "Use <$" -} {-# LANGUAGE TypeApplications #-} - module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), Foldable (toList)) - - import Data.Maybe (mapMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M @@ -60,7 +57,7 @@ import Language.PureScript.Types ( SourceType, Type(..), srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, srcRCons, unknowns, everywhereOnTypesM) + srcTypeVar, srcTypeApp, quantify, eqType, srcRCons, unknowns, everywhereOnTypesM, containsUnknowns) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -124,7 +121,9 @@ import Language.PureScript.CoreFn.Desugar.Utils toReExportRef, traverseLit, wrapTrace, - M ) + traceNameTypes, + M, + ) import Text.Pretty.Simple (pShow) import Data.Text.Lazy qualified as LT @@ -221,18 +220,20 @@ declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace (" pure [NonRec (ssA ss) name expr] -- Recursive binding groups. This is tricky. Calling `typedOf` saves us a lot of work, but it's hard to tell whether that's 100% safe here declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDING GROUP" $ do - let stripped :: [((A.SourceAnn, Ident), A.Expr)] = NE.toList $ (\(((ss, com), name), _, e) -> (((ss, com), name), e)) <$> ds - types <- typesOf RecursiveBindingGroup mn stripped -- NOTE: If something weird breaks, look here. It's possible that `typesOf` makes calls to type CHECKING machinery that we don't want to ever invoke. - recBody <- bindLocalVariables (prepareBind <$> types) $ traverse goRecBindings types + let typed = NE.toList $ extractTypeAndPrepareBind <$> ds + toBind = snd <$> typed + recBody <- bindLocalVariables toBind $ traverse goRecBindings typed pure [Rec recBody] where - prepareBind :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> (SourceSpan, Ident, SourceType, NameVisibility) - prepareBind (((ss',_),ident),(_,sty)) = (ss',ident,sty,Defined) - - goRecBindings :: ((A.SourceAnn, Ident), (A.Expr, SourceType)) -> m ((Ann, Ident), Expr Ann) - goRecBindings ((ann,ident),(expr,ty)) = do - expr' <- exprToCoreFn mn (fst ann) (Just ty) expr - pure ((ssA $ fst ann,ident), expr') + -- If we only ever call this on a top-level binding group then this should be OK, all the exprs should be explicitly typed + extractTypeAndPrepareBind :: ((A.SourceAnn, Ident), NameKind, A.Expr) -> (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) + extractTypeAndPrepareBind (((ss',_),ident),_,A.TypedValue _ e ty) = (e,(ss',ident,ty,Defined)) + extractTypeAndPrepareBind (((ss',_),ident),_,_) = error $ "Top level declaration " <> (showIdent' ident) <> " should have a type annotation, but does not" + + goRecBindings :: (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) -> m ((Ann, Ident), Expr Ann) + goRecBindings (expr,(ss',ident,ty,nv)) = do + expr' <- exprToCoreFn mn ss' (Just ty) expr + pure ((ssA ss',ident), expr') -- TODO: Avoid catchall case declToCoreFn _ _ = pure [] @@ -281,6 +282,7 @@ exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprTo pure . f $ Abs (ssA ssb) (purusFun a b) name body other -> error $ "Invalid function type " <> ppType 100 other -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain +-- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t) -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. @@ -445,6 +447,8 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo weirder cases in the AST. We'll have to deal with any problems once we have examples that clearly isolate the problematic syntax nodes. -} +-- TODO: Figure out why exprs in a valuedec are a list, maybe fix? +-- TODO: Trees that grow (paper) transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = @@ -453,51 +457,35 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret +-- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do - _ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} - ty <- generalizeUnknowns _ty - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)]) - let seen' = seen ++ thisDecl - transformLetBindings mn _ss seen' rest ret + ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} + if not (containsUnknowns ty) + then bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)]) + let seen' = seen ++ thisDecl + transformLetBindings mn _ss seen' rest ret + else error + $ "The inferred type for let-bound identifier \n '" + <> showIdent' ident + <> "'\ncontains unification variables:\n " + <> ppType 1000 ty + <> "\nPlease add a type signature for '" <> showIdent' ident <> "'" -- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds if null untyped then do - let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] bindNames dict $ do makeBindingGroupVisible - thisDecl <- concat <$> traverse (declToCoreFn mn) ds' + thisDecl <- concat <$> traverse (declToCoreFn mn) ds' let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope. - else error $ "untyped binding group element after initial typechecker pass: \n" <> LT.unpack (pShow untyped) + else error $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" <> LT.unpack (pShow untyped) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" --- TODO: Make less convoluted --- Problem: Doesn't give us kind information. Do we need it? -generalizeUnknowns :: forall (m :: * -> *) (a :: *). M m => Type a -> m (Type a) -generalizeUnknowns t = do - let unks = IS.toList $ unknowns t - t' <- foldM gogo t unks - pure . quantify $ t' - where - go :: T.Text -> Int -> Type a -> m (Type a) - go nm ti = \case - tu@(TUnknown ann i) -> - if i == ti - then pure $ TypeVar ann nm - else pure tu - other -> pure other - - gogo :: Type a -> IS.Key -> m (Type a) - gogo acc i = lookupUnkName i >>= \case - Just nm -> everywhereOnTypesM (go nm i) acc - Nothing -> do - fresh <- runIdent <$> freshIdent' - everywhereOnTypesM (go fresh i) acc - -- | Infer the types of variables brought into scope by a binder *without* instantiating polytypes to unknowns. -- TODO: Check whether unifyTypes needed diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index 45a746dc..04b53fb5 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -4,7 +4,8 @@ module Language.PureScript.CoreFn.Desugar.Utils where import Prelude -import Protolude (MonadError (..)) +import Prelude qualified as P +import Protolude (MonadError (..), traverse_) import Data.Function (on) import Data.Tuple (swap) @@ -24,7 +25,7 @@ import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcType import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Strict (MonadState, gets) +import Control.Monad.State.Strict (MonadState, gets, modify') import Control.Monad.Writer.Class ( MonadWriter ) import Language.PureScript.TypeChecker.Types ( kindType, @@ -41,7 +42,7 @@ import Language.PureScript.TypeChecker.Monad ( bindLocalVariables, getEnv, withScopedTypeVars, - CheckState(checkCurrentModule, checkEnv) ) + CheckState(checkCurrentModule, checkEnv), debugNames ) import Language.PureScript.Pretty.Values (renderValue) @@ -63,9 +64,11 @@ traverseLit f = \case -- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType inferType (Just t) _ = pure t -inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: " <> renderValue 100 e) >> +inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> infer e >>= \case - TypedValue' _ _ t -> pure t + TypedValue' _ _ t -> do + traceM ("TYPE: " <> ppType 100 t) + pure t {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous @@ -102,6 +105,42 @@ instantiatePolyType mn = \case other -> (other,id,id) +traceNameTypes :: M m => m () +traceNameTypes = do + nametypes <- getEnv >>= pure . debugNames + traverse_ traceM nametypes + +{- Since we operate on an AST where constraints have been desugared to dictionaries at the *expr* level, + using a typechecker context which contains ConstrainedTypes, looking up the type for a class method + will always give us a "wrong" type. Let's try fixing them in the context! + +-} +desugarConstraintType' :: SourceType -> SourceType +desugarConstraintType' = \case + ForAll a vis var mbk t mSkol -> + let t' = desugarConstraintType' t + in ForAll a vis var mbk t' mSkol + ConstrainedType _ Constraint{..} t -> + let inner = desugarConstraintType' t + dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass + dictTyCon = srcTypeConstructor dictTyName + dictTy = foldl srcTypeApp dictTyCon constraintArgs + in function dictTy inner + other -> other + +desugarConstraintType :: M m => Qualified Ident -> m () +desugarConstraintType i = do + env <- getEnv + let oldNameTypes = names env + case M.lookup i oldNameTypes of + Just (t,k,v) -> do + let newVal = (desugarConstraintType' t, k, v) + newNameTypes = M.insert i newVal oldNameTypes + newEnv = env {names = newNameTypes} + modify' $ \checkstate -> checkstate {checkEnv = newEnv} + + + -- Gives much more readable output (with colors for brackets/parens!) than plain old `show` pTrace :: (Monad m, Show a) => a -> m () pTrace = traceM . LT.unpack . pShow From b2befc1cb4abad6d3a6e5ec3784dfe826797e9ba Mon Sep 17 00:00:00 2001 From: gnumonik Date: Mon, 5 Feb 2024 23:59:54 -0500 Subject: [PATCH 19/44] Fixed problem w/ object literal binders, cleaned up the interface of instantiatePolyTypes --- src/Language/PureScript/CoreFn/Desugar.hs | 102 ++++++++---------- .../PureScript/CoreFn/Desugar/Utils.hs | 31 +++++- src/Language/PureScript/Environment.hs | 6 ++ 3 files changed, 79 insertions(+), 60 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 24308f92..9c361f43 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -4,14 +4,14 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), Foldable (toList)) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn) import Data.Maybe (mapMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), nullSourceAnn) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) @@ -19,7 +19,6 @@ import Language.PureScript.CoreFn.Meta (Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment ( - tyArray, pattern (:->), pattern ArrayT, DataDeclType(..), @@ -31,15 +30,12 @@ import Language.PureScript.Environment ( purusFun, NameVisibility (..), tyBoolean, - kindRow, tyFunction, - tyRecord, tyString, tyChar, tyInt, tyNumber ) import Language.PureScript.Label (Label(..)) -import Data.IntSet qualified as IS import Language.PureScript.Names ( pattern ByNullSourcePos, Ident(..), ModuleName, @@ -50,14 +46,14 @@ import Language.PureScript.Names ( mkQualified, runIdent, coerceProperName, - Name (DctorName), freshIdent') + Name (DctorName)) import Language.PureScript.PSString (PSString) import Language.PureScript.Types ( pattern REmptyKinded, SourceType, Type(..), srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, srcRCons, unknowns, everywhereOnTypesM, containsUnknowns) + srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -65,26 +61,17 @@ import Language.PureScript.Constants.Prim qualified as C import Control.Monad.State.Strict (MonadState, gets, modify) import Control.Monad.Writer.Class ( MonadWriter ) import Language.PureScript.TypeChecker.Kinds ( kindOf ) -import Language.PureScript.TypeChecker.Synonyms - ( replaceAllTypeSynonyms ) import Language.PureScript.TypeChecker.Types - ( kindType, - checkTypeKind, - freshTypeWithKind, + ( checkTypeKind, SplitBindingGroup(SplitBindingGroup), TypedValue'(TypedValue'), - BindingGroupType(RecursiveBindingGroup), - typesOf, typeDictionaryForBindingGroup, - checkTypedBindingGroupElement, - typeForBindingGroupElement, infer ) import Data.List.NonEmpty qualified as NE -import Language.PureScript.TypeChecker.Unify (unifyTypes, replaceTypeWildcards) -import Control.Monad (forM, (<=<), (>=>), foldM) -import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) +import Language.PureScript.TypeChecker.Unify (unifyTypes) +import Control.Monad (forM, (>=>)) import Language.PureScript.Errors - ( MultipleErrors, parU, errorMessage', SimpleErrorMessage(..) ) + ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) import Debug.Trace (traceM) import Language.PureScript.CoreFn.Pretty ( ppType ) import Data.Text qualified as T @@ -96,7 +83,7 @@ import Language.PureScript.TypeChecker.Monad makeBindingGroupVisible, warnAndRethrowWithPositionTC, withBindingGroupVisible, - CheckState(checkEnv, checkCurrentModule), lookupUnkName ) + CheckState(checkEnv, checkCurrentModule) ) import Language.PureScript.CoreFn.Desugar.Utils ( binderToCoreFn, dedupeImports, @@ -121,11 +108,11 @@ import Language.PureScript.CoreFn.Desugar.Utils toReExportRef, traverseLit, wrapTrace, - traceNameTypes, - M, + M, unwrapRecord, withInstantiatedFunType, ) import Text.Pretty.Simple (pShow) import Data.Text.Lazy qualified as LT +import Data.Set qualified as S {- CONVERSION MACHINERY @@ -274,13 +261,11 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect _ = Nothing unchangedRecordFields _ _ = Nothing -- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here. -exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ do - let (inner,f,bindAct) = instantiatePolyType mn t -- Strip the quantifiers & constrained type wrappers and get the innermost not-polymorphic type, a function that puts the quantifiers back, and a monadic action to bind the necessary vars/tyvars - case inner of - a :-> b -> do - body <- bindAct $ bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v - pure . f $ Abs (ssA ssb) (purusFun a b) name body - other -> error $ "Invalid function type " <> ppType 100 other +exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ + withInstantiatedFunType mn t $ \a b -> do + body <- bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v + pure $ Abs (ssA ssb) (purusFun a b) name body + -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = @@ -299,16 +284,8 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) | otherwise = wrapTrace "exprToCoreFn APP" $ do appT <- inferType mTy app - traceM $ "AppTy: " <> ppType 10 appT - traceM $ "expr: " <> renderValue 10 app - traceM $ "fun expr: " <> renderValue 10 v1 - traceM $ "arg expr: " <> renderValue 10 v2 v1' <- exprToCoreFn mn ss Nothing v1 - - traceM $ "FunTy: " <> ppType 10 (exprType v1') v2' <- exprToCoreFn mn ss Nothing v2 - - traceM $ "ArgTy: " <> ppType 10 (exprType v2') pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' where mkDictInstBinder = \case @@ -420,11 +397,11 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo expr <- bindLocalVariables toBind $ exprToCoreFn mn ss (Just ret) e -- need to bind all variables that occur in the binders. We know the type of the right hand side (as it was passed in) pure $ Right expr -- NOTE: Not sure whether this works / TODO: Make a test case that uses guards in case expressions - go _ gs = do + go toBind gs = bindLocalVariables toBind $ do ges <- forM gs $ \case A.GuardedExpr g e -> do let cond = guardToExpr g - condE <- exprToCoreFn mn ss Nothing cond -- (Just tyBoolean)? + condE <- exprToCoreFn mn ss (Just tyBoolean) cond -- (Just tyBoolean)? eE <- exprToCoreFn mn ss (Just ret) e pure (condE,eE) pure . Left $ ges @@ -447,8 +424,6 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo weirder cases in the AST. We'll have to deal with any problems once we have examples that clearly isolate the problematic syntax nodes. -} --- TODO: Figure out why exprs in a valuedec are a list, maybe fix? --- TODO: Trees that grow (paper) transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret = @@ -483,7 +458,9 @@ transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wra let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope. - else error $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" <> LT.unpack (pShow untyped) + else error + $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" + <> LT.unpack (pShow untyped) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" @@ -520,24 +497,33 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do - row <- freshTypeWithKind (kindRow kindType) - rest <- freshTypeWithKind (kindRow kindType) - m1 <- inferRowProperties row rest props - unifyTypes val (srcTypeApp tyRecord row) - return m1 + let props' = sortOn fst props + case unwrapRecord val of + Left notARecord -> error + $ "Internal error while desugaring binders to CoreFn: \nType " + <> ppType 100 notARecord + <> "\n is not a record type" + Right rowItems -> do + let typeKeys = S.fromList $ fst <$> rowItems + exprKeys = S.fromList $ fst <$> props' + -- The type-level labels are authoritative + diff = S.difference typeKeys exprKeys + if S.null diff + then deduceRowProperties (M.fromList rowItems) props' -- M.unions <$> zipWithM inferBinder' (snd <$> rowItems) (snd <$> props') + else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff where - inferRowProperties :: SourceType -> SourceType -> [(PSString, A.Binder)] -> m (M.Map Ident (SourceSpan, SourceType)) - inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty - inferRowProperties nrow row ((name, binder):binders) = do - propTy <- freshTypeWithKind kindType - m1 <- inferBinder' propTy binder - m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders - return $ m1 `M.union` m2 + deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType)) + deduceRowProperties types [] = pure M.empty + deduceRowProperties types ((lbl,bndr):rest) = case M.lookup lbl types of + Nothing -> error $ "Cannot deduce type information for record with label " <> show lbl -- should be impossible after typechecking + Just ty -> do + x <- inferBinder' ty bndr + xs <- deduceRowProperties types rest + pure $ M.union x xs -- TODO: Remove ArrayT pattern synonym inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do M.unions <$> traverse (inferBinder' val) binders inferBinder' _ (A.LiteralBinder _ (ArrayLiteral _)) = internalError "bad type in array binder " --- NOTE/TODO/FIXME: I'm not sure how to construct an expression with the following binders, which makes it hard to tell whether this works! inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $ warnAndRethrowWithPositionTC ss $ do m <- inferBinder' val binder @@ -547,7 +533,7 @@ inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POS inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do (elabTy, kind) <- kindOf ty checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner - unifyTypes val elabTy -- ty1 + unifyTypes val elabTy inferBinder' elabTy binder inferBinder' _ A.OpBinder{} = internalError "OpBinder should have been desugared before inferBinder'" diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index 04b53fb5..d92ed3e8 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -19,9 +19,20 @@ import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Expr(..), PurusType) import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment ( DataDeclType(..), Environment(..), NameKind(..), lookupConstructor, lookupValue, NameVisibility (..), dictTypeName, TypeClassData (typeClassArguments), function) +import Language.PureScript.Environment ( + pattern RecordT, + DataDeclType(..), + Environment(..), + NameKind(..), + lookupConstructor, + lookupValue, + NameVisibility (..), + dictTypeName, + TypeClassData (typeClassArguments), + function, + pattern (:->)) import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName) -import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp) +import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..)) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Control.Monad.Supply.Class (MonadSupply) @@ -44,6 +55,8 @@ import Language.PureScript.TypeChecker.Monad withScopedTypeVars, CheckState(checkCurrentModule, checkEnv), debugNames ) import Language.PureScript.Pretty.Values (renderValue) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Label (Label(..)) {- UTILITIES -} @@ -70,6 +83,12 @@ inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValu traceM ("TYPE: " <> ppType 100 t) pure t +-- Wrapper around instantiatePolyType to provide a better interface +withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann) +withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of + (a :-> b, replaceForalls, bindAct) -> bindAct $ replaceForalls <$> act a b + (other,_,_) -> error + $ "Internal error. Expected a function type, but got: " <> ppType 1000 other {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. @@ -104,6 +123,14 @@ instantiatePolyType mn = \case in (function dictTy inner,g,act') other -> (other,id,id) +-- In a context where we expect a Record type (object literals, etc), unwrap the record and get at the underlying rowlist +unwrapRecord :: Type a -> Either (Type a) [(PSString,Type a)] +unwrapRecord = \case + RecordT lts -> Right $ go <$> fst (rowToSortedList lts) + other -> Left other + where + go :: RowListItem a -> (PSString, Type a) + go RowListItem{..} = (runLabel rowListLabel, rowListType) traceNameTypes :: M m => m () traceNameTypes = do diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 08a8c576..b456ba8e 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -379,6 +379,12 @@ pattern ArrayT :: Type a -> Type a pattern ArrayT a <- TypeApp _ (TypeConstructor _ C.Array) a +pattern RecordT :: Type a -> Type a +pattern RecordT a <- + TypeApp _ (TypeConstructor _ C.Record) a + + + getFunArgTy :: Type () -> Type () getFunArgTy = \case a :-> _ -> a From 5a705553f98a71746ef849bcecd8e07dafb66a61 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 12:52:49 -0700 Subject: [PATCH 20/44] Nix setup --- .gitignore | 3 + cabal.project | 4 + default.nix | 20 + flake.lock | 813 +++++++++++++++++++++++++++++++++++++ flake.nix | 107 +++++ fourmolu.yaml | 8 + nix/fourmolu/default.nix | 13 + nix/haskell/default.nix | 36 ++ nix/haskell/lib.nix | 91 +++++ nix/haskell/mk-hackage.nix | 132 ++++++ nix/plutarch/default.nix | 28 ++ nix/plutarch/lib.nix | 44 ++ nix/utils/default.nix | 22 + nix/utils/lib.nix | 39 ++ purescript.cabal | 2 +- shell.nix | 21 - 16 files changed, 1361 insertions(+), 22 deletions(-) create mode 100644 default.nix create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 fourmolu.yaml create mode 100644 nix/fourmolu/default.nix create mode 100644 nix/haskell/default.nix create mode 100644 nix/haskell/lib.nix create mode 100644 nix/haskell/mk-hackage.nix create mode 100644 nix/plutarch/default.nix create mode 100644 nix/plutarch/lib.nix create mode 100644 nix/utils/default.nix create mode 100644 nix/utils/lib.nix delete mode 100644 shell.nix diff --git a/.gitignore b/.gitignore index 0454beff..9b55e739 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,6 @@ TAGS *.ps *.svg tests/purs/make/ +.direnv/ +/.pre-commit-config.yaml +/result* diff --git a/cabal.project b/cabal.project index aa859b8b..29ca61bc 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,7 @@ repository cardano-haskell-packages packages: purescript.cabal + +-- HACK: plutus core cannot build without it, remove after bump. +constraints: + nothunks < 0.2 diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..83f611fb --- /dev/null +++ b/default.nix @@ -0,0 +1,20 @@ +{ + perSystem = { self', config, ... }: + let + purus = config.libPlutarch.mkPackage { + name = "purus"; + src = ./.; + }; + in + { + devShells.purus = purus.devShell; + + packages = { + purs = purus.packages."purescript:exe:purs"; + }; + + apps = { + purs.program = "${self'.packages.purs}/bin/purs"; + }; + }; +} diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..34d0f876 --- /dev/null +++ b/flake.lock @@ -0,0 +1,813 @@ +{ + "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-compat_2": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-parts": { + "inputs": { + "nixpkgs-lib": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1706830856, + "narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1701680307, + "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc98X": { + "flake": false, + "locked": { + "lastModified": 1696643148, + "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", + "ref": "ghc-9.8", + "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", + "revCount": 61642, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "ref": "ghc-9.8", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc99": { + "flake": false, + "locked": { + "lastModified": 1701580282, + "narHash": "sha256-drA01r3JrXnkKyzI+owMZGxX0JameMzjK0W5jJE/+V4=", + "ref": "refs/heads/master", + "rev": "f5eb0f2982e9cf27515e892c4bdf634bcfb28459", + "revCount": 62197, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "pre-commit-hooks-nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1703887061, + "narHash": "sha256-gGPa9qWNc6eCXT/+Z5/zMkyYOuRZqeFZBDbopNZQkuY=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "43e1aa1308018f37118e34d3a9cb4f5e75dc11d5", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1708215850, + "narHash": "sha256-jaxFHCObJ3uON5RNbeon795RmBG/SUFcFM77TAxx3hg=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "f5c26f4307f80cdc8ba7b762e0738c09d40a4685", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskell-nix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc98X": "ghc98X", + "ghc99": "ghc99", + "hackage": "hackage", + "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", + "iserv-proxy": "iserv-proxy", + "nix-tools-static": "nix-tools-static", + "nixpkgs": [ + "haskell-nix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-2111": "nixpkgs-2111", + "nixpkgs-2205": "nixpkgs-2205", + "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1708217408, + "narHash": "sha256-Ri9PXSAvg25bBvcJOCTsi6pRhaT8Wp37037KMfXYeOU=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "2fb6466a23873e590ef96066ee18a75998830c7b", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hci-effects": { + "inputs": { + "flake-parts": [ + "flake-parts" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1704029560, + "narHash": "sha256-a4Iu7x1OP+uSYpqadOu8VCPY+MPF3+f6KIi+MAxlgyw=", + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "rev": "d5cbf433a6ae9cae05400189a8dbc6412a03ba16", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "type": "github" + } + }, + "hls-1.10": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "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" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskell-nix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1691634696, + "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", + "ref": "hkm/remote-iserv", + "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", + "revCount": 14, + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + }, + "original": { + "ref": "hkm/remote-iserv", + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + } + }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1661606874, + "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", + "owner": "NixOS", + "repo": "nix", + "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.11.0", + "repo": "nix", + "type": "github" + } + }, + "nix-tools-static": { + "flake": false, + "locked": { + "lastModified": 1706266250, + "narHash": "sha256-9t+GRk3eO9muCtKdNAwBtNBZ5dH1xHcnS17WaQyftwA=", + "owner": "input-output-hk", + "repo": "haskell-nix-example", + "rev": "580cb6db546a7777dad3b9c0fa487a366c045c4e", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "nix", + "repo": "haskell-nix-example", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1657693803, + "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-22.05-small", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1659914493, + "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1659446231, + "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2205": { + "locked": { + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2211": { + "locked": { + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "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": { + "locked": { + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1708276637, + "narHash": "sha256-+gICdImzDvxULC/+iqsmLsvwEv5LQuFglxn2fk/VyQM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ec841889d30aabad381acfa9529fe6045268bdbd", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "pre-commit-hooks-nix": { + "inputs": { + "flake-compat": "flake-compat_2", + "flake-utils": "flake-utils", + "gitignore": "gitignore", + "nixpkgs": [ + "nixpkgs" + ], + "nixpkgs-stable": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1708018599, + "narHash": "sha256-M+Ng6+SePmA8g06CmUZWi1AjG2tFBX9WCXElBHEKnyM=", + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "rev": "5df5a70ad7575f6601d91f0efec95dd9bc619431", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-parts": "flake-parts", + "haskell-nix": "haskell-nix", + "hci-effects": "hci-effects", + "nixpkgs": "nixpkgs_2", + "pre-commit-hooks-nix": "pre-commit-hooks-nix" + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1708214991, + "narHash": "sha256-PCVnVqnBctf/qkpTBnBxwDHvfZaxXeq0bO98LxoKfhY=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "0a279134ea4ae6269b93f76638c4ed9ccd9a496a", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..dbd6c47f --- /dev/null +++ b/flake.nix @@ -0,0 +1,107 @@ +{ + description = "uplc-benchmark"; + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs"; + flake-parts = { + url = "github:hercules-ci/flake-parts"; + inputs.nixpkgs-lib.follows = "nixpkgs"; + }; + pre-commit-hooks-nix = { + url = "github:cachix/pre-commit-hooks.nix"; + inputs.nixpkgs.follows = "nixpkgs"; + inputs.nixpkgs-stable.follows = "nixpkgs"; + }; + hci-effects = { + url = "github:hercules-ci/hercules-ci-effects"; + inputs.nixpkgs.follows = "nixpkgs"; + inputs.flake-parts.follows = "flake-parts"; + }; + haskell-nix = { + url = "github:input-output-hk/haskell.nix"; + }; + }; + outputs = inputs: + let + flakeModules = { + haskell = ./nix/haskell; + plutarch = ./nix/plutarch; + utils = ./nix/utils; + }; + in + inputs.flake-parts.lib.mkFlake { inherit inputs; } ({ self, ... }: { + imports = [ + inputs.pre-commit-hooks-nix.flakeModule + inputs.hci-effects.flakeModule + ./. + ] ++ (builtins.attrValues flakeModules); + + # `nix flake show --impure` hack + systems = + if builtins.hasAttr "currentSystem" builtins + then [ builtins.currentSystem ] + else inputs.nixpkgs.lib.systems.flakeExposed; + + herculesCI.ciSystems = [ "x86_64-linux" ]; + + flake.flakeModules = flakeModules; + + perSystem = + { config + , pkgs + , lib + , system + , self' + , ... + }: { + _module.args.pkgs = import self.inputs.nixpkgs { + inherit system; + config.allowBroken = true; + }; + + pre-commit.settings = { + hooks = { + deadnix.enable = true; + # TODO: Enable in separate PR, causes mass changes. + # fourmolu.enable = true; + nixpkgs-fmt.enable = true; + typos.enable = true; + }; + + tools = { + fourmolu = lib.mkForce (pkgs.callPackage ./nix/fourmolu { + mkHaskellPackage = config.libHaskell.mkPackage; + }); + }; + + settings = { + latexindent.flags = config.libUtils.mkCli { + yaml = "\"defaultIndent:' ', onlyOneBackUp: 1\""; + local = true; + silent = true; + overwriteIfDifferent = true; + logfile = "/dev/null"; + }; + deadnix.edit = true; + }; + + excludes = [ + ".materialized" + ]; + }; + + devShells = { + default = pkgs.mkShell { + shellHook = config.pre-commit.installationScript; + + inputsFrom = [ + self'.devShells.purus + ]; + + nativeBuildInputs = [ + pkgs.fd + ]; + }; + }; + }; + }); +} diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..ed2de01b --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 2 +comma-style: leading +record-brace-space: true +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 diff --git a/nix/fourmolu/default.nix b/nix/fourmolu/default.nix new file mode 100644 index 00000000..954cbfaa --- /dev/null +++ b/nix/fourmolu/default.nix @@ -0,0 +1,13 @@ +{ mkHaskellPackage +, fetchFromGitHub +}: + +(mkHaskellPackage { + name = "fourmolu"; + src = fetchFromGitHub { + owner = "fourmolu"; + repo = "fourmolu"; + rev = "v0.13.1.0"; + hash = "sha256-abUK9KdvVI7di84X/L3vHZM97pOsciyx503aDjUnoc4="; + }; +}).packages."fourmolu:exe:fourmolu" diff --git a/nix/haskell/default.nix b/nix/haskell/default.nix new file mode 100644 index 00000000..fc5dd740 --- /dev/null +++ b/nix/haskell/default.nix @@ -0,0 +1,36 @@ +{ self +, lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; + inherit (lib) types mkOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, system, pkgs, ... }: { + options = { + libHaskell = mkOption { + type = types.anything; + default = { }; + }; + }; + + config = + let + mkHaskellPackage = pkgs.callPackage ./lib.nix { + inherit lib system; + haskellNixNixpkgs = self.inputs.haskell-nix.inputs.nixpkgs; + haskellNixOverlay = self.inputs.haskell-nix.overlay; + }; + + in + { + libHaskell = { + mkPackage = mkHaskellPackage; + }; + }; + }); + }; +} diff --git a/nix/haskell/lib.nix b/nix/haskell/lib.nix new file mode 100644 index 00000000..2dcbb208 --- /dev/null +++ b/nix/haskell/lib.nix @@ -0,0 +1,91 @@ +{ lib +, fetchFromGitHub + # e.g. "x86_64-linux" +, system # : string +, haskellNixNixpkgs # : nixpkgs +, haskellNixOverlay # : overlay +}: + +let + iohk-nix = fetchFromGitHub { + owner = "input-output-hk"; + repo = "iohk-nix"; + rev = "4848df60660e21fbb3fe157d996a8bac0a9cf2d6"; + hash = "sha256-ediFkDOBP7yVquw1XtHiYfuXKoEnvKGjTIAk9mC6qxo="; + }; + + pkgs = import haskellNixNixpkgs { + inherit system; + overlays = [ + (import "${iohk-nix}/overlays/crypto") + haskellNixOverlay + ]; + }; +in + +{ name # : string +, src # : path +, ghcVersion ? "ghc928" # : string +, haskellModules ? [ ] +, externalDependencies ? [ ] +, externalRepositories ? { } +}: +let + mkHackage = pkgs.callPackage ./mk-hackage.nix { + nix-tools = pkgs.haskell-nix.nix-tools-set { + compiler-nix-name = ghcVersion; + }; + }; + + # This looks like a noop but without it haskell.nix throws a runtime + # error about `pkgs` attribute not being present which is nonsense + # https://input-output-hk.github.io/haskell.nix/reference/library.html?highlight=cabalProject#modules + fixedHaskellModules = map (m: args @ { ... }: m args) haskellModules; + + flatExternalDependencies = + lib.lists.concatMap + (dep: [ (dep.passthru or { }).src or dep ] ++ + (flatExternalDependencies (dep.passthru or { }).externalDependencies or [ ])); + + flattenedExternalDependencies = flatExternalDependencies externalDependencies; + + customHackages = mkHackage { + srcs = map toString flattenedExternalDependencies; + inherit name; + }; + + project = pkgs.haskell-nix.cabalProject' { + inherit src; + name = name; + + compiler-nix-name = ghcVersion; + inputMap = lib.mapAttrs (_: toString) externalRepositories; + + modules = customHackages.modules ++ fixedHaskellModules; + inherit (customHackages) extra-hackages extra-hackage-tarballs; + + shell = { + withHoogle = true; + exactDeps = true; + + tools = { + cabal = { }; + haskell-language-server = { }; + }; + }; + }; + + projectFlake = project.flake { }; + + augmentedPackages = builtins.mapAttrs + (_: package: + package // { + passthru = (package.passthru or { }) // { + inherit src externalDependencies; + }; + }) + (projectFlake.packages or { }); +in +projectFlake // { + packages = augmentedPackages; +} diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix new file mode 100644 index 00000000..9bd43db8 --- /dev/null +++ b/nix/haskell/mk-hackage.nix @@ -0,0 +1,132 @@ +{ gzip +, runCommand +, lib +, nix-tools +}: +let + mkPackageSpec = src: + with lib; + let + cabalFiles = concatLists (mapAttrsToList + (name: type: if type == "regular" && hasSuffix ".cabal" name then [ name ] else [ ]) + (builtins.readDir src)); + + cabalPath = + if length cabalFiles == 1 + then src + "/${builtins.head cabalFiles}" + else builtins.abort "Could not find unique file with .cabal suffix in source: ${src}"; + cabalFile = builtins.readFile cabalPath; + parse = field: + let + lines = filter (s: builtins.match "^${field} *:.*$" (toLower s) != null) (splitString "\n" cabalFile); + line = + if lines != [ ] + then head lines + else builtins.abort "Could not find line with prefix ''${field}:' in ${cabalPath}"; + in + replaceStrings [ " " ] [ "" ] (head (tail (splitString ":" line))); + pname = parse "name"; + version = parse "version"; + in + { inherit src pname version; }; + + mkHackageDir = { pname, version, src }: + runCommand "${pname}-${version}-hackage" + { } '' + set -e + mkdir -p $out/${pname}/${version} + md5=11111111111111111111111111111111 + sha256=1111111111111111111111111111111111111111111111111111111111111111 + length=1 + cat < $out/"${pname}"/"${version}"/package.json + { + "signatures" : [], + "signed" : { + "_type" : "Targets", + "expires" : null, + "targets" : { + "/package/${pname}-${version}.tar.gz" : { + "hashes" : { + "md5" : "$md5", + "sha256" : "$sha256" + }, + "length" : $length + } + }, + "version" : 0 + } + } + EOF + cp ${src}/*.cabal $out/"${pname}"/"${version}"/ + ''; + + mkHackageTarballFromDirs = name: hackageDirs: + runCommand "${name}-hackage-index.tar.gz" { } '' + mkdir hackage + ${builtins.concatStringsSep "" (map (dir: '' + echo ${dir} + ln -sf ${dir}/* hackage/ + '') hackageDirs)} + cd hackage + tar --sort=name --owner=root:0 --group=root:0 --mtime='UTC 2009-01-01' -hczvf $out */*/* + ''; + + mkHackageTarball = name: pkg-specs: + mkHackageTarballFromDirs name (map mkHackageDir pkg-specs); + + mkHackageNix = name: hackageTarball: + runCommand "${name}-hackage-nix" + { + nativeBuildInputs = [ + gzip + nix-tools + ]; + } '' + set -e + export LC_CTYPE=C.UTF-8 + export LC_ALL=C.UTF-8 + export LANG=C.UTF-8 + cp ${hackageTarball} 01-index.tar.gz + gunzip 01-index.tar.gz + hackage-to-nix $out 01-index.tar "https://mkHackageNix/" + ''; + + mkModule = extraHackagePackages: { + packages = lib.listToAttrs (map + (spec: { + name = spec.pname; + value = { + inherit (spec) src; + }; + }) + extraHackagePackages); + }; + + mkHackageFromSpec = name: extraHackagePackages: rec { + extra-hackage-tarball = mkHackageTarball name extraHackagePackages; + extra-hackage = mkHackageNix name extra-hackage-tarball; + module = mkModule extraHackagePackages; + }; + +in +{ srcs # : [string] +, name # : string +}: + +if builtins.length srcs == 0 +then { + modules = [ ]; + extra-hackage-tarballs = { }; + extra-hackages = [ ]; +} +else + let + hackage = mkHackageFromSpec name (map mkPackageSpec srcs); + in + { + modules = [ hackage.module ]; + extra-hackage-tarballs = { + "${name}-hackage-tarball" = hackage.extra-hackage-tarball; + }; + extra-hackages = [ (import hackage.extra-hackage) ]; + } diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix new file mode 100644 index 00000000..afb64fb4 --- /dev/null +++ b/nix/plutarch/default.nix @@ -0,0 +1,28 @@ +{ lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, pkgs, ... }: { + options = { + libPlutarch = lib.mkOption { + type = lib.types.anything; + default = { }; + }; + }; + + config = { + libPlutarch = { + mkPackage = pkgs.callPackage ./lib.nix { + mkHaskellPackage = config.libHaskell.mkPackage; + inherit (config.libUtils) applyPatches; + }; + }; + }; + }); + }; +} diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix new file mode 100644 index 00000000..3ec84f23 --- /dev/null +++ b/nix/plutarch/lib.nix @@ -0,0 +1,44 @@ +{ fetchFromGitHub +, mkHaskellPackage +, applyPatches +, fetchpatch +}: + +let + plutarchPackage = applyPatches { + name = "plutarch-patched"; + src = fetchFromGitHub { + owner = "Plutonomicon"; + repo = "plutarch-plutus"; + rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master + hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0="; + }; + + patches = [ + # https://github.com/Plutonomicon/plutarch-plutus/pull/650 + (fetchpatch { + url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch"; + hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek="; + }) + ]; + }; + + cardanoPackages = fetchFromGitHub { + owner = "input-output-hk"; + repo = "cardano-haskell-packages"; + rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo + hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; + }; +in + +args: +mkHaskellPackage (args // { + externalRepositories = { + "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; + } // (args.externalRepositories or { }); + + externalDependencies = [ + "${plutarchPackage}" + "${plutarchPackage}/plutarch-extra" + ] ++ (args.externalDependencies or [ ]); +}) diff --git a/nix/utils/default.nix b/nix/utils/default.nix new file mode 100644 index 00000000..851ab543 --- /dev/null +++ b/nix/utils/default.nix @@ -0,0 +1,22 @@ +{ lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; + inherit (lib) types mkOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, pkgs, ... }: { + options = { + libUtils = mkOption { + type = types.anything; + default = { }; + }; + }; + + config.libUtils = pkgs.callPackage ./lib.nix { }; + }); + }; +} diff --git a/nix/utils/lib.nix b/nix/utils/lib.nix new file mode 100644 index 00000000..c5b2f51b --- /dev/null +++ b/nix/utils/lib.nix @@ -0,0 +1,39 @@ +{ stdenv +, lib +}: + +let + applyPatches = args @ { patches, ... }: stdenv.mkDerivation ({ + inherit patches; + + dontConfigure = true; + dontBuild = true; + + installPhase = '' + mkdir -p "$out" + cp -r * "$out" + ''; + + dontFixup = true; + } // args); + + mkFlag = flag: value: "--${flag}=${value}"; + + mkFlags = flag: values: builtins.concatStringsSep " " (map (mkFlag flag) values); + + mkCli = args: + builtins.concatStringsSep " " + (lib.attrsets.mapAttrsToList + (flag: value: + if builtins.isList value + then mkFlags flag value + else if builtins.isBool value then (if value then "--${flag}" else "") + else mkFlag flag "${value}" + ) + args); + + withNameAttr = f: name: args: f (args // { inherit name; }); +in +{ + inherit applyPatches mkCli withNameAttr; +} diff --git a/purescript.cabal b/purescript.cabal index 31f72e7d..5af9edbd 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -119,7 +119,7 @@ common defaults TypeFamilies ViewPatterns build-tool-depends: - happy:happy ==1.20.0 + happy:happy ^>= 1.20.0 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 7e50545d..00000000 --- a/shell.nix +++ /dev/null @@ -1,21 +0,0 @@ -with (import {}); -let haskell928 = haskell.packages.ghc928; - ghc928 = haskell.compiler.ghc928; -in mkShell { - nativeBuildInputs = [ - pkg-config - haskell928.haskell-language-server - ghc928 - cabal-install - ]; - - buildInputs = [ - zlib - libsodium - secp256k1 - ]; - - shellHook = '' - export LC_ALL=C.utf8 - ''; -} From 86ec0381fe4590831a213799d713bf6b8c97d8d4 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:12:04 -0700 Subject: [PATCH 21/44] Trigger CI From acbc49dca1a712cb82612c8ea299d059914cf208 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:35:20 -0700 Subject: [PATCH 22/44] Remove unused configs --- flake.nix | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/flake.nix b/flake.nix index dbd6c47f..fb3d0f68 100644 --- a/flake.nix +++ b/flake.nix @@ -72,21 +72,6 @@ mkHaskellPackage = config.libHaskell.mkPackage; }); }; - - settings = { - latexindent.flags = config.libUtils.mkCli { - yaml = "\"defaultIndent:' ', onlyOneBackUp: 1\""; - local = true; - silent = true; - overwriteIfDifferent = true; - logfile = "/dev/null"; - }; - deadnix.edit = true; - }; - - excludes = [ - ".materialized" - ]; }; devShells = { @@ -96,10 +81,6 @@ inputsFrom = [ self'.devShells.purus ]; - - nativeBuildInputs = [ - pkgs.fd - ]; }; }; }; From 43bea5a6b18556481c1124c9830dd4d7d8ee777a Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:49:26 -0700 Subject: [PATCH 23/44] Disable typos check Too many of them to fix now --- .envrc | 2 +- flake.nix | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.envrc b/.envrc index 1d953f4b..3550a30f 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -use nix +use flake diff --git a/flake.nix b/flake.nix index fb3d0f68..9552252a 100644 --- a/flake.nix +++ b/flake.nix @@ -64,7 +64,6 @@ # TODO: Enable in separate PR, causes mass changes. # fourmolu.enable = true; nixpkgs-fmt.enable = true; - typos.enable = true; }; tools = { From 5f464c5ec73ffd3cdfe2241da2b16cefba736169 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 20 Feb 2024 23:56:54 -0500 Subject: [PATCH 24/44] Primitive infrastructure for golden tests, removed some dead options --- app/Command/Compile.hs | 6 +- purescript.cabal | 1 + src/Language/PureScript/CoreFn/Desugar.hs | 3 +- src/Language/PureScript/CoreFn/FromJSON.hs | 4 + src/Language/PureScript/CoreFn/Module.hs | 93 +++++++++++++++++++++- src/Language/PureScript/CoreFn/ToJSON.hs | 24 ++++++ src/Language/PureScript/Ide/Rebuild.hs | 2 + src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Make/Actions.hs | 91 +++++++++++---------- src/Language/PureScript/Options.hs | 15 ++-- 10 files changed, 184 insertions(+), 59 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 8f348da9..fc268cd3 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -130,11 +130,11 @@ codegenTargets :: Opts.Parser [P.CodegenTarget] codegenTargets = Opts.option targetParser $ Opts.short 'g' <> Opts.long "codegen" - <> Opts.value [P.JS] + <> Opts.value [P.CoreFn] <> Opts.help ( "Specifies comma-separated codegen targets to include. " <> targetsMessage - <> " The default target is 'js', but if this option is used only the targets specified will be used." + <> " The default target is 'coreFn', but if this option is used only the targets specified will be used." ) targetsMessage :: String @@ -158,7 +158,7 @@ options = where -- Ensure that the JS target is included if sourcemaps are handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget - handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts) + handleTargets ts = S.fromList ts pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile diff --git a/purescript.cabal b/purescript.cabal index 31f72e7d..2b15b65e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -155,6 +155,7 @@ common defaults -- specific version. aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, + aeson-diff, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.18, diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 9c361f43..4f4407c3 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -445,7 +445,8 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU <> showIdent' ident <> "'\ncontains unification variables:\n " <> ppType 1000 ty - <> "\nPlease add a type signature for '" <> showIdent' ident <> "'" + <> "\nIf this let-bound identifier occurs in a user-defined `let-binding`, please add a type signature for '" <> showIdent' ident <> "'" + <> "\nIf the identifier occurs in a compiler-generated `let-binding` with guards (e.g. in a guarded case branch), try removing the guarded expression (e.g. use a normal if-then expression)" -- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 4ae83fec..1f083f51 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -30,6 +30,10 @@ import Language.PureScript.Types () import Text.ParserCombinators.ReadP (readP_to_S) +-- dunno how to work around the orphan +instance FromJSON (Module Ann) where + parseJSON = fmap snd . moduleFromJSON + parseVersion' :: String -> Maybe Version parseVersion' str = case filter (null . snd) $ readP_to_S parseVersion str of diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 09f5189c..f874ab31 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE StandaloneDeriving, ScopedTypeVariables #-} module Language.PureScript.CoreFn.Module where import Prelude import Data.Map.Strict (Map) +import Data.List (sort) import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.Comments (Comment) -import Language.PureScript.CoreFn.Expr (Bind) +import Language.PureScript.CoreFn.Expr (Bind(..), Expr(..), CaseAlternative) +import Language.PureScript.CoreFn.Ann import Language.PureScript.Names (Ident, ModuleName) +import Data.Bifunctor (second) -- | -- The CoreFn module representation @@ -23,3 +28,89 @@ data Module a = Module , moduleForeign :: [Ident] , moduleDecls :: [Bind a] } deriving (Functor, Show) + +deriving instance Eq a => Eq (Module a) + +data DiffResult a = + DiffSourceSpan SourceSpan SourceSpan + | DiffComments [Comment] [Comment] + | DiffName ModuleName ModuleName + | DiffPath FilePath FilePath + | DiffImports [(a,ModuleName)] [(a,ModuleName)] + | DiffReExports (Map ModuleName [Ident]) (Map ModuleName [Ident]) + | DiffExports [Ident] [Ident] + | DiffForeign [Ident] [Ident] + | DiffDecl (Maybe (Bind a)) (Maybe (Bind a)) + +deriving instance Eq a => Eq (DiffResult a) +deriving instance Ord a => Ord (DiffResult a) +deriving instance Show a => Show (DiffResult a) + +diffModule :: Module Ann -> Module Ann -> [DiffResult Ann] +diffModule m1 m2 = ezDiff DiffSourceSpan moduleSourceSpan + <> ezDiff DiffComments moduleComments + <> ezDiff DiffName moduleName + <> ezDiff DiffPath modulePath + <> ezDiff DiffImports moduleImports + <> ezDiff DiffReExports moduleReExports + <> ezDiff DiffExports moduleExports + <> ezDiff DiffForeign moduleForeign + <> diffDecls (sort $ fmap removeComments <$> moduleDecls m1) (sort $ fmap removeComments <$> moduleDecls m2) + where + ezDiff :: Eq b => (b -> b -> DiffResult Ann) -> (Module Ann -> b) -> [DiffResult Ann] + ezDiff f g + | g m1 == g m2 = [] + | otherwise = [f (g m1) (g m2)] + + diffDecls :: [Bind Ann] -> [Bind Ann] -> [DiffResult Ann] + diffDecls [] bs@(_:_) = map (DiffDecl Nothing . Just) bs + diffDecls as@(_:_) [] = map (\a -> DiffDecl (Just a) Nothing) as + diffDecls [] [] = [] + diffDecls (a:as) (b:bs) + | a == b = diffDecls as bs + | otherwise = DiffDecl (Just a) (Just b) : diffDecls as bs + +canonicalizeModule :: Ord a => Module a -> Module a +canonicalizeModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) + = Module modSS modComments' modName modPath modImports' modExports' modReExports' modForeign' modDecls' + where + modComments' = sort modComments + modImports' = sort modImports + modExports' = sort modExports + modForeign' = sort modForeign + modReExports' = sort <$> modReExports + modDecls' = sort . map canonicalizeDecl $ modDecls + +canonicalizeDecl :: Ord a => Bind a -> Bind a +canonicalizeDecl = \case + NonRec ann ident expr -> NonRec ann ident (canonicalizeExpr expr) + Rec recBindingGroup -> Rec . sort . fmap (second canonicalizeExpr) $ recBindingGroup + +canonicalizeExpr :: Ord a => Expr a -> Expr a +canonicalizeExpr = \case + Literal ann ty lit -> Literal ann ty (canonicalizeLit lit) + Constructor a ty tName cName fields -> Constructor a ty tName cName fields + Accessor a ty fieldName expr -> Accessor a ty fieldName (canonicalizeExpr expr) + ObjectUpdate a ty origVal copyFields updateFields -> + let updateFields' = sort $ second canonicalizeExpr <$> updateFields + copyFields' = sort <$> copyFields + origVal' = canonicalizeExpr origVal + in ObjectUpdate a ty origVal' copyFields' updateFields' + Abs a ty ident body -> Abs a ty ident (canonicalizeExpr body) + App a ty e1 e2 -> + let e1' = canonicalizeExpr e1 + e2' = canonicalizeExpr e2 + in App a ty e1' e2' + Var a ty ident -> Var a ty ident + -- This one is confusing. The order intrinsically matters. Can't sort at the top level. Not sure what to do about that. + Case a ty es alts -> Case a ty (canonicalizeExpr <$> es) (canonicalizeAlt <$> alts) + Let a ty binds expr -> + let binds' = sort $ canonicalizeDecl <$> binds + expr' = canonicalizeExpr expr + in Let a ty binds' expr' + +canonicalizeAlt :: CaseAlternative a -> CaseAlternative a +canonicalizeAlt = id -- TODO + +canonicalizeLit :: Literal (Expr a) -> Literal (Expr a) +canonicalizeLit = id diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index b7a1fc70..3b6aa4c5 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -5,6 +5,7 @@ -- module Language.PureScript.CoreFn.ToJSON ( moduleToJSON + , moduleToJSON' ) where import Prelude @@ -139,6 +140,29 @@ moduleToJSON v m = object reExportsToJSON :: M.Map ModuleName [Ident] -> Value reExportsToJSON = toJSON . M.map (map runIdent) + +moduleToJSON' :: Module Ann -> Value +moduleToJSON' m = object + [ "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m) + , "moduleName" .= moduleNameToJSON (moduleName m) + , "modulePath" .= toJSON (modulePath m) + , "imports" .= map importToJSON (moduleImports m) + , "exports" .= map identToJSON (moduleExports m) + , "reExports" .= reExportsToJSON (moduleReExports m) + , "foreign" .= map identToJSON (moduleForeign m) + , "decls" .= map bindToJSON (moduleDecls m) + , "comments" .= map toJSON (moduleComments m) + ] + where + importToJSON (ann,mn) = object + [ "annotation" .= annToJSON ann + , "moduleName" .= moduleNameToJSON mn + ] + + reExportsToJSON :: M.Map ModuleName [Ident] -> Value + reExportsToJSON = toJSON . M.map (map runIdent) + + bindToJSON :: Bind Ann -> Value bindToJSON (NonRec ann n e) = object diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339..923e10b8 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -122,12 +122,14 @@ updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash)) foreignCacheInfo <- + {- if S.member P.JS codegenTargets then do foreigns' <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile))) for (M.lookup moduleName foreigns') \foreignPath -> do foreignHash <- P.hashFile foreignPath pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash)) else + -} pure Nothing let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a808e992..b041af6a 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -50,7 +50,6 @@ import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn qualified as CFT import Language.PureScript.CoreFn.Pretty qualified as CFT -import Language.PureScript.CoreFn.Module qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) @@ -121,7 +120,6 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ traceM "PURUS START HERE" ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') traceM $ prettyEnv (checkEnv chkSt) - --mapM_ (traceM . show) . CFT.moduleDecls $ coreFn traceM $ CFT.prettyPrintModule' coreFn let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn @@ -173,7 +171,7 @@ make ma@MakeActions{..} ms = do (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) - let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted + let toBeRebuilt = sorted -- filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted let totalModuleCount = length toBeRebuilt for_ toBeRebuilt $ \m -> fork $ do let moduleName = getModuleName . CST.resPartial $ m diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 6739b4bf..4162faa0 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Make.Actions ( MakeActions(..) , RebuildPolicy(..) @@ -20,13 +21,13 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply (SupplyT) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (Value(String), (.=), object) +import Data.Aeson (Value(String), (.=), object, decode, encode, Result (..), fromJSON) import Data.Bifunctor (bimap, first) import Data.Either (partitionEithers) import Data.Foldable (for_) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe, maybeToList, fromJust) import Data.Set qualified as S import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -39,6 +40,7 @@ import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.CodeGen.UPLC qualified as PC import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.ToJSON qualified as CFJ +import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Prim qualified as Docs.Prim @@ -181,18 +183,22 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = :: ModuleName -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash))) getInputTimestampsAndHashes mn = do - let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap - case path of - Left policy -> - return (Left policy) - Right filePath -> do - cwd <- makeIO "Getting the current directory" getCurrentDirectory - let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns)) - getInfo fp = do - ts <- getTimestamp fp - return (ts, hashFile fp) - pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths - return $ Right $ M.fromList pathsWithInfo + codegenTargets <- asks optionsCodegenTargets + if CheckCoreFn `S.member` codegenTargets + then pure (Left RebuildAlways) + else do + let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap + case path of + Left policy -> + return (Left policy) + Right filePath -> do + cwd <- makeIO "Getting the current directory" getCurrentDirectory + let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns)) + getInfo fp = do + ts <- getTimestamp fp + return (ts, hashFile fp) + pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths + return $ Right $ M.fromList pathsWithInfo outputFilename :: ModuleName -> String -> FilePath outputFilename mn fn = @@ -201,11 +207,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = targetFilename :: ModuleName -> CodegenTarget -> FilePath targetFilename mn = \case - JS -> outputFilename mn "index.js" - JSSourceMap -> outputFilename mn "index.js.map" - -- CoreFn -> outputFilename mn "corefn.json" Docs -> outputFilename mn "docs.json" - UPLC -> outputFilename mn "index.cfn" + CoreFn -> outputFilename mn "index.cfn" + CheckCoreFn -> outputFilename mn "index.cfn" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -251,39 +255,31 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts codegenTargets <- lift $ asks optionsCodegenTargets - when (S.member UPLC codegenTargets) $ do + {- -when (S.member UPLC codegenTargets) $ do let coreFnFile = targetFilename mn UPLC json = CFJ.moduleToJSON Paths.version m lift $ writeJSONFile coreFnFile json - {- - when (S.member JS codegenTargets) $ do - foreignInclude <- case mn `M.lookup` foreigns of - Just _ - | not $ requiresForeign m -> do - return Nothing - | otherwise -> do - return $ Just "./foreign.js" - Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn - | otherwise -> return Nothing - rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO "get the current directory" getCurrentDirectory - let sourceMaps = S.member JSSourceMap codegenTargets - (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - jsFile = targetFilename mn JS - mapFile = targetFilename mn JSSourceMap - prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] - js = T.unlines $ map ("// " <>) prefix ++ [pjs] - mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" - lift $ do - writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) - when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings -} when (S.member Docs codegenTargets) $ do lift $ writeJSONFile (outputFilename mn "docs.json") docs - when (S.member UPLC codegenTargets) $ do - lift $ writeJSONFile (targetFilename mn UPLC) (moduleToJSON (makeVersion [0,0,1]) m) - -- uplc <- PC.moduleToUPLC m - -- lift $ PC.printUPLC uplc + when (S.member CoreFn codegenTargets) $ do + lift $ writeJSONFile (targetFilename mn CoreFn) (moduleToJSON (makeVersion [0,0,1]) m) + when (S.member CheckCoreFn codegenTargets) $ do + let mn' = T.unpack (runModuleName mn) + mabOldModule <- lift $ readJSONFile (targetFilename mn CoreFn) + case mabOldModule of + Nothing -> error "Cannot check CoreFn output - could not parse JSON serialization of old module" + Just oldM -> do + let oldM' = CF.canonicalizeModule oldM + m' = CF.canonicalizeModule (jsonRoundTrip m) + diff = CF.diffModule oldM' m' + lift $ makeIO "print golden result" $ putStrLn $ "checkCoreFn mismatches: " <> show diff + where + jsonRoundTrip :: CF.Module CF.Ann -> CF.Module CF.Ann + jsonRoundTrip mdl = case fromJSON $ moduleToJSON (makeVersion [0,0,1]) mdl of + Error str -> error str + Success a -> a + ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do @@ -439,7 +435,8 @@ ffiCodegen' -> Maybe (ModuleName -> String -> FilePath) -> CF.Module CF.Ann -> Make () -ffiCodegen' foreigns codegenTargets makeOutputPath m = do +ffiCodegen' foreigns codegenTargets makeOutputPath m = pure () + {- when (S.member JS codegenTargets) $ do let mn = CF.moduleName m case mn `M.lookup` foreigns of @@ -455,8 +452,10 @@ ffiCodegen' foreigns codegenTargets makeOutputPath m = do throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return () + where requiresForeign = not . null . CF.moduleForeign copyForeign path mn = for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js")) + -} diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 059b27fb..ae413155 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -18,16 +18,21 @@ data Options = Options -- Default make options defaultOptions :: Options -defaultOptions = Options False False (S.singleton JS) +defaultOptions = Options False False (S.singleton CoreFn) -data CodegenTarget = JS | JSSourceMap | Docs | UPLC +data CodegenTarget + = Docs + | CoreFn + {- N.B. We need a compilation mode that tests for changes from existing serialized CoreFn. + This is the easiest way to implement that (though maybe we should do something else for the final version) + -} + | CheckCoreFn deriving (Eq, Ord, Show) codegenTargets :: Map String CodegenTarget codegenTargets = Map.fromList - [ ("js", JS) - , ("uplc", UPLC) - , ("sourcemaps", JSSourceMap) + [ ("coreFn", CoreFn) + , ("checkCoreFn", CheckCoreFn) -- , ("corefn", CoreFn) , ("docs", Docs) ] From aa95066bee1007aa15625921530f1ef591941cb8 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 21 Feb 2024 23:17:20 -0500 Subject: [PATCH 25/44] testing infrastructure, ported some tests/purs/passing tests to debug compiler --- purescript.cabal | 26 +++- {app => purs-lib}/Command/Bundle.hs | 0 {app => purs-lib}/Command/Compile.hs | 23 +++- {app => purs-lib}/Command/Docs.hs | 0 {app => purs-lib}/Command/Docs/Html.hs | 0 {app => purs-lib}/Command/Docs/Markdown.hs | 0 {app => purs-lib}/Command/Graph.hs | 0 {app => purs-lib}/Command/Hierarchy.hs | 0 {app => purs-lib}/Command/Ide.hs | 0 {app => purs-lib}/Command/Publish.hs | 0 {app => purs-lib}/Command/REPL.hs | 0 {app => purs-lib}/Version.hs | 0 src/Language/PureScript/CoreFn/Desugar.hs | 4 +- src/Language/PureScript/Environment.hs | 3 + tests/Language/PureScript/Ide/RebuildSpec.hs | 2 +- tests/Main.hs | 20 +-- tests/TestCoreFn.hs | 21 ++-- tests/TestMake.hs | 2 +- tests/TestPurus.hs | 115 ++++++++++++++++++ tests/TestSourceMaps.hs | 2 +- tests/purus/passing/2018/A.purs | 7 ++ tests/purus/passing/2018/B.purs | 3 + tests/purus/passing/2138/Lib.purs | 3 + tests/purus/passing/2609/Eg.purs | 5 + tests/purus/passing/4035/Other.purs | 4 + tests/purus/passing/4101/Lib.purs | 9 ++ tests/purus/passing/4105/Lib.purs | 5 + tests/purus/passing/4200/Lib.purs | 7 ++ tests/purus/passing/4310/Lib.purs | 20 +++ tests/purus/passing/ClassRefSyntax/Lib.purs | 5 + tests/purus/passing/Coercible/Lib.purs | 12 ++ tests/purus/passing/Coercible/Lib2.purs | 3 + .../passing/DctorOperatorAlias/List.purs | 5 + .../passing/ExplicitImportReExport/Bar.purs | 3 + .../passing/ExplicitImportReExport/Foo.purs | 4 + tests/purus/passing/ExportExplicit/M1.purs | 10 ++ tests/purus/passing/ExportExplicit2/M1.purs | 7 ++ tests/purus/passing/ForeignKind/Lib.purs | 60 +++++++++ tests/purus/passing/Import/M1.purs | 6 + tests/purus/passing/Import/M2.purs | 5 + tests/purus/passing/ImportExplicit/M1.purs | 4 + tests/purus/passing/ImportQualified/M1.purs | 3 + .../ImportedClassName.purs | 4 + tests/purus/passing/ModuleDeps/M1.purs | 5 + tests/purus/passing/ModuleDeps/M2.purs | 5 + tests/purus/passing/ModuleDeps/M3.purs | 3 + .../NonOrphanInstanceFunDepExtra/Lib.purs | 4 + .../passing/NonOrphanInstanceMulti/Lib.purs | 4 + 48 files changed, 409 insertions(+), 24 deletions(-) rename {app => purs-lib}/Command/Bundle.hs (100%) rename {app => purs-lib}/Command/Compile.hs (85%) rename {app => purs-lib}/Command/Docs.hs (100%) rename {app => purs-lib}/Command/Docs/Html.hs (100%) rename {app => purs-lib}/Command/Docs/Markdown.hs (100%) rename {app => purs-lib}/Command/Graph.hs (100%) rename {app => purs-lib}/Command/Hierarchy.hs (100%) rename {app => purs-lib}/Command/Ide.hs (100%) rename {app => purs-lib}/Command/Publish.hs (100%) rename {app => purs-lib}/Command/REPL.hs (100%) rename {app => purs-lib}/Version.hs (100%) create mode 100644 tests/TestPurus.hs create mode 100644 tests/purus/passing/2018/A.purs create mode 100644 tests/purus/passing/2018/B.purs create mode 100644 tests/purus/passing/2138/Lib.purs create mode 100644 tests/purus/passing/2609/Eg.purs create mode 100644 tests/purus/passing/4035/Other.purs create mode 100644 tests/purus/passing/4101/Lib.purs create mode 100644 tests/purus/passing/4105/Lib.purs create mode 100644 tests/purus/passing/4200/Lib.purs create mode 100644 tests/purus/passing/4310/Lib.purs create mode 100644 tests/purus/passing/ClassRefSyntax/Lib.purs create mode 100644 tests/purus/passing/Coercible/Lib.purs create mode 100644 tests/purus/passing/Coercible/Lib2.purs create mode 100644 tests/purus/passing/DctorOperatorAlias/List.purs create mode 100644 tests/purus/passing/ExplicitImportReExport/Bar.purs create mode 100644 tests/purus/passing/ExplicitImportReExport/Foo.purs create mode 100644 tests/purus/passing/ExportExplicit/M1.purs create mode 100644 tests/purus/passing/ExportExplicit2/M1.purs create mode 100644 tests/purus/passing/ForeignKind/Lib.purs create mode 100644 tests/purus/passing/Import/M1.purs create mode 100644 tests/purus/passing/Import/M2.purs create mode 100644 tests/purus/passing/ImportExplicit/M1.purs create mode 100644 tests/purus/passing/ImportQualified/M1.purs create mode 100644 tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs create mode 100644 tests/purus/passing/ModuleDeps/M1.purs create mode 100644 tests/purus/passing/ModuleDeps/M2.purs create mode 100644 tests/purus/passing/ModuleDeps/M3.purs create mode 100644 tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs create mode 100644 tests/purus/passing/NonOrphanInstanceMulti/Lib.purs diff --git a/purescript.cabal b/purescript.cabal index 2b15b65e..ae6ab30f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -409,13 +409,35 @@ executable purs exceptions >=0.10.4 && <0.11, network >=3.1.2.7 && <3.2, optparse-applicative >=0.17.0.0 && <0.18, - purescript + purescript, + purs-lib if flag(release) cpp-options: -DRELEASE else build-depends: gitrev >=1.2.0 && <1.4 other-modules: + Paths_purescript + autogen-modules: + Paths_purescript + +library purs-lib + import: defaults + hs-source-dirs: purs-lib + -- main-is: Main.hs + ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages + build-depends: + ansi-wl-pprint >=0.6.9 && <0.7, + exceptions >=0.10.4 && <0.11, + network >=3.1.2.7 && <3.2, + optparse-applicative >=0.17.0.0 && <0.18, + purescript + if flag(release) + cpp-options: -DRELEASE + else + build-depends: + gitrev >=1.2.0 && <1.4 + exposed-modules: Command.Bundle Command.Compile Command.Docs @@ -440,6 +462,7 @@ test-suite tests ghc-options: -Wno-incomplete-uni-patterns -Wno-unused-packages build-depends: purescript, + purs-lib, generic-random >=1.5.0.1 && <1.6, hspec >= 2.10.7 && < 3, HUnit >=1.6.2.0 && <1.7, @@ -480,6 +503,7 @@ test-suite tests TestPsci.EvalTest TestPsci.TestEnv TestPscPublish + TestPurus TestSourceMaps TestUtils Paths_purescript diff --git a/app/Command/Bundle.hs b/purs-lib/Command/Bundle.hs similarity index 100% rename from app/Command/Bundle.hs rename to purs-lib/Command/Bundle.hs diff --git a/app/Command/Compile.hs b/purs-lib/Command/Compile.hs similarity index 85% rename from app/Command/Compile.hs rename to purs-lib/Command/Compile.hs index fc268cd3..9cd29b37 100644 --- a/app/Command/Compile.hs +++ b/purs-lib/Command/Compile.hs @@ -1,4 +1,4 @@ -module Command.Compile (command) where +module Command.Compile where import Prelude @@ -31,7 +31,7 @@ data PSCMakeOptions = PSCMakeOptions , pscmOpts :: P.Options , pscmUsePrefix :: Bool , pscmJSONErrors :: Bool - } + } deriving Show -- | Arguments: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () @@ -72,6 +72,25 @@ compile PSCMakeOptions{..} = do printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess +compileForTests :: PSCMakeOptions -> IO () +compileForTests PSCMakeOptions{..} = do + included <- globWarningOnMisses warnFileTypeNotFound pscmInput + excluded <- globWarningOnMisses warnFileTypeNotFound pscmExclude + let input = included \\ excluded + if (null input) then do + hPutStr stderr $ unlines [ "purs compile: No input files." + , "Usage: For basic information, try the `--help' option." + ] + else do + moduleFiles <- readUTF8FilesT input + (makeErrors, makeWarnings) <- runMake pscmOpts $ do + ms <- CST.parseModulesFromFiles id moduleFiles + let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms + foreigns <- inferForeignModules filePathMap + let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix + P.make makeActions (map snd ms) + printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors + warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++) diff --git a/app/Command/Docs.hs b/purs-lib/Command/Docs.hs similarity index 100% rename from app/Command/Docs.hs rename to purs-lib/Command/Docs.hs diff --git a/app/Command/Docs/Html.hs b/purs-lib/Command/Docs/Html.hs similarity index 100% rename from app/Command/Docs/Html.hs rename to purs-lib/Command/Docs/Html.hs diff --git a/app/Command/Docs/Markdown.hs b/purs-lib/Command/Docs/Markdown.hs similarity index 100% rename from app/Command/Docs/Markdown.hs rename to purs-lib/Command/Docs/Markdown.hs diff --git a/app/Command/Graph.hs b/purs-lib/Command/Graph.hs similarity index 100% rename from app/Command/Graph.hs rename to purs-lib/Command/Graph.hs diff --git a/app/Command/Hierarchy.hs b/purs-lib/Command/Hierarchy.hs similarity index 100% rename from app/Command/Hierarchy.hs rename to purs-lib/Command/Hierarchy.hs diff --git a/app/Command/Ide.hs b/purs-lib/Command/Ide.hs similarity index 100% rename from app/Command/Ide.hs rename to purs-lib/Command/Ide.hs diff --git a/app/Command/Publish.hs b/purs-lib/Command/Publish.hs similarity index 100% rename from app/Command/Publish.hs rename to purs-lib/Command/Publish.hs diff --git a/app/Command/REPL.hs b/purs-lib/Command/REPL.hs similarity index 100% rename from app/Command/REPL.hs rename to purs-lib/Command/REPL.hs diff --git a/app/Version.hs b/purs-lib/Version.hs similarity index 100% rename from app/Version.hs rename to purs-lib/Version.hs diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 4f4407c3..9e72366e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -486,11 +486,11 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder Just (_, _, ty, _) -> do traceM (ppType 100 ty) let (args, ret) = peelArgs ty - unifyTypes ret val -- TODO: Check whether necesseary? + -- unifyTypes ret val -- TODO: Check whether necesseary? M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - -- NOTE: Maybe forbid invalid return types? + -- REVIEW: Instantiating the quantifier might not be safe here? peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. peelArgs = go [] where diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index b456ba8e..cab4e45f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -379,6 +379,9 @@ pattern ArrayT :: Type a -> Type a pattern ArrayT a <- TypeApp _ (TypeConstructor _ C.Array) a +arrayT :: Type a -> Type () +arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ()) + pattern RecordT :: Type a -> Type a pattern RecordT a <- TypeApp _ (TypeConstructor _ C.Record) a diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 93a0cabe..7da70065 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -15,7 +15,7 @@ import System.Directory (doesFileExist, removePathForcibly) import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) defaultTarget :: Set P.CodegenTarget -defaultTarget = Set.singleton P.JS +defaultTarget = Set.singleton P.CoreFn load :: [Text] -> Command load = LoadSync . map Test.mn diff --git a/tests/Main.hs b/tests/Main.hs index b8f6ea97..6b8ec2c0 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -21,6 +21,7 @@ import TestSourceMaps qualified import TestMake qualified import TestUtils qualified import TestGraph qualified +import TestPurus (shouldPassTests) import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -28,21 +29,26 @@ main :: IO () main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 + shouldPassTests {- do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 TestUtils.updateSupportCode + shouldPassTests hspec $ do describe "cst" TestCst.spec describe "ast" TestAst.spec - describe "ide" TestIde.spec + -- describe "ide" TestIde.spec beforeAll TestUtils.setupSupportModules $ do describe "compiler" TestCompiler.spec - describe "sourcemaps" TestSourceMaps.spec + -- describe "sourcemaps" TestSourceMaps.spec describe "make" TestMake.spec - describe "psci" TestPsci.spec + -- describe "psci" TestPsci.spec describe "corefn" TestCoreFn.spec - describe "docs" TestDocs.spec - describe "prim-docs" TestPrimDocs.spec - describe "publish" TestPscPublish.spec + -- describe "docs" TestDocs.spec + -- describe "prim-docs" TestPrimDocs.spec + -- describe "publish" TestPscPublish.spec describe "hierarchy" TestHierarchy.spec - describe "graph" TestGraph.spec + -- describe "graph" TestGraph.spec +-} diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 588c6817..07b757e9 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -17,8 +17,10 @@ import Language.PureScript.CoreFn.FromJSON (moduleFromJSON) import Language.PureScript.CoreFn.ToJSON (moduleToJSON) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..)) import Language.PureScript.PSString (mkString) +import Language.PureScript.Environment import Test.Hspec (Spec, context, shouldBe, shouldSatisfy, specify) +import Language.PureScript.CoreFn.Desugar.Utils (purusTy) parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON @@ -102,16 +104,17 @@ spec = context "CoreFnFromJson" $ do context "Expr" $ do specify "should parse literals" $ do let m = Module ss [] mn mp [] [] M.empty [] - [ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1)) - , NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0)) - , NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc")) - , NonRec ann (Ident "x4") $ Literal ann (CharLiteral 'c') - , NonRec ann (Ident "x5") $ Literal ann (BooleanLiteral True) - , NonRec ann (Ident "x6") $ Literal ann (ArrayLiteral [Literal ann (CharLiteral 'a')]) - , NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))]) + [ NonRec ann (Ident "x1") $ Literal ann (purusTy tyInt) (NumericLiteral (Left 1)) + , NonRec ann (Ident "x2") $ Literal ann (purusTy tyNumber) (NumericLiteral (Right 1.0)) + , NonRec ann (Ident "x3") $ Literal ann (purusTy tyString) (StringLiteral (mkString "abc")) + , NonRec ann (Ident "x4") $ Literal ann (purusTy tyChar) (CharLiteral 'c') + , NonRec ann (Ident "x5") $ Literal ann (purusTy tyBoolean) (BooleanLiteral True) + , NonRec ann (Ident "x6") $ Literal ann (arrayT tyChar) (ArrayLiteral [Literal ann (purusTy tyChar) (CharLiteral 'a')]) + -- TODO: Need helpers to make the type + -- , NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))]) ] parseMod m `shouldSatisfy` isSuccess - +{- don't have the tools to write type sigs, TODO come back an fix specify "should parse Constructor" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ] @@ -256,7 +259,7 @@ spec = context "CoreFnFromJson" $ do ] ] parseMod m `shouldSatisfy` isSuccess - + -} context "Comments" $ do specify "should parse LineComment" $ do let m = Module ss [ LineComment "line" ] mn mp [] [] M.empty [] [] diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 610e8465..6cd5347f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -164,7 +164,7 @@ spec = do let modulePath = sourcesDir "Module.purs" moduleContent1 = "module Module where\nx :: Int\nx = 1" moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.CoreFn, P.Docs] } go opts = compileWithOptions opts [modulePath] >>= assertSuccess oneSecond = 10 ^ (6::Int) -- microseconds. diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs new file mode 100644 index 00000000..48567dae --- /dev/null +++ b/tests/TestPurus.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TypeApplications #-} +module TestPurus where + +import Prelude +import Command.Compile ( compileForTests, PSCMakeOptions(..) ) +import Control.Monad (when,unless,void) +import System.FilePath +import Language.PureScript qualified as P +import Data.Set qualified as S +import Data.Foldable (traverse_) +import System.Directory (removeDirectoryRecursive, doesDirectoryExist, createDirectory) +import System.FilePath.Glob qualified as Glob +import Data.Function (on) +import Data.List (sort, sortBy, stripPrefix, groupBy, find) +import Control.Exception.Base + + +shouldPassTests :: IO () +shouldPassTests = traverse_ runPurusDefault shouldPass + +runPurus :: P.CodegenTarget -> FilePath -> IO () +runPurus target dir = do + outDirExists <- doesDirectoryExist outputDir + when (target /= P.CheckCoreFn) $ do + when outDirExists $ removeDirectoryRecursive outputDir + unless outDirExists $ createDirectory outputDir + files <- concat <$> getTestFiles dir + print files + print ("Compiling " <> dir) + compileForTests (makeOpts files) + print ("Done with " <> dir) + where + outputDir = "tests" "purus" dir "output" + + makeOpts :: [FilePath] -> PSCMakeOptions + makeOpts files = PSCMakeOptions { + pscmInput = files, + pscmExclude = [], + pscmOutputDir = outputDir, + pscmOpts = purusOpts, + pscmUsePrefix = False, + pscmJSONErrors = False + } + + purusOpts :: P.Options + purusOpts = P.Options { + optionsVerboseErrors = True, + optionsNoComments = True, + optionsCodegenTargets = S.singleton target + } + +runPurusDefault :: FilePath -> IO () +runPurusDefault path = runPurus P.CoreFn path + +runPurusGolden :: FilePath -> IO () +runPurusGolden path = runPurus P.CheckCoreFn path + + +shouldPass :: [FilePath] +shouldPass = map (prefix ) paths + where + prefix = "passing" + paths = [ + "2018", + "2138", + "2609", + "4035", + "4101", + "4105", + "4200", + "4310", + "ClassRefSyntax", + "Coercible", + "DctorOperatorAlias", + "ExplicitImportReExport", + "ExportExplicit", + "ExportExplicit2", + "ForeignKind", + "Import", + "ImportExplicit", + "ImportQualified", + "InstanceUnnamedSimilarClassName", + "ModuleDeps", + "NonOrphanInstanceFunDepExtra", + "NonOrphanInstanceMulti" + + ] + + +getTestFiles :: FilePath -> IO [[FilePath]] +getTestFiles testDir = do + let dir = "tests" "purus" testDir + getFiles dir <$> testGlob dir + where + -- A glob for all purs and js files within a test directory + testGlob :: FilePath -> IO [FilePath] + testGlob = Glob.globDir1 (Glob.compile "**/*.purs") + -- Groups the test files so that a top-level file can have dependencies in a + -- subdirectory of the same name. The inner tuple contains a list of the + -- .purs files and the .js files for the test case. + getFiles :: FilePath -> [FilePath] -> [[FilePath]] + getFiles baseDir + = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) + . groupBy ((==) `on` extractPrefix) + . sortBy (compare `on` extractPrefix) + . map (makeRelative baseDir) + -- Extracts the filename part of a .purs file, or if the file is in a + -- subdirectory, the first part of that directory path. + extractPrefix :: FilePath -> FilePath + extractPrefix fp = + let dir = takeDirectory fp + ext = reverse ".purs" + in if dir == "." + then maybe fp reverse $ stripPrefix ext $ reverse fp + else dir diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index 5b91017d..ae931b88 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -67,7 +67,7 @@ assertCompilesToExpectedValidOutput support inputFiles = do where compilationOptions :: P.Options - compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.JSSourceMap] } + compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.CoreFn] } -- | Fails the test if the produced source maps are not valid. sourceMapIsValid :: FilePath -> Expectation diff --git a/tests/purus/passing/2018/A.purs b/tests/purus/passing/2018/A.purs new file mode 100644 index 00000000..bff4cd03 --- /dev/null +++ b/tests/purus/passing/2018/A.purs @@ -0,0 +1,7 @@ +module A where + +import B as Main + +-- Prior to the 2018 fix this would be detected as a cycle between A and Main. +foo ∷ Main.Foo → Main.Foo +foo x = x diff --git a/tests/purus/passing/2018/B.purs b/tests/purus/passing/2018/B.purs new file mode 100644 index 00000000..c87647d4 --- /dev/null +++ b/tests/purus/passing/2018/B.purs @@ -0,0 +1,3 @@ +module B where + +data Foo = X | Y diff --git a/tests/purus/passing/2138/Lib.purs b/tests/purus/passing/2138/Lib.purs new file mode 100644 index 00000000..3c433e0b --- /dev/null +++ b/tests/purus/passing/2138/Lib.purs @@ -0,0 +1,3 @@ +module Lib (A(..), A) where + +data A = B | C diff --git a/tests/purus/passing/2609/Eg.purs b/tests/purus/passing/2609/Eg.purs new file mode 100644 index 00000000..cd6e73d3 --- /dev/null +++ b/tests/purus/passing/2609/Eg.purs @@ -0,0 +1,5 @@ +module Eg (Foo'(Bar'), (:->)) where + +data Foo' = Bar' Int Int + +infix 4 Bar' as :-> diff --git a/tests/purus/passing/4035/Other.purs b/tests/purus/passing/4035/Other.purs new file mode 100644 index 00000000..055b3c78 --- /dev/null +++ b/tests/purus/passing/4035/Other.purs @@ -0,0 +1,4 @@ +module Other where + +type Id :: forall k. k -> k +type Id a = a diff --git a/tests/purus/passing/4101/Lib.purs b/tests/purus/passing/4101/Lib.purs new file mode 100644 index 00000000..fc5f850e --- /dev/null +++ b/tests/purus/passing/4101/Lib.purs @@ -0,0 +1,9 @@ +module Lib where + +newtype Const :: forall k. Type -> k -> Type +newtype Const a b = Const a + +data Unit = Unit + +type CONST = Const +type UNIT = CONST Unit diff --git a/tests/purus/passing/4105/Lib.purs b/tests/purus/passing/4105/Lib.purs new file mode 100644 index 00000000..89ccc304 --- /dev/null +++ b/tests/purus/passing/4105/Lib.purs @@ -0,0 +1,5 @@ +module Lib where + +type Template col = { bio :: col String } +type Identity a = a +type Patch = Template Identity diff --git a/tests/purus/passing/4200/Lib.purs b/tests/purus/passing/4200/Lib.purs new file mode 100644 index 00000000..645940a2 --- /dev/null +++ b/tests/purus/passing/4200/Lib.purs @@ -0,0 +1,7 @@ +module Lib where + +data T :: forall m. m -> Type +data T msg = E + +type TAlias :: forall k. k -> Type +type TAlias msg = T msg diff --git a/tests/purus/passing/4310/Lib.purs b/tests/purus/passing/4310/Lib.purs new file mode 100644 index 00000000..2c5b8707 --- /dev/null +++ b/tests/purus/passing/4310/Lib.purs @@ -0,0 +1,20 @@ +module Lib where + +data Tuple a b = Tuple a b + +infixr 6 Tuple as /\ +infixr 6 type Tuple as /\ + +mappend :: String -> String -> String +mappend _ _ = "mappend" + +infixr 5 mappend as <> + +class Test a where + runTest :: a -> String + +instance Test Int where + runTest _ = "4" + +instance (Test a, Test b) => Test (a /\ b) where + runTest (a /\ b) = runTest a <> runTest b diff --git a/tests/purus/passing/ClassRefSyntax/Lib.purs b/tests/purus/passing/ClassRefSyntax/Lib.purs new file mode 100644 index 00000000..c9eca67a --- /dev/null +++ b/tests/purus/passing/ClassRefSyntax/Lib.purs @@ -0,0 +1,5 @@ +module Lib (class X, go) where + +class X a where + go :: a -> a + diff --git a/tests/purus/passing/Coercible/Lib.purs b/tests/purus/passing/Coercible/Lib.purs new file mode 100644 index 00000000..cca268cf --- /dev/null +++ b/tests/purus/passing/Coercible/Lib.purs @@ -0,0 +1,12 @@ +module Coercible.Lib + ( module Coercible.Lib2 + , NTLib1 (..) + , NTLib3 (..) + ) where + +import Coercible.Lib2 + +newtype NTLib1 a = NTLib1 a + +newtype NTLib3 a b = NTLib3 a +type role NTLib3 representational representational diff --git a/tests/purus/passing/Coercible/Lib2.purs b/tests/purus/passing/Coercible/Lib2.purs new file mode 100644 index 00000000..3fdef618 --- /dev/null +++ b/tests/purus/passing/Coercible/Lib2.purs @@ -0,0 +1,3 @@ +module Coercible.Lib2 where + +newtype NTLib2 a = NTLib2 a diff --git a/tests/purus/passing/DctorOperatorAlias/List.purs b/tests/purus/passing/DctorOperatorAlias/List.purs new file mode 100644 index 00000000..a428343a --- /dev/null +++ b/tests/purus/passing/DctorOperatorAlias/List.purs @@ -0,0 +1,5 @@ +module List where + +data List a = Cons a (List a) | Nil + +infixr 6 Cons as : diff --git a/tests/purus/passing/ExplicitImportReExport/Bar.purs b/tests/purus/passing/ExplicitImportReExport/Bar.purs new file mode 100644 index 00000000..5f8ef12a --- /dev/null +++ b/tests/purus/passing/ExplicitImportReExport/Bar.purs @@ -0,0 +1,3 @@ +module Bar (module Foo) where + +import Foo diff --git a/tests/purus/passing/ExplicitImportReExport/Foo.purs b/tests/purus/passing/ExplicitImportReExport/Foo.purs new file mode 100644 index 00000000..d2c06e96 --- /dev/null +++ b/tests/purus/passing/ExplicitImportReExport/Foo.purs @@ -0,0 +1,4 @@ +module Foo where + +foo :: Int +foo = 3 diff --git a/tests/purus/passing/ExportExplicit/M1.purs b/tests/purus/passing/ExportExplicit/M1.purs new file mode 100644 index 00000000..5195d0e9 --- /dev/null +++ b/tests/purus/passing/ExportExplicit/M1.purs @@ -0,0 +1,10 @@ +module M1 (X(X, Y), Z(..), foo) where + +data X = X | Y +data Z = Z + +foo :: Int +foo = 0 + +bar :: Int +bar = 1 diff --git a/tests/purus/passing/ExportExplicit2/M1.purs b/tests/purus/passing/ExportExplicit2/M1.purs new file mode 100644 index 00000000..aa78149f --- /dev/null +++ b/tests/purus/passing/ExportExplicit2/M1.purs @@ -0,0 +1,7 @@ +module M1 (bar) where + +foo :: Int +foo = 0 + +bar :: Int +bar = foo diff --git a/tests/purus/passing/ForeignKind/Lib.purs b/tests/purus/passing/ForeignKind/Lib.purs new file mode 100644 index 00000000..d28a9a5c --- /dev/null +++ b/tests/purus/passing/ForeignKind/Lib.purs @@ -0,0 +1,60 @@ +module ForeignKinds.Lib (Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where + +-- declaration + +data Nat + +-- use in foreign data + +foreign import data Zero :: Nat +foreign import data Succ :: Nat -> Nat + +-- use in data + +data NatProxy (t :: Nat) = NatProxy + +-- use in type sig + +succProxy :: forall n. NatProxy n -> NatProxy (Succ n) +succProxy _ = NatProxy + +-- use in alias + +type Kinded f = f :: Nat + +type KindedZero = Kinded Zero + +type N0 = Zero +type N1 = Succ N0 +type N2 = Succ N1 +type N3 = Succ N2 + +-- use of alias + +proxy0 :: NatProxy N0 +proxy0 = NatProxy + +proxy1 :: NatProxy N1 +proxy1 = NatProxy + +proxy2 :: NatProxy N2 +proxy2 = NatProxy + +proxy3 :: NatProxy N3 +proxy3 = NatProxy + +-- use in class + +class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o + +instance addNatZero + :: AddNat Zero r r + +instance addNatSucc + :: AddNat l r o + => AddNat (Succ l) r (Succ o) + +-- use of class + +addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o +addNat _ _ = NatProxy diff --git a/tests/purus/passing/Import/M1.purs b/tests/purus/passing/Import/M1.purs new file mode 100644 index 00000000..ec535855 --- /dev/null +++ b/tests/purus/passing/Import/M1.purs @@ -0,0 +1,6 @@ +module M1 where + +id :: forall a. a -> a +id = \x -> x + +foo = id diff --git a/tests/purus/passing/Import/M2.purs b/tests/purus/passing/Import/M2.purs new file mode 100644 index 00000000..a6a9846e --- /dev/null +++ b/tests/purus/passing/Import/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import M1 + +main = \_ -> foo 42 diff --git a/tests/purus/passing/ImportExplicit/M1.purs b/tests/purus/passing/ImportExplicit/M1.purs new file mode 100644 index 00000000..cf27f2df --- /dev/null +++ b/tests/purus/passing/ImportExplicit/M1.purs @@ -0,0 +1,4 @@ +module M1 where + +data X = X | Y +data Z = Z diff --git a/tests/purus/passing/ImportQualified/M1.purs b/tests/purus/passing/ImportQualified/M1.purs new file mode 100644 index 00000000..719a1a03 --- /dev/null +++ b/tests/purus/passing/ImportQualified/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +log x = x diff --git a/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs b/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs new file mode 100644 index 00000000..c9666933 --- /dev/null +++ b/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs @@ -0,0 +1,4 @@ +module ImportedClassName where + +class ClassName a where + foo :: a -> Int diff --git a/tests/purus/passing/ModuleDeps/M1.purs b/tests/purus/passing/ModuleDeps/M1.purs new file mode 100644 index 00000000..535aa287 --- /dev/null +++ b/tests/purus/passing/ModuleDeps/M1.purs @@ -0,0 +1,5 @@ +module M1 where + +import M2 as M2 + +foo = M2.bar diff --git a/tests/purus/passing/ModuleDeps/M2.purs b/tests/purus/passing/ModuleDeps/M2.purs new file mode 100644 index 00000000..017e70e3 --- /dev/null +++ b/tests/purus/passing/ModuleDeps/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import M3 as M3 + +bar = M3.baz diff --git a/tests/purus/passing/ModuleDeps/M3.purs b/tests/purus/passing/ModuleDeps/M3.purs new file mode 100644 index 00000000..f07167b7 --- /dev/null +++ b/tests/purus/passing/ModuleDeps/M3.purs @@ -0,0 +1,3 @@ +module M3 where + +baz = 1 diff --git a/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs new file mode 100644 index 00000000..59097710 --- /dev/null +++ b/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{f, l}} +class C f l r | l -> r +data L diff --git a/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs b/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs new file mode 100644 index 00000000..49b5b73e --- /dev/null +++ b/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{l, r}} +class C l r +data R From df4b8b8800b6158397c857ef56e3032b0d0a4ce1 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Thu, 22 Feb 2024 18:08:06 -0700 Subject: [PATCH 26/44] Remove Nix Plutarch wrapper --- default.nix | 15 +++++++++++-- flake.nix | 1 - nix/haskell/mk-hackage.nix | 2 ++ nix/plutarch/default.nix | 28 ------------------------ nix/plutarch/lib.nix | 44 -------------------------------------- 5 files changed, 15 insertions(+), 75 deletions(-) delete mode 100644 nix/plutarch/default.nix delete mode 100644 nix/plutarch/lib.nix diff --git a/default.nix b/default.nix index 83f611fb..4ff7fc51 100644 --- a/default.nix +++ b/default.nix @@ -1,9 +1,20 @@ { - perSystem = { self', config, ... }: + perSystem = { self', pkgs, config, ... }: let - purus = config.libPlutarch.mkPackage { + cardanoPackages = pkgs.fetchFromGitHub { + owner = "input-output-hk"; + repo = "cardano-haskell-packages"; + rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo + hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; + }; + + purus = config.libHaskell.mkPackage { name = "purus"; src = ./.; + + externalRepositories = { + "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; + }; }; in { diff --git a/flake.nix b/flake.nix index 9552252a..555cfe2e 100644 --- a/flake.nix +++ b/flake.nix @@ -24,7 +24,6 @@ let flakeModules = { haskell = ./nix/haskell; - plutarch = ./nix/plutarch; utils = ./nix/utils; }; in diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix index 9bd43db8..fc89862f 100644 --- a/nix/haskell/mk-hackage.nix +++ b/nix/haskell/mk-hackage.nix @@ -1,3 +1,5 @@ +# Adapted from https://github.com/mlabs-haskell/mlabs-tooling.nix/blob/cd0cf0d29f17980befe384248c16937589912c69/mk-hackage.nix + { gzip , runCommand , lib diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix deleted file mode 100644 index afb64fb4..00000000 --- a/nix/plutarch/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -{ lib -, flake-parts-lib -, ... -}: -let - inherit (flake-parts-lib) mkPerSystemOption; -in -{ - options = { - perSystem = mkPerSystemOption ({ config, pkgs, ... }: { - options = { - libPlutarch = lib.mkOption { - type = lib.types.anything; - default = { }; - }; - }; - - config = { - libPlutarch = { - mkPackage = pkgs.callPackage ./lib.nix { - mkHaskellPackage = config.libHaskell.mkPackage; - inherit (config.libUtils) applyPatches; - }; - }; - }; - }); - }; -} diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix deleted file mode 100644 index 3ec84f23..00000000 --- a/nix/plutarch/lib.nix +++ /dev/null @@ -1,44 +0,0 @@ -{ fetchFromGitHub -, mkHaskellPackage -, applyPatches -, fetchpatch -}: - -let - plutarchPackage = applyPatches { - name = "plutarch-patched"; - src = fetchFromGitHub { - owner = "Plutonomicon"; - repo = "plutarch-plutus"; - rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master - hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0="; - }; - - patches = [ - # https://github.com/Plutonomicon/plutarch-plutus/pull/650 - (fetchpatch { - url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch"; - hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek="; - }) - ]; - }; - - cardanoPackages = fetchFromGitHub { - owner = "input-output-hk"; - repo = "cardano-haskell-packages"; - rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo - hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; - }; -in - -args: -mkHaskellPackage (args // { - externalRepositories = { - "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; - } // (args.externalRepositories or { }); - - externalDependencies = [ - "${plutarchPackage}" - "${plutarchPackage}/plutarch-extra" - ] ++ (args.externalDependencies or [ ]); -}) From 5a834377ef832b1cf297ba295d7258c1bb1c3cd5 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 27 Feb 2024 00:51:41 -0500 Subject: [PATCH 27/44] Fixed bug discovered in test #4301 (I hope...) --- src/Language/PureScript/CoreFn/Desugar.hs | 144 +++++++++----- .../PureScript/CoreFn/Desugar/Utils.hs | 99 ++++++++-- src/Language/PureScript/CoreFn/Expr.hs | 4 +- src/Language/PureScript/CoreFn/Pretty.hs | 10 +- src/Language/PureScript/Environment.hs | 6 +- src/Language/PureScript/Make/Actions.hs | 5 +- tests/purus/passing/Misc/Lib.purs | 177 ++++++++++++++++++ 7 files changed, 374 insertions(+), 71 deletions(-) create mode 100644 tests/purus/passing/Misc/Lib.purs diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 9e72366e..d52a00fe 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -4,14 +4,14 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, (<=<), Bifunctor (bimap)) import Data.Maybe (mapMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), SourceAnn) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) @@ -34,7 +34,7 @@ import Language.PureScript.Environment ( tyString, tyChar, tyInt, - tyNumber ) + tyNumber, function, pattern (:$),pattern RecordT ) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names ( pattern ByNullSourcePos, Ident(..), @@ -47,13 +47,13 @@ import Language.PureScript.Names ( runIdent, coerceProperName, Name (DctorName)) -import Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString, prettyPrintString) import Language.PureScript.Types ( pattern REmptyKinded, SourceType, Type(..), srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns) + srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns, replaceTypeVars, rowToList, RowListItem (..), freeTypeVariables) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -66,14 +66,14 @@ import Language.PureScript.TypeChecker.Types SplitBindingGroup(SplitBindingGroup), TypedValue'(TypedValue'), typeDictionaryForBindingGroup, - infer ) + infer, instantiatePolyTypeWithUnknowns, inferBinder, instantiateForBinders ) import Data.List.NonEmpty qualified as NE import Language.PureScript.TypeChecker.Unify (unifyTypes) -import Control.Monad (forM, (>=>)) +import Control.Monad (forM, (>=>), foldM) import Language.PureScript.Errors ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) import Debug.Trace (traceM) -import Language.PureScript.CoreFn.Pretty ( ppType ) +import Language.PureScript.CoreFn.Pretty ( ppType, renderExpr ) import Data.Text qualified as T import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.TypeChecker.Monad @@ -108,11 +108,14 @@ import Language.PureScript.CoreFn.Desugar.Utils toReExportRef, traverseLit, wrapTrace, - M, unwrapRecord, withInstantiatedFunType, + desugarConstraintTypes, + M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs ) import Text.Pretty.Simple (pShow) import Data.Text.Lazy qualified as LT import Data.Set qualified as S +import Language.PureScript.TypeChecker (replaceAllTypeSynonyms) +import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) {- CONVERSION MACHINERY @@ -131,9 +134,11 @@ import Data.Set qualified as S moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn (A.Module modSS coms mn decls (Just exps)) = do +moduleToCoreFn (A.Module modSS coms mn _decls (Just exps)) = do setModuleName - let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) + desugarConstraintTypes + let decls = desugarConstraintsInDecl <$> _decls + importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls exps' = ordNub $ concatMap exportToCoreFn exps reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) @@ -156,7 +161,7 @@ lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibil lookupType sp tn = do mn <- getModuleName env <- gets checkEnv - case M.lookup (Qualified (BySourcePos sp) tn) (names env) of + case M.lookup (Qualified (BySourcePos sp) tn) (names env) of Nothing -> case M.lookup (mkQualified tn mn) (names env) of Nothing -> do pEnv <- printEnv @@ -178,7 +183,7 @@ declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of [(_,wrappedTy)] -> do -- traceM (show ctor) - let innerFunTy = quantify $ purusFun wrappedTy wrappedTy + let innerFunTy = quantify $ function wrappedTy wrappedTy pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] _ -> error "Found newtype with multiple fields" @@ -201,6 +206,7 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DA -- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here? -- NOTE: Should be impossible to have a guarded expr here, make it an error declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do + traceM $ renderValue 100 e (valDeclTy,nv) <- lookupType (spanStart ss) name bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? @@ -226,9 +232,27 @@ declToCoreFn _ _ = pure [] -- Desugars expressions from AST to typed CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) +exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal ss' (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do + arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts + pure $ Literal (ss,[],Nothing) arrT arr +exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal ss' (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do + traceM $ "ObjLitTy: " <> show row + let (tyFields,_) = rowToList row + tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields + resolvedFields <- foldM (go tyMap) [] objFields + pure $ Literal (ss,[],Nothing) recTy (ObjectLiteral resolvedFields) + where + go :: M.Map PSString (RowListItem SourceAnn) -> [(PSString, Expr Ann)] -> (PSString, A.Expr) -> m [(PSString, Expr Ann)] + go tyMap acc (lbl,expr) = case M.lookup lbl tyMap of + Just rowListItem -> do + let fieldTy = rowListType rowListItem + expr' <- exprToCoreFn mn ss (Just fieldTy) expr + pure $ (lbl,expr'):acc + Nothing -> error $ "row type missing field " <> T.unpack (prettyPrintString lbl) -- Literal case is straightforward exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do litT <- purusTy <$> inferType mTy astLit + traceM $ "LIT TY: " <> ppType 1000 litT lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit pure $ Literal (ss, [], Nothing) litT lit' -- Accessor case is straightforward @@ -264,30 +288,65 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ withInstantiatedFunType mn t $ \a b -> do body <- bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body + pure $ Abs (ssA ssb) (function a b) name body -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = - internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t) + internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> show lam <> "\n\n" <> show (const () <$> t) -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. -- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType -- TODO: Investigate whether still necessary -exprToCoreFn mn ss mTy app@(A.App v1 v2) - | isDictCtor v2 && isDictInstCase v1 = wrapTrace "exprToCoreFn APP DICT" $ do - v2' <- exprToCoreFn mn ss Nothing v2 - toBind <- mkDictInstBinder v1 - v1' <- bindLocalVariables toBind $ exprToCoreFn mn ss Nothing v1 - appT <- inferType mTy app - pure $ App (ss, [], Just IsSyntheticApp) (purusTy appT) v1' v2' +-- FIXME: Something's off here, see output for 4310 +exprToCoreFn mn ss mTy app@(A.App fun arg) + | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do + let analyzed = mTy >>= analyzeCtor + prettyAnalyzed = bimap (ppType 100) (fmap (ppType 100)) <$> analyzed + traceM $ "APP DICT analyzed:\n" <> show prettyAnalyzed + case analyzed of + Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> do + traceM $ "APP Dict name: " <> T.unpack (runProperName nm) + env <- getEnv + case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of + Just (_, _, ty, _) -> do + traceM $ "APP Dict original type:\n" <> ppType 100 ty + case instantiate ty args of + iFun@(iArg :-> iRes) -> do + traceM $ "APP Dict iArg:\n" <> ppType 100 iArg + traceM $ "APP Dict iRes:\n" <> ppType 100 iRes + fun' <- exprToCoreFn mn ss (Just iFun) fun + arg' <- exprToCoreFn mn ss (Just iArg) arg + pure $ App (ss,[],Nothing) iRes fun' arg' + _ -> error "dict ctor has to have a function type" + _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ (Qualified qb $ coerceProperName nm) + Just (other,_) -> error $ error $ "APP Dict not a constructor type (impossible?): \n" <> ppType 100 other + Nothing -> error $ "APP Dict w/o type passed in:\n" <> renderValue 100 app + -- type should be something like: Test$Dict (Tuple a b) + -- lookup the type of the Dict ctor (should have one quantified record arg), i.e. + -- forall a. { runTest :: a -> String } -> { runTest :: a -> String } + -- instantiate the args, giving something like: + -- {runTest :: Tuple a b -> String} - | otherwise = wrapTrace "exprToCoreFn APP" $ do + | otherwise = wrapTrace "exprToCoreFn APP" $ do + {- appT <- inferType mTy app - v1' <- exprToCoreFn mn ss Nothing v1 - v2' <- exprToCoreFn mn ss Nothing v2 - pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' + fun' <- exprToCoreFn mn ss Nothing fun + arg' <- exprToCoreFn mn ss Nothing arg + pure $ App (ss, [], Nothing) appT fun' arg' + -} + fun' <- exprToCoreFn mn ss Nothing fun + let funTy = exprType fun' + traceM $ "app fun:\n" <> (ppType 100 funTy) <> "\n" <> renderExpr 100 fun' + withInstantiatedFunType mn funTy $ \a b -> do + -- fun'' <- exprToCoreFn mn ss (Just $ function a b) fun + arg' <- exprToCoreFn mn ss (Just a) arg + traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' + -- unifyTypes b appT + pure $ App (ss, [], Nothing) b fun' arg' + where + {- mkDictInstBinder = \case A.TypedValue _ e _ -> mkDictInstBinder e A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do @@ -302,11 +361,12 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2) isDictInstCase = \case A.TypedValue _ e _ -> isDictInstCase e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name + A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name _ -> False - +-} isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name + A.TypedValue _ e _ -> isDictCtor e _ -> False isSynthetic = \case A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 @@ -346,14 +406,13 @@ exprToCoreFn _ _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CT pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name -- Case expressions exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do - traceM $ renderValue 100 astCase + traceM $ "CASE:\n" <> renderValue 100 astCase + traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy) caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. - traceM "CASE.1" ts <- traverse (infer >=> pure . tvType) vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list) - traceM $ ppType 100 caseTy - pTrace vs - vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe zipWithM + --(vs_,ts) <- instantiateForBinders vs alts -- maybe zipWithM alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s) + vs' <- traverse (exprToCoreFn mn ss Nothing) vs pure $ Case (ssA ss) (purusTy caseTy) vs' alts' where tvType (TypedValue' _ _ t) = t @@ -419,10 +478,6 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo an unknown type is correct *during the initial typechecking phase*, but it is disastrous for us because we need to preserve the quantifiers explicitly in the typed AST. - Both of these functions work for reasonably simple examples, but may fail in more complex cases. - The primary reason for this is: I'm not sure how to write PS source that contains some of the - weirder cases in the AST. We'll have to deal with any problems once we have examples that - clearly isolate the problematic syntax nodes. -} transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) @@ -481,23 +536,26 @@ inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inf inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name)) $ return $ M.singleton name (ss, val) inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do + traceM $ "InferBinder VAL:\n" <> ppType 100 val env <- getEnv + let cArgs = ctorArgs val + traceM $ "InferBinder CTOR ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") cArgs case M.lookup ctor (dataConstructors env) of - Just (_, _, ty, _) -> do - traceM (ppType 100 ty) - let (args, ret) = peelArgs ty - -- unifyTypes ret val -- TODO: Check whether necesseary? + Just (_, _, _ty, _) -> do + let ty = instantiate _ty cArgs + traceM $ "InferBinder CTOR TY:\n" <> ppType 100 ty + let (args, _) = peelArgs ty + traceM $ "InferBinder ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") args M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - -- REVIEW: Instantiating the quantifier might not be safe here? peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. peelArgs = go [] where - go args (ForAll _ _ _ _ innerTy _) = go args innerTy go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do + traceM $ ppType 100 val let props' = sortOn fst props case unwrapRecord val of Left notARecord -> error diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index d92ed3e8..9bc92bcc 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -11,9 +11,10 @@ import Data.Function (on) import Data.Tuple (swap) import Data.Map qualified as M +import Language.PureScript.AST qualified as A import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) -import Language.PureScript.AST.Traversals (everythingOnValues) +import Language.PureScript.AST.Traversals (everythingOnValues, overTypes) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Expr(..), PurusType) @@ -30,9 +31,9 @@ import Language.PureScript.Environment ( dictTypeName, TypeClassData (typeClassArguments), function, - pattern (:->)) + pattern (:->), pattern (:$), isDictTypeName) import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName) -import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..)) +import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..), replaceTypeVars, everywhereOnTypes) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Control.Monad.Supply.Class (MonadSupply) @@ -57,6 +58,7 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label(..)) +import Data.Bifunctor (Bifunctor(..)) {- UTILITIES -} @@ -64,6 +66,28 @@ import Language.PureScript.Label (Label(..)) -- | Type synonym for a monad that has all of the required typechecker functionality type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +ctorArgs :: SourceType -> [SourceType] +ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2] +ctorArgs _ = [] + +ctorFun :: SourceType -> Maybe SourceType +ctorFun (TypeApp _ t1 _) = go t1 + where + go (TypeApp _ tx _) = case ctorFun tx of + Nothing -> Just tx + Just tx' -> Just tx' + go other = Just other +ctorFun _ = Nothing + +analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType]) +analyzeCtor t = (,ctorArgs t) <$> ctorFun t + + +instantiate :: SourceType -> [SourceType] -> SourceType +instantiate ty [] = ty +instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts +instantiate other _ = other + -- | Traverse a literal. Note that literals are usually have a type like `Literal (Expr a)`. That is: The `a` isn't typically an annotation, it's an expression type traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b) traverseLit f = \case @@ -87,8 +111,8 @@ inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValu withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann) withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of (a :-> b, replaceForalls, bindAct) -> bindAct $ replaceForalls <$> act a b - (other,_,_) -> error - $ "Internal error. Expected a function type, but got: " <> ppType 1000 other + (other,_,_) -> let !showty = LT.unpack (pShow other) + in error $ "Internal error. Expected a function type, but got: " <> showty {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. @@ -105,22 +129,33 @@ withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of -- TODO: Explicitly return two sourcetypes for arg/return types instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) instantiatePolyType mn = \case - ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of + ForAll ann vis var mbk t mSkol -> case instantiatePolyType mn t of (inner,g,act) -> let f = \case Abs ann' ty' ident' expr' -> - Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' + Abs ann' (ForAll ann vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' other -> other -- FIXME: kindType? act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) in (inner, f . g, act') - ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of + -- this branch should be deprecated + {- + ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of (inner,g,act) -> let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass dictTyCon = srcTypeConstructor dictTyName dictTy = foldl srcTypeApp dictTyCon constraintArgs act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma in (function dictTy inner,g,act') + -} + fun@(a :-> r) -> case analyzeCtor a of + Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> + if isDictTypeName nm + then + let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma + in (fun,id,act') + else (fun,id,id) + other -> (fun,id,id) other -> (other,id,id) -- In a context where we expect a Record type (object literals, etc), unwrap the record and get at the underlying rowlist @@ -132,6 +167,7 @@ unwrapRecord = \case go :: RowListItem a -> (PSString, Type a) go RowListItem{..} = (runLabel rowListLabel, rowListType) + traceNameTypes :: M m => m () traceNameTypes = do nametypes <- getEnv >>= pure . debugNames @@ -155,17 +191,41 @@ desugarConstraintType' = \case in function dictTy inner other -> other -desugarConstraintType :: M m => Qualified Ident -> m () -desugarConstraintType i = do +desugarConstraintTypes :: M m => m () +desugarConstraintTypes = do env <- getEnv - let oldNameTypes = names env - case M.lookup i oldNameTypes of - Just (t,k,v) -> do - let newVal = (desugarConstraintType' t, k, v) - newNameTypes = M.insert i newVal oldNameTypes - newEnv = env {names = newNameTypes} - modify' $ \checkstate -> checkstate {checkEnv = newEnv} + let f = everywhereOnTypes desugarConstraintType' + oldNameTypes = names env + desugaredNameTypes = (\(st,nk,nv) -> (f st,nk,nv)) <$> oldNameTypes + + oldTypes = types env + desugaredTypes = first f <$> oldTypes + + oldCtors = dataConstructors env + desugaredCtors = (\(a,b,c,d) -> (a,b,f c,d)) <$> oldCtors + + oldSynonyms = typeSynonyms env + desugaredSynonyms = second f <$> oldSynonyms + + newEnv = env { names = desugaredNameTypes + , types = desugaredTypes + , dataConstructors = desugaredCtors + , typeSynonyms = desugaredSynonyms } + + modify' $ \checkstate -> checkstate {checkEnv = newEnv} + +desugarConstraintsInDecl :: A.Declaration -> A.Declaration +desugarConstraintsInDecl = \case + A.BindingGroupDeclaration decls -> + A.BindingGroupDeclaration + $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType' expr)) <$> decls + A.ValueDecl ann name nk bs [A.MkUnguarded e] -> + A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType' e] + A.DataDeclaration ann declTy tName args ctorDecs -> + let fixCtor (A.DataConstructorDeclaration a nm fields) = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType') <$> fields) + in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs) + other -> other -- Gives much more readable output (with colors for brackets/parens!) than plain old `show` @@ -200,8 +260,9 @@ showIdent' :: Ident -> String showIdent' = T.unpack . runIdent -- | Turns a `Type a` into a `Type ()`. We shouldn't need source position information for types. -purusTy :: Type a -> PurusType -purusTy = fmap (const ()) +-- NOTE: Deprecated (probably) +purusTy :: SourceType -> PurusType +purusTy = id -- fmap (const ()) -- | Given a class name, return the TypeClassData associated with the name. getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index f243761e..9b959180 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -11,10 +11,10 @@ import Language.PureScript.AST.Literals (Literal) import Language.PureScript.CoreFn.Binders (Binder) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (Type) +import Language.PureScript.Types (Type, SourceType) -type PurusType = Type () +type PurusType = SourceType -- Type () -- | -- Data type for expressions and terms diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 60975d76..90c86c09 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -74,7 +74,7 @@ prettyPrintValue :: Int -> Expr a -> Box -- prettyPrintValue d _ | d < 0 = text "..." prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps -prettyPrintValue d (App ann _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (App ann ty val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") // (prettyPrintValue (d-1) val) prettyPrintValue d (Case ann ty values binders) = (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // @@ -110,14 +110,14 @@ prettyPrintDeclaration d b = case b of NonRec _ ident expr -> vcat left [ text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr, -- not sure about the d here - text "\n" + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here + ] Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> vcat left [ text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr, - text "\n" + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr + ]) bindings prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index cab4e45f..88fd5f1f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -379,6 +379,10 @@ pattern ArrayT :: Type a -> Type a pattern ArrayT a <- TypeApp _ (TypeConstructor _ C.Array) a +pattern (:$) :: Type a -> Type a -> Type a +pattern f :$ a <- + TypeApp _ f a + arrayT :: Type a -> Type () arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ()) @@ -388,7 +392,7 @@ pattern RecordT a <- -getFunArgTy :: Type () -> Type () +getFunArgTy :: Type a -> Type a getFunArgTy = \case a :-> _ -> a ForAll _ _ _ _ t _ -> getFunArgTy t diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 4162faa0..a1e13c32 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -60,6 +60,7 @@ import System.FilePath ((), makeRelative, splitPath, normalise, splitDirector import System.FilePath.Posix qualified as Posix import System.IO (stderr) import Language.PureScript.CoreFn.ToJSON (moduleToJSON) +import Language.PureScript.CoreFn.Pretty (prettyPrintModule') -- | Determines when to rebuild a module data RebuildPolicy @@ -263,7 +264,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when (S.member Docs codegenTargets) $ do lift $ writeJSONFile (outputFilename mn "docs.json") docs when (S.member CoreFn codegenTargets) $ do - lift $ writeJSONFile (targetFilename mn CoreFn) (moduleToJSON (makeVersion [0,0,1]) m) + let targetFile = (targetFilename mn CoreFn) + lift $ writeJSONFile targetFile (moduleToJSON (makeVersion [0,0,1]) m) + lift $ makeIO "write pretty core" $ writeFile (targetFile <> ".pretty") (prettyPrintModule' m) when (S.member CheckCoreFn codegenTargets) $ do let mn' = T.unpack (runModuleName mn) mabOldModule <- lift $ readJSONFile (targetFilename mn CoreFn) diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs new file mode 100644 index 00000000..99f05ec4 --- /dev/null +++ b/tests/purus/passing/Misc/Lib.purs @@ -0,0 +1,177 @@ +module Lib where + +{- Type Classes -} +-- Single Param +class Eq a where + eq :: a -> a -> Boolean + +minus :: Int -> Int -> Int +minus _ _ = 42 + +instance Eq Int where + eq _ _ = true + +testEq :: Boolean +testEq = eq 1 2 + +{- Tomasz's Counterexample -} +workingEven :: Int -> Int +workingEven n = + if n `eq` 0 then 1 + else 42 + +brokenEven :: Int -> Int -- N.B. shouldn't be broken anymore :) +brokenEven n = + if n `eq` 0 then 1 + else brokenEven (n `minus` 2) + +-- Multi Param +class Eq2 a b where + eq2 :: a -> b -> Boolean + +instance Eq2 Int Boolean where + eq2 _ _ = true + +testEq2 :: Boolean +testEq2 = eq2 101 false + +{- Binders (also tests a bunch of other things by happenstance) -} + +-- Unit test type for inferBinder' +data TestBinderSum = + ConInt Int + | ConInts (Array Int) + | ConBoolean Boolean + | ConString String + | ConChar Char + | ConNested TestBinderSum + | ConQuantified (forall x. x -> Int) + | ConConstrained (forall x. Eq x => x -> Int) -- kind of nonsensical + | ConObject {objField :: Int} + | ConObjectQuantified {objFieldQ :: forall x. x -> Int} + +testBinders :: TestBinderSum -> Int +testBinders x = case x of + a@(ConInt 3) -> 1 -- NamedBinder, ConstructorBinder, Int LitBinder + ConInt a -> a -- ConstructorBinder enclosing VarBinder + ConInts ([3] :: Array Int) -> 2 -- Array LitBinder, TypedBinder + ConInts [a,b] -> b -- VarBinders enclosed in Array LitBinder + ConBoolean true -> 4 -- Bool LitBinder + ConChar '\n' -> 5 -- Char LitBinder + ConNested (ConInt 2) -> 6 -- Nested ConstructorBinders + ConQuantified f -> f "hello" + ConConstrained f -> f 2 + ConNested other -> 7 + ConObject obj -> obj.objField + ConObjectQuantified objQ -> objQ.objFieldQ "world" + ConObject {objField: f} -> f + _ -> 0 + + +{- Binding groups (with and w/o type anns) -} +mutuallyRecursiveBindingGroup :: Int +mutuallyRecursiveBindingGroup = + let f :: Int -> Int + f x = g 2 + h :: Int -> Int -> Int + h x y = y + g :: Int -> Int + g y = h (f y) 3 + in g 3 + +{- TODO: Make this a shouldfail test +mutuallyRecursiveBindingGroupNoTypes :: Int +mutuallyRecursiveBindingGroupNoTypes = + let f' x = g' 2 + h' x y = y + g' y = h' (f' y) 3 + in g' 3 +-} +nestedBinds :: Int +nestedBinds = + let f :: Int -> Int + f _ = 4 + + g :: forall (a :: Type). a -> Int + g _ = 5 + + h = let i = g "hello" + j = f i + in f j + in h + +{- Data declarations -} +data ADataRec = ADataRec {hello :: Int, world :: Boolean} + +newtype ANewtypeRec = ANewTypeRec {foo :: Int} + +data ASum = Constr1 Int | Constr2 Boolean + +{- lits -} +anIntLit :: Int +anIntLit = 1 + +aStringLit :: String +aStringLit = "woop" + +aVal :: Int +aVal = 1 + + +aBool :: Boolean +aBool = true + +aList :: Array Int +aList = [1,2,3,4,5] + +{- Functions -} + +aFunction :: forall x. x -> (forall y. y -> Int) -> Int +aFunction any f = f any + +aFunction2 :: Int -> Array Int +aFunction2 x = [x,1] + +aFunction3 :: Int -> Int +aFunction3 x = if (eq x 2) then 4 else 1 + +aFunction4 :: forall (r :: Row Type). {a :: Int | r} -> Int +aFunction4 r = r.a + +aFunction5 :: Int +aFunction5 = aFunction4 {a: 2} + +aFunction6 :: Int +aFunction6 = aFunction [] go + where + go :: forall (z :: Type). z -> Int + go _ = 10 + +{- Objects -} + +anObj :: {foo :: Int} +anObj = {foo: 3} + +objUpdate :: {foo :: Int} +objUpdate = anObj {foo = 4} + +polyInObj :: {bar :: forall x. x -> Int, baz :: Int} +polyInObj = {bar: go, baz : 100} + where + go :: forall y. y -> Int + go _ = 5 + +polyInObjMatch :: Int +polyInObjMatch = case polyInObj of + {bar: f, baz: _} -> f "hello" + +aPred :: Int -> Boolean +aPred _ = true + +{- We should probably just remove guarded case branches, see slack msg +guardedCase :: Int +guardedCase = case polyInObj of + {bar: _, baz: x} + | eq @Int x 4 -> x + _ -> 0 +-} From c99c476f7c4021f7990525c243bc897402a7d460 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 28 Feb 2024 23:35:16 -0500 Subject: [PATCH 28/44] Fixed issue w/ transitive imports resulting from explicitly desguaring dictionary types, (sort of) fixed let-generalization, ported over more tests --- src/Language/PureScript/CoreFn/Desugar.hs | 175 ++++++++---------- .../PureScript/CoreFn/Desugar/Utils.hs | 46 +++-- src/Language/PureScript/Environment.hs | 4 +- src/Language/PureScript/Make.hs | 16 +- src/Language/PureScript/Sugar.hs | 1 + src/Language/PureScript/Sugar/TypeClasses.hs | 6 +- src/Language/PureScript/TypeChecker/Monad.hs | 1 + src/Language/PureScript/TypeChecker/Types.hs | 7 +- tests/TestPurus.hs | 13 +- tests/purus/passing/Misc/Lib.purs | 4 +- .../passing/PendingConflictingImports/A.purs | 4 + .../passing/PendingConflictingImports/B.purs | 4 + .../PendingConflictingImports.purs | 8 + .../passing/PendingConflictingImports2/A.purs | 4 + .../PendingConflictingImports2.purs | 9 + tests/purus/passing/ReExportQualified/A.purs | 3 + tests/purus/passing/ReExportQualified/B.purs | 3 + tests/purus/passing/ReExportQualified/C.purs | 4 + .../ReExportQualified/ReExportQualified.purs | 9 + tests/purus/passing/RedefinedFixity/M1.purs | 6 + tests/purus/passing/RedefinedFixity/M2.purs | 3 + tests/purus/passing/RedefinedFixity/M3.purs | 4 + .../RedefinedFixity/RedefinedFixity.purs | 5 + .../passing/ResolvableScopeConflict/A.purs | 4 + .../passing/ResolvableScopeConflict/B.purs | 7 + .../ResolvableScopeConflict.purs | 12 ++ .../passing/ResolvableScopeConflict2/A.purs | 7 + .../ResolvableScopeConflict2.purs | 14 ++ .../passing/ResolvableScopeConflict3/A.purs | 4 + .../ResolvableScopeConflict3.purs | 9 + .../ShadowedModuleName.purs | 7 + .../passing/ShadowedModuleName/Test.purs | 6 + .../passing/TransitiveImport/Middle.purs | 9 + .../purus/passing/TransitiveImport/Test.purs | 9 + .../TransitiveImport/TransitiveImport.purs | 6 + 35 files changed, 304 insertions(+), 129 deletions(-) create mode 100644 tests/purus/passing/PendingConflictingImports/A.purs create mode 100644 tests/purus/passing/PendingConflictingImports/B.purs create mode 100644 tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs create mode 100644 tests/purus/passing/PendingConflictingImports2/A.purs create mode 100644 tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs create mode 100644 tests/purus/passing/ReExportQualified/A.purs create mode 100644 tests/purus/passing/ReExportQualified/B.purs create mode 100644 tests/purus/passing/ReExportQualified/C.purs create mode 100644 tests/purus/passing/ReExportQualified/ReExportQualified.purs create mode 100644 tests/purus/passing/RedefinedFixity/M1.purs create mode 100644 tests/purus/passing/RedefinedFixity/M2.purs create mode 100644 tests/purus/passing/RedefinedFixity/M3.purs create mode 100644 tests/purus/passing/RedefinedFixity/RedefinedFixity.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict/A.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict/B.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict2/A.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict3/A.purs create mode 100644 tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs create mode 100644 tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs create mode 100644 tests/purus/passing/ShadowedModuleName/Test.purs create mode 100644 tests/purus/passing/TransitiveImport/Middle.purs create mode 100644 tests/purus/passing/TransitiveImport/Test.purs create mode 100644 tests/purus/passing/TransitiveImport/TransitiveImport.purs diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index d52a00fe..27259b84 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,17 +1,17 @@ {- HLINT ignore "Use void" -} {- HLINT ignore "Use <$" -} -{-# LANGUAGE TypeApplications #-} + module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, (<=<), Bifunctor (bimap)) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap)) import Data.Maybe (mapMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), SourceAnn) +import Language.PureScript.AST.SourcePos (SourceSpan(..), SourceAnn) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) @@ -27,20 +27,20 @@ import Language.PureScript.Environment ( isDictTypeName, lookupConstructor, lookupValue, - purusFun, NameVisibility (..), tyBoolean, tyFunction, tyString, tyChar, tyInt, - tyNumber, function, pattern (:$),pattern RecordT ) + tyNumber, + function, + pattern RecordT ) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names ( pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), - ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified, @@ -51,9 +51,7 @@ import Language.PureScript.PSString (PSString, prettyPrintString) import Language.PureScript.Types ( pattern REmptyKinded, SourceType, - Type(..), - srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns, replaceTypeVars, rowToList, RowListItem (..), freeTypeVariables) + Type(..), quantify, eqType, containsUnknowns, rowToList, RowListItem (..)) import Language.PureScript.AST.Binders qualified as A import Language.PureScript.AST.Declarations qualified as A import Language.PureScript.AST.SourcePos qualified as A @@ -65,8 +63,7 @@ import Language.PureScript.TypeChecker.Types ( checkTypeKind, SplitBindingGroup(SplitBindingGroup), TypedValue'(TypedValue'), - typeDictionaryForBindingGroup, - infer, instantiatePolyTypeWithUnknowns, inferBinder, instantiateForBinders ) + typeDictionaryForBindingGroup ) import Data.List.NonEmpty qualified as NE import Language.PureScript.TypeChecker.Unify (unifyTypes) import Control.Monad (forM, (>=>), foldM) @@ -93,12 +90,9 @@ import Language.PureScript.CoreFn.Desugar.Utils getConstructorMeta, getLetMeta, getModuleName, - getTypeClassArgs, getValueMeta, importToCoreFn, inferType, - instantiatePolyType, - pTrace, printEnv, properToIdent, purusTy, @@ -109,13 +103,11 @@ import Language.PureScript.CoreFn.Desugar.Utils traverseLit, wrapTrace, desugarConstraintTypes, - M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs + M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs, instantiatePolyType, lookupDictType ) import Text.Pretty.Simple (pShow) import Data.Text.Lazy qualified as LT import Data.Set qualified as S -import Language.PureScript.TypeChecker (replaceAllTypeSynonyms) -import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope) {- CONVERSION MACHINERY @@ -193,8 +185,7 @@ declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ( declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d -- Data declarations get turned into value declarations for the constructor(s) -declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do - traverse go ctors +declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ traverse go ctors where go ctorDecl = do env <- gets checkEnv @@ -208,6 +199,7 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DA declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do traceM $ renderValue 100 e (valDeclTy,nv) <- lookupType (spanStart ss) name + traceM (ppType 100 valDeclTy) bindLocalVariables [(ss,name,valDeclTy,nv)] $ do expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here? pure [NonRec (ssA ss) name expr] @@ -221,10 +213,10 @@ declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDIN -- If we only ever call this on a top-level binding group then this should be OK, all the exprs should be explicitly typed extractTypeAndPrepareBind :: ((A.SourceAnn, Ident), NameKind, A.Expr) -> (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) extractTypeAndPrepareBind (((ss',_),ident),_,A.TypedValue _ e ty) = (e,(ss',ident,ty,Defined)) - extractTypeAndPrepareBind (((ss',_),ident),_,_) = error $ "Top level declaration " <> (showIdent' ident) <> " should have a type annotation, but does not" + extractTypeAndPrepareBind (((_,_),ident),_,_) = error $ "Top level declaration " <> showIdent' ident <> " should have a type annotation, but does not" goRecBindings :: (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) -> m ((Ann, Ident), Expr Ann) - goRecBindings (expr,(ss',ident,ty,nv)) = do + goRecBindings (expr,(ss',ident,ty,_)) = do expr' <- exprToCoreFn mn ss' (Just ty) expr pure ((ssA ss',ident), expr') -- TODO: Avoid catchall case @@ -232,10 +224,10 @@ declToCoreFn _ _ = pure [] -- Desugars expressions from AST to typed CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) -exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal ss' (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do +exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts pure $ Literal (ss,[],Nothing) arrT arr -exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal ss' (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do +exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do traceM $ "ObjLitTy: " <> show row let (tyFields,_) = rowToList row tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields @@ -293,34 +285,46 @@ exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprTo -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = - internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> show lam <> "\n\n" <> show (const () <$> t) + internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> renderValue 100 lam <> "\n\n" <> show (ppType 100 <$> t) -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. -- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType -- TODO: Investigate whether still necessary -- FIXME: Something's off here, see output for 4310 exprToCoreFn mn ss mTy app@(A.App fun arg) | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do + traceM $ "APP Dict type" <> show (ppType 100 <$> mTy) + traceM $ "APP Dict expr:\n" <> renderValue 100 app let analyzed = mTy >>= analyzeCtor prettyAnalyzed = bimap (ppType 100) (fmap (ppType 100)) <$> analyzed traceM $ "APP DICT analyzed:\n" <> show prettyAnalyzed - case analyzed of - Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> do - traceM $ "APP Dict name: " <> T.unpack (runProperName nm) - env <- getEnv - case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of - Just (_, _, ty, _) -> do - traceM $ "APP Dict original type:\n" <> ppType 100 ty - case instantiate ty args of - iFun@(iArg :-> iRes) -> do - traceM $ "APP Dict iArg:\n" <> ppType 100 iArg - traceM $ "APP Dict iRes:\n" <> ppType 100 iRes - fun' <- exprToCoreFn mn ss (Just iFun) fun - arg' <- exprToCoreFn mn ss (Just iArg) arg - pure $ App (ss,[],Nothing) iRes fun' arg' - _ -> error "dict ctor has to have a function type" - _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ (Qualified qb $ coerceProperName nm) - Just (other,_) -> error $ error $ "APP Dict not a constructor type (impossible?): \n" <> ppType 100 other - Nothing -> error $ "APP Dict w/o type passed in:\n" <> renderValue 100 app + case mTy of + Just iTy -> + case analyzed of + Just (TypeConstructor _ (Qualified qb nm), args) -> do + traceM $ "APP Dict name: " <> T.unpack (runProperName nm) + env <- getEnv + case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of + Just (_, _, ty, _) -> do + traceM $ "APP Dict original type:\n" <> ppType 100 ty + case instantiate ty args of + iFun@(iArg :-> iRes) -> do + traceM $ "APP Dict iArg:\n" <> ppType 100 iArg + traceM $ "APP Dict iRes:\n" <> ppType 100 iRes + fun' <- exprToCoreFn mn ss (Just iFun) fun + arg' <- exprToCoreFn mn ss (Just iArg) arg + pure $ App (ss,[],Nothing) iTy fun' arg' + _ -> error "dict ctor has to have a function type" + _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ Qualified qb (coerceProperName nm) + Just (other,_) -> error $ "APP Dict not a constructor type (impossible here?): \n" <> ppType 100 other + Nothing -> do + -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds + -- in the output + let (inner,g,act) = instantiatePolyType mn iTy + act (exprToCoreFn mn ss (Just inner) app) >>= \case + App ann' _ e1 e2 -> pure . g $ App ann' iTy e1 e2 + other -> error "An application desguared to something else. This should not be possible." + Nothing -> error $ "APP Dict w/o type passed in (impossible to infer):\n" <> renderValue 100 app + -- type should be something like: Test$Dict (Tuple a b) -- lookup the type of the Dict ctor (should have one quantified record arg), i.e. @@ -329,51 +333,29 @@ exprToCoreFn mn ss mTy app@(A.App fun arg) -- {runTest :: Tuple a b -> String} | otherwise = wrapTrace "exprToCoreFn APP" $ do - {- - appT <- inferType mTy app - fun' <- exprToCoreFn mn ss Nothing fun - arg' <- exprToCoreFn mn ss Nothing arg - pure $ App (ss, [], Nothing) appT fun' arg' - -} - fun' <- exprToCoreFn mn ss Nothing fun - let funTy = exprType fun' - traceM $ "app fun:\n" <> (ppType 100 funTy) <> "\n" <> renderExpr 100 fun' - withInstantiatedFunType mn funTy $ \a b -> do - -- fun'' <- exprToCoreFn mn ss (Just $ function a b) fun - arg' <- exprToCoreFn mn ss (Just a) arg - traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' - -- unifyTypes b appT - pure $ App (ss, [], Nothing) b fun' arg' - + traceM $ renderValue 100 app + case mTy of + Just appT -> do + fun' <- exprToCoreFn mn ss Nothing fun + let funTy = exprType fun' + traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' + withInstantiatedFunType mn funTy $ \a b -> do + arg' <- exprToCoreFn mn ss (Just a) arg + traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' + pure $ App (ss, [], Nothing) appT fun' arg' + Nothing -> do + fun' <- exprToCoreFn mn ss Nothing fun + let funTy = exprType fun' + traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' + withInstantiatedFunType mn funTy $ \a b -> do + arg' <- exprToCoreFn mn ss (Just a) arg + traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' + pure $ App (ss, [], Nothing) b fun' arg' where - {- - mkDictInstBinder = \case - A.TypedValue _ e _ -> mkDictInstBinder e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do - let className :: Qualified (ProperName 'ClassName) = coerceProperName <$> cn - args' <- getTypeClassArgs className - let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show @Int i)) [1..] args' - dictTyCon = srcTypeConstructor (coerceProperName <$> cn) - dictTyFreeVars = foldl srcTypeApp dictTyCon args - ty = quantify dictTyFreeVars - pure [(A.NullSourceSpan,Ident "dict",ty,Defined)] - _ -> error "invalid dict accesor expr" - - isDictInstCase = \case - A.TypedValue _ e _ -> isDictInstCase e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name - _ -> False --} isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name A.TypedValue _ e _ -> isDictCtor e _ -> False - isSynthetic = \case - A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 - A.Accessor _ v3 -> isSynthetic v3 - A.Var NullSourceSpan _ -> True - A.Unused{} -> True - _ -> False -- Dunno what to do here. Haven't encountered an Unused so far, will need to see one to figure out how to handle them exprToCoreFn _ _ _ (A.Unused _) = -- ????? need to figure out what this _is_ error "Don't know what to do w/ exprToCoreFn A.Unused" @@ -382,10 +364,12 @@ exprToCoreFn _ _ _ (A.Unused _) = -- ????? need to figure out what this _is_ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident - Nothing -> do + Nothing -> lookupDictType ident >>= \case + Just ty -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident + Nothing -> do -- pEnv <- printEnv - traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) - error "boom" + traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) + error "boom" -- If-Then-Else Turns into a case expression exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do -- NOTE/TODO: Don't need to call infer separately here @@ -409,15 +393,11 @@ exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" traceM $ "CASE:\n" <> renderValue 100 astCase traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy) caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. - ts <- traverse (infer >=> pure . tvType) vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list) - --(vs_,ts) <- instantiateForBinders vs alts -- maybe zipWithM + (vs',ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\ e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees* alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s) - vs' <- traverse (exprToCoreFn mn ss Nothing) vs pure $ Case (ssA ss) (purusTy caseTy) vs' alts' - where - tvType (TypedValue' _ _ t) = t + -- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct. --- (I think we have to do this - the inferred type is "wrong" if it contains a class constraint) exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $ exprToCoreFn mn ss (Just ty) v exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $ @@ -489,10 +469,12 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk transformLetBindings mn _ss seen' rest ret -- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do - ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} - if not (containsUnknowns ty) + -- ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} + e <- exprToCoreFn mn ss Nothing val + let ty = exprType e + if not (containsUnknowns ty) -- TODO: Don't need this anymore (shouldn't ever contain unknowns) then bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)]) + let thisDecl = [NonRec (ssA ss) ident e] let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret else error @@ -572,7 +554,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff where deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType)) - deduceRowProperties types [] = pure M.empty + deduceRowProperties _ [] = pure M.empty deduceRowProperties types ((lbl,bndr):rest) = case M.lookup lbl types of Nothing -> error $ "Cannot deduce type information for record with label " <> show lbl -- should be impossible after typechecking Just ty -> do @@ -580,8 +562,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin xs <- deduceRowProperties types rest pure $ M.union x xs -- TODO: Remove ArrayT pattern synonym -inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do - M.unions <$> traverse (inferBinder' val) binders +inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ M.unions <$> traverse (inferBinder' val) binders inferBinder' _ (A.LiteralBinder _ (ArrayLiteral _)) = internalError "bad type in array binder " inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $ warnAndRethrowWithPositionTC ss $ do diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index 9bc92bcc..f3f37e86 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -59,6 +59,9 @@ import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label(..)) import Data.Bifunctor (Bifunctor(..)) +import Data.List.NonEmpty qualified as NEL +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (..)) +import Data.List (foldl') {- UTILITIES -} @@ -66,10 +69,12 @@ import Data.Bifunctor (Bifunctor(..)) -- | Type synonym for a monad that has all of the required typechecker functionality type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +-- Extract all of the arguments to a type constructor ctorArgs :: SourceType -> [SourceType] ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2] ctorArgs _ = [] +-- Extract the TyCon ("function") part of an applied Type Constructor ctorFun :: SourceType -> Maybe SourceType ctorFun (TypeApp _ t1 _) = go t1 where @@ -82,7 +87,6 @@ ctorFun _ = Nothing analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType]) analyzeCtor t = (,ctorArgs t) <$> ctorFun t - instantiate :: SourceType -> [SourceType] -> SourceType instantiate ty [] = ty instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts @@ -101,7 +105,7 @@ traverseLit f = \case -- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType inferType (Just t) _ = pure t -inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> +inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> infer e >>= \case TypedValue' _ _ t -> do traceM ("TYPE: " <> ppType 100 t) @@ -138,24 +142,14 @@ instantiatePolyType mn = \case -- FIXME: kindType? act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) in (inner, f . g, act') - -- this branch should be deprecated - {- - ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of - (inner,g,act) -> - let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass - dictTyCon = srcTypeConstructor dictTyName - dictTy = foldl srcTypeApp dictTyCon constraintArgs - act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma - in (function dictTy inner,g,act') - -} - fun@(a :-> r) -> case analyzeCtor a of - Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> + fun@(a :-> r) -> case analyzeCtor a of + Just (TypeConstructor _ (Qualified _ nm), _) -> if isDictTypeName nm then let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma in (fun,id,act') else (fun,id,id) - other -> (fun,id,id) + _ -> (fun,id,id) other -> (other,id,id) -- In a context where we expect a Record type (object literals, etc), unwrap the record and get at the underlying rowlist @@ -245,6 +239,28 @@ wrapTrace msg act = do startMsg = pad $ "BEGIN " <> msg endMsg = pad $ "END " <> msg + + +-- NOTE: Grotesqely inefficient, but since the scope can change I'm not sure what else we can do. +-- If this ends up matters, we have to rework the environment somehow +lookupDictType :: M m => Qualified Ident -> m (Maybe SourceType) +lookupDictType nm = do + tyClassDicts <- typeClassDictionaries <$> getEnv + let dictMap = dictionaryIdentMap tyClassDicts + pure $ M.lookup nm dictMap + where + dictionaryIdentMap :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + -> M.Map (Qualified Ident) SourceType + dictionaryIdentMap m = foldl' go M.empty inner + where + -- duplicates? + inner = concatMap NEL.toList . M.elems $ M.unions $ concatMap M.elems $ M.elems m + go :: M.Map (Qualified Ident) SourceType -> NamedDict -> M.Map (Qualified Ident) SourceType + go acc TypeClassDictionaryInScope{..} = M.insert tcdValue dictTy acc + where + dictTy = foldl' srcTypeApp dictTyCon tcdInstanceTypes + dictTyCon = srcTypeConstructor $ coerceProperName . dictTypeName <$> tcdClassName + -- | Generates a pretty (ish) representation of the type environment/context. For debugging. printEnv :: M m => m String printEnv = do diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 88fd5f1f..df2cc914 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -383,8 +383,8 @@ pattern (:$) :: Type a -> Type a -> Type a pattern f :$ a <- TypeApp _ f a -arrayT :: Type a -> Type () -arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ()) +arrayT :: SourceType -> SourceType +arrayT = TypeApp NullSourceAnn (TypeConstructor NullSourceAnn C.Array) pattern RecordT :: Type a -> Type a pattern RecordT a <- diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b041af6a..dec70c72 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -56,6 +56,7 @@ import System.FilePath (replaceExtension) -- Temporary import Debug.Trace (traceM) import Language.PureScript.CoreFn.Pretty (ppType) +import Language.PureScript.CoreFn.Desugar.Utils (pTrace) -- | Rebuild a single module. -- @@ -96,17 +97,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ withPrim = importPrim m lint withPrim - ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do + ((Module ss coms _ elaborated exps, env', chkSt), nextVar) <- runSupplyT 0 $ do (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' - (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env + (checked, chkSt@CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible -- Imports cannot be linted before type checking because we need to -- known which newtype constructors are used to solve Coercible -- constraints in order to not report them as unused. censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports' - return (checked, checkEnv) + return (checked, checkEnv, chkSt) -- desugar case declarations *after* type- and exhaustiveness checking -- since pattern guards introduces cases which the exhaustiveness checker @@ -117,14 +118,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps - traceM "PURUS START HERE" - ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') - traceM $ prettyEnv (checkEnv chkSt) + traceM $ "PURUS START HERE: " <> T.unpack (runModuleName moduleName) + -- pTrace regrouped + -- pTrace exps + ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env') + traceM $ CFT.prettyPrintModule' coreFn let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized exts = moduleToExternsFile mod' env' renamedIdents + --pTrace exts ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 4d713d54..fdaf44fd 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -73,3 +73,4 @@ desugar externs = >=> deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule + diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 7c2fc013..ccb699db 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -226,7 +226,7 @@ desugarDecl mn exps = go dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) in - return $ ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + return $ ValueDecl sa name' Public [] [MkUnguarded (TypedValue True dict constrainedTy)] return (expRef name' className tys, [d, dictDecl]) go other = return (Nothing, [other]) @@ -303,7 +303,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati -- NOTE: changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified {- -ByNullSourcePos -} (BySourcePos $ spanStart ss) dictObjIdent)) visibility = second (const TypeVarVisible) <$> args - in ValueDecl sa ident Private [] + in ValueDecl sa ident Public [] [MkUnguarded ( TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) @@ -363,7 +363,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = constrainedTy = quantify (foldr srcConstrainedType dictTy deps) dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props mkTV = if unreachable then TypedValue False (Var nullSourceSpan C.I_undefined) else TypedValue True dict - result = ValueDecl sa name Private [] [MkUnguarded (mkTV constrainedTy)] + result = ValueDecl sa name Public [] [MkUnguarded (mkTV constrainedTy)] return result where diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 396769a0..46be3f3e 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -110,6 +110,7 @@ data CheckState = CheckState emptyCheckState :: Environment -> CheckState emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty + -- | Unification variables type Unknown = Int diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ddc38a41..9faf7830 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -608,12 +608,15 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + TypedValue' chk val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + -- NOTE (from Sean): Returning a TypedValue gives us access to monomorphized types for un-annotated let bindings. + -- I'm not sure why they don't do this, perhaps there is a reason to avoid doing so? + let val'' = TypedValue chk val' valTy' bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val'']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs index 48567dae..d14d7ad0 100644 --- a/tests/TestPurus.hs +++ b/tests/TestPurus.hs @@ -81,9 +81,18 @@ shouldPass = map (prefix ) paths "ImportQualified", "InstanceUnnamedSimilarClassName", "ModuleDeps", + "Misc", "NonOrphanInstanceFunDepExtra", - "NonOrphanInstanceMulti" - + "NonOrphanInstanceMulti", + "PendingConflictingImports", + "PendingConflictingImports2", + "RedefinedFixity", + "ReExportQualified", + "ResolvableScopeConflict", + "ResolvableScopeConflict2", + "ResolvableScopeConflict3", + "ShadowedModuleName", + "TransitiveImport" ] diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs index 99f05ec4..17fc3900 100644 --- a/tests/purus/passing/Misc/Lib.purs +++ b/tests/purus/passing/Misc/Lib.purs @@ -79,14 +79,14 @@ mutuallyRecursiveBindingGroup = g y = h (f y) 3 in g 3 -{- TODO: Make this a shouldfail test + mutuallyRecursiveBindingGroupNoTypes :: Int mutuallyRecursiveBindingGroupNoTypes = let f' x = g' 2 h' x y = y g' y = h' (f' y) 3 in g' 3 --} + nestedBinds :: Int nestedBinds = let f :: Int -> Int diff --git a/tests/purus/passing/PendingConflictingImports/A.purs b/tests/purus/passing/PendingConflictingImports/A.purs new file mode 100644 index 00000000..302b0328 --- /dev/null +++ b/tests/purus/passing/PendingConflictingImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/tests/purus/passing/PendingConflictingImports/B.purs b/tests/purus/passing/PendingConflictingImports/B.purs new file mode 100644 index 00000000..076bf7ea --- /dev/null +++ b/tests/purus/passing/PendingConflictingImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs b/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs new file mode 100644 index 00000000..b42cd06f --- /dev/null +++ b/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs @@ -0,0 +1,8 @@ +module Main where + +-- No error as we never force `thing` to be resolved in `Main` +import A +import B + + +main = "Done" diff --git a/tests/purus/passing/PendingConflictingImports2/A.purs b/tests/purus/passing/PendingConflictingImports2/A.purs new file mode 100644 index 00000000..302b0328 --- /dev/null +++ b/tests/purus/passing/PendingConflictingImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs b/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs new file mode 100644 index 00000000..81c3d821 --- /dev/null +++ b/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs @@ -0,0 +1,9 @@ +module Main where + +import A + +-- No error as we never force `thing` to be resolved in `Main` +thing :: Int +thing = 2 + +main = "Done" diff --git a/tests/purus/passing/ReExportQualified/A.purs b/tests/purus/passing/ReExportQualified/A.purs new file mode 100644 index 00000000..ae231283 --- /dev/null +++ b/tests/purus/passing/ReExportQualified/A.purs @@ -0,0 +1,3 @@ +module A where + +x = "Do" diff --git a/tests/purus/passing/ReExportQualified/B.purs b/tests/purus/passing/ReExportQualified/B.purs new file mode 100644 index 00000000..2e149222 --- /dev/null +++ b/tests/purus/passing/ReExportQualified/B.purs @@ -0,0 +1,3 @@ +module B where + +y = "ne" diff --git a/tests/purus/passing/ReExportQualified/C.purs b/tests/purus/passing/ReExportQualified/C.purs new file mode 100644 index 00000000..589f37bc --- /dev/null +++ b/tests/purus/passing/ReExportQualified/C.purs @@ -0,0 +1,4 @@ +module C (module A, module M2) where + +import A +import B as M2 diff --git a/tests/purus/passing/ReExportQualified/ReExportQualified.purs b/tests/purus/passing/ReExportQualified/ReExportQualified.purs new file mode 100644 index 00000000..af2f8d27 --- /dev/null +++ b/tests/purus/passing/ReExportQualified/ReExportQualified.purs @@ -0,0 +1,9 @@ +module Main where + +import C + + +concat :: String -> String -> String +concat _ _ = "concat" + +main = x `concat` y diff --git a/tests/purus/passing/RedefinedFixity/M1.purs b/tests/purus/passing/RedefinedFixity/M1.purs new file mode 100644 index 00000000..703e37bf --- /dev/null +++ b/tests/purus/passing/RedefinedFixity/M1.purs @@ -0,0 +1,6 @@ +module M1 where + +applyFn :: forall a b. (forall c d. c -> d) -> a -> b +applyFn f a = f a + +infixr 1000 applyFn as $ diff --git a/tests/purus/passing/RedefinedFixity/M2.purs b/tests/purus/passing/RedefinedFixity/M2.purs new file mode 100644 index 00000000..f7ddf194 --- /dev/null +++ b/tests/purus/passing/RedefinedFixity/M2.purs @@ -0,0 +1,3 @@ +module M2 where + +import M1 diff --git a/tests/purus/passing/RedefinedFixity/M3.purs b/tests/purus/passing/RedefinedFixity/M3.purs new file mode 100644 index 00000000..cd62cc11 --- /dev/null +++ b/tests/purus/passing/RedefinedFixity/M3.purs @@ -0,0 +1,4 @@ +module M3 where + +import M1 +import M2 diff --git a/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs b/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs new file mode 100644 index 00000000..a796c579 --- /dev/null +++ b/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs @@ -0,0 +1,5 @@ +module Main where + +import M3 + +main = "Done" diff --git a/tests/purus/passing/ResolvableScopeConflict/A.purs b/tests/purus/passing/ResolvableScopeConflict/A.purs new file mode 100644 index 00000000..302b0328 --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/tests/purus/passing/ResolvableScopeConflict/B.purs b/tests/purus/passing/ResolvableScopeConflict/B.purs new file mode 100644 index 00000000..4ad4bb6f --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict/B.purs @@ -0,0 +1,7 @@ +module B where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs b/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs new file mode 100644 index 00000000..aa2bed42 --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs @@ -0,0 +1,12 @@ +module Main where + +import A (thing) +import B + +-- Not an error as although we have `thing` in scope from both A and B, it is +-- imported explicitly from A, giving it a resolvable solution. +what :: Boolean -> Int +what true = thing +what false = zing + +main = "Done" diff --git a/tests/purus/passing/ResolvableScopeConflict2/A.purs b/tests/purus/passing/ResolvableScopeConflict2/A.purs new file mode 100644 index 00000000..943011cd --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict2/A.purs @@ -0,0 +1,7 @@ +module A where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs b/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs new file mode 100644 index 00000000..899fadec --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs @@ -0,0 +1,14 @@ +module Main where + +import A + +thing :: Int +thing = 1 + +-- Not an error as although we have `thing` in scope from both Main and A, +-- as the local declaration takes precedence over the implicit import +what :: Boolean -> Int +what true = thing +what false = zing + +main = "Done" diff --git a/tests/purus/passing/ResolvableScopeConflict3/A.purs b/tests/purus/passing/ResolvableScopeConflict3/A.purs new file mode 100644 index 00000000..302b0328 --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict3/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs b/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs new file mode 100644 index 00000000..20400820 --- /dev/null +++ b/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs @@ -0,0 +1,9 @@ +module Main (thing, main, module A) where + +import A + + +thing :: Int +thing = 2 + +main = "Done" diff --git a/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs b/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs new file mode 100644 index 00000000..80061b5f --- /dev/null +++ b/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs @@ -0,0 +1,7 @@ +module Main where + +import Test + +data Test = Test + +main = runZ (Z "Done") diff --git a/tests/purus/passing/ShadowedModuleName/Test.purs b/tests/purus/passing/ShadowedModuleName/Test.purs new file mode 100644 index 00000000..b30eb2df --- /dev/null +++ b/tests/purus/passing/ShadowedModuleName/Test.purs @@ -0,0 +1,6 @@ +module Test where + +data Z = Z String + +runZ :: Z -> String +runZ (Z s) = s diff --git a/tests/purus/passing/TransitiveImport/Middle.purs b/tests/purus/passing/TransitiveImport/Middle.purs new file mode 100644 index 00000000..57e2a2b1 --- /dev/null +++ b/tests/purus/passing/TransitiveImport/Middle.purs @@ -0,0 +1,9 @@ +module Middle (module Test, unit, middle) where + +import Test + +unit :: Unit +unit = Unit + +middle :: forall a. TestCls a => a -> a +middle = test diff --git a/tests/purus/passing/TransitiveImport/Test.purs b/tests/purus/passing/TransitiveImport/Test.purs new file mode 100644 index 00000000..2d735b50 --- /dev/null +++ b/tests/purus/passing/TransitiveImport/Test.purs @@ -0,0 +1,9 @@ +module Test where + +data Unit = Unit + +class TestCls a where + test :: a -> a + +instance unitTestCls :: TestCls Unit where + test _ = Unit diff --git a/tests/purus/passing/TransitiveImport/TransitiveImport.purs b/tests/purus/passing/TransitiveImport/TransitiveImport.purs new file mode 100644 index 00000000..5d7ad43c --- /dev/null +++ b/tests/purus/passing/TransitiveImport/TransitiveImport.purs @@ -0,0 +1,6 @@ +module Main where + + import Middle + + main :: Unit + main = (middle unit) From 293acc930c757acad23ddf5e43a1d763382e8561 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 29 Feb 2024 16:42:58 -0500 Subject: [PATCH 29/44] Documenting/Explaining the use of new utils --- .../PureScript/CoreFn/Desugar/Utils.hs | 196 +++++++++++++++++- 1 file changed, 190 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index f3f37e86..aa777e9c 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -65,10 +65,111 @@ import Data.List (foldl') {- UTILITIES -} +--TODO: Explain purpose of every function + -- | Type synonym for a monad that has all of the required typechecker functionality type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + + +{- "Type Constructor analysis" machinery. (This requires some explaining) + + In the course of converting to typed CoreFn, we always proceed "top-down" + from top-level declarations which must have a type annotation attached + (their typechecker enforces this - it will add an inferred annotation if + the user fails to annotate the type). + + Because not all sub-expression (specifically, "synthetic applications" where a type class + dictionary constructor is applied to its argument in an instance declaration) are typed, + we may run into situations where the inferred or reconstructed type for a sub-expression + is universally quantified, even though we know (via our "top-down" approach) that the + quantified type variables should be instantiated (either to concrete types or to + type variables which are introduced in the outer lexical scope). + + An example (from test 4310) makes the problem clearer. Suppose we have: + + ``` + data Tuple a b = Tuple a b + + infixr 6 Tuple as /\ + infixr 6 type Tuple as /\ + + mappend :: String -> String -> String + mappend _ _ = "mappend" + + infixr 5 mappend as <> + + class Test a where + runTest :: a -> String + + instance Test Int where + runTest _ = "4" + + instance (Test a, Test b) => Test (a /\ b) where + runTest (a /\ b) = runTest a <> runTest b + + ``` + + The generated code for the typeclass declaration gives us (in part): + + ``` + Test$Dict :: forall a. { runTest :: a -> String } -> { runTest :: a -> String } + Test$Dict = \(x: { runTest :: a -> String} ) -> + (x: { runTest :: a -> String} ) + + runTest :: forall (@a :: Type). Test$Dict a -> a -> String + runTest = \(dict: Test$Dict a) -> + case (dict: Test$Dict a) of + (Test$Dict v) -> (v: { runTest :: a -> String} ).runTest + ``` + + Because the Tuple instance for Test uses `runTest` (the function), and because + `runTest` is universally quantified, if we did not instantiate those quantifiers, + a new skolem scope will be introduced at each application of `runTest`, giving us + type variables that cannot be unified with the outermost type variables. + + That is, without using this machiner (and `instantiate`), we end up with something like + this for the tuple instance: + + ``` + test/\ :: forall (a :: Type) (b :: Type). Test$Dict a -> Test$Dict b -> Test$Dict (Tuple a b) + test/\ = \(dictTest: Test$Dict a) -> + \(dictTest1: Test$Dict b) -> + (Test$Dict: { runTest :: a -> String} -> Test$Dict a ) { runTest: \(v: Tuple a0 b1) -> } + case (v: Tuple a0 b1) of + (Tuple a b) -> + ((mappend: String -> String -> String) + (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest: Test$Dict a)) (a: t1))) + (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest1: Test$Dict b)) (b: t2)) + ``` + + By using this machinery in `inferBinder'`, we can instantiate the quantifiers to the + lexically scoped type variables in the top-level signature, and get output that is properly typed: + + ``` + test/\ :: forall (a :: Type) (b :: Type). Test$Dict a -> Test$Dict b -> Test$Dict (Tuple a b) + test/\ = \(dictTest: Test$Dict a) -> + \(dictTest1: Test$Dict b) -> + (Test$Dict: { runTest :: Tuple a b -> String} -> Test$Dict (Tuple a b) ) { runTest: \(v: Tuple a b) -> } + case (v: Tuple a b) of + (Tuple a b) -> + ((mappend: String -> String -> String) + (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest: Test$Dict a)) (a: a))) + (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest1: Test$Dict b)) (b: b)) + + ``` + + We also use this in the branch of the `App` case of `exprToCoreFn` that handles dictionary applications + (in the same manner and for the same purpose). + +-} + +-- Given a type (which we expect to be a TyCon applied to type args), +-- extract (TyCon,[Args]) (returning Nothing if the input type is not a TyCon) +analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType]) +analyzeCtor t = (,ctorArgs t) <$> ctorFun t + -- Extract all of the arguments to a type constructor ctorArgs :: SourceType -> [SourceType] ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2] @@ -84,9 +185,20 @@ ctorFun (TypeApp _ t1 _) = go t1 go other = Just other ctorFun _ = Nothing -analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType]) -analyzeCtor t = (,ctorArgs t) <$> ctorFun t +{- Instantiation machinery. This differs from `instantiatePolyType` and + `withInstantiatedFunType` in that those functions are used to "peek under" + the quantifier in a universally quantified type (i.e. those functions + *put the quantifier back* after temporarily instantiating the quantified variables + *to type variables* for the purposes of type reconstruction). + + This instantiates a quantified type (the first arg) and *does not* replace the + quantifier. This is primarily used when we encounter an expression with a universally + quantified type (either as an annotation in a AST.TypedValue or as the result of looking up + the type in the typechecking environment) in a context where we know (from our top-down approach) + that the instantiated type must be instantiated to something "concrete" (where, again, + a "concrete" type can either be an explicit type or a tyvar from the outer scope). +-} instantiate :: SourceType -> [SourceType] -> SourceType instantiate ty [] = ty instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts @@ -102,7 +214,12 @@ traverseLit f = \case ArrayLiteral xs -> ArrayLiteral <$> traverse f xs ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs --- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) +{- `exprtoCoreFn` takes a `Maybe SourceType` argument. While in principle we should never need to infer the type + using PS type inference machinery (we should always be able to reconstruct it w/ recursive applications of + `exprToCoreFn` on the components), I have to get around to rewriting the corefn desugaring code to avoid this. + + Should be DEPRECATED eventually. +-} inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType inferType (Just t) _ = pure t inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> @@ -240,9 +357,76 @@ wrapTrace msg act = do endMsg = pad $ "END " <> msg - --- NOTE: Grotesqely inefficient, but since the scope can change I'm not sure what else we can do. --- If this ends up matters, we have to rework the environment somehow +{- + This is used to solve a problem that arises with re-exported instances. + + We diverge from PureScript by "desugaring" constrained types to types that contain + explicit type class dictionaries. (We have to do this for PIR conversion - we have to type + all nodes of the AST.) + + During PureScript's initial desugaring phase, type class declarations, instance declarations, and + expressions that contain type class constaints are transformed into generated value declarations. For example: + + ``` + class Eq a where + eq a :: a -> a -> Bool + + f :: forall a. Eq a => a -> a -> Boolean + f x y = eq x y + ``` + + Is transformed into (something like, I'm ommitting the full generated code for brevity): + + ``` + Eq$Dict :: forall a. {eq :: a -> a -> Boolean } -> {eq :: a -> a -> Boolean} + Eq$Dict x = x + + eq :: forall a. Eq$Dict a -> a -> a -> Boolean + eq = \dict -> case dict of + (v :: {eq :: a -> a -> Boolean}) -> v.eq + + f :: forall a. Eq a => a -> a -> Boolean + f = \dict x y -> (eq dict) x y + ``` + + Three important things to note here: + - PureScript does *not* transform constrained types into types that contain explicit dictionaries, + even though the expressions are desugared to contain those dictionaries. (We do this ourselves + after the PS typechecking phase) + - Generated declarations for type classes and instances are not (and cannot be) exported, + because typeclass desugaring takes place *after* import/export resolution + in their desugaring pipeline. (This would be difficult to fix, each step of the desugaring pipeline + expects input that conforms to the output of the previous step). + - Generated code relating to typeclass dictionaries is ignored by the PureScript typechecker. + Ordinarily, we can rely on the typechecker to insert the type annotation for most + expressions, but we cannot do so here. + + These factors give rise to a problem: Our desugared constraint types (where we transform + type annotations of the form `C a => (..)` into `C$Dict a -> (...)`) no longer contain constraints, + and therefore we cannot use the constraint solving machinery directly to infer the types of + identifiers that refer to type class dictionaries. Because generated type class code cannot be exported + by the user in the source (and would not ordinarily be implicitly re-exported even if it could be exported), + we cannot rely upon normal import resolution to provide the types corresponding to dictionary identifiers. + + This solves the problem. Because we use the same state/module scope as the PS typechecker, we + have access to all of the type class dictionaries (including their identifiers) that are in scope. + When we encounter an identifier that cannot be assigned a type by the normal type lookup process, + we extract a map from identifiers to source types, and lookup the identifier in the map, allowing us to + resolve the types of dictionary expressions. + + These identifiers are always qualified by module in the AST, so cannot clash with local definitions, which + are qualified by SourcePos. + + NOTE: In theory (at least), this component of the type checker environment can change if we + make any calls to `infer` or any of the type checking functions in the + TypeChecker.X namespace. So for now, we rebuild this map every time we fail to + lookup the type for an identifier in the normal way. (Which is grossly + inefficient) + + In principle, we should be able to totally reconstruct the types w/o making + any calls to `infer` or the typechecker machinery. Once that is done, we can + construct this map only once for each module, which will greatly improve performance. +-} lookupDictType :: M m => Qualified Ident -> m (Maybe SourceType) lookupDictType nm = do tyClassDicts <- typeClassDictionaries <$> getEnv From 1e178045aae683aa45b01be0ff14982f7713c100 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 29 Feb 2024 21:05:31 -0500 Subject: [PATCH 30/44] Type inference/checking machinery removed from CoreFn desugaring machinery. (We're now properly *reconstructing* the types) --- src/Language/PureScript/CoreFn/Desugar.hs | 210 ++++++++++-------- .../PureScript/CoreFn/Desugar/Utils.hs | 45 ++-- src/Language/PureScript/CoreFn/Pretty.hs | 2 +- src/Language/PureScript/Environment.hs | 4 +- 4 files changed, 135 insertions(+), 126 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 27259b84..2da586de 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -6,7 +6,7 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap)) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M @@ -59,13 +59,7 @@ import Language.PureScript.Constants.Prim qualified as C import Control.Monad.State.Strict (MonadState, gets, modify) import Control.Monad.Writer.Class ( MonadWriter ) import Language.PureScript.TypeChecker.Kinds ( kindOf ) -import Language.PureScript.TypeChecker.Types - ( checkTypeKind, - SplitBindingGroup(SplitBindingGroup), - TypedValue'(TypedValue'), - typeDictionaryForBindingGroup ) import Data.List.NonEmpty qualified as NE -import Language.PureScript.TypeChecker.Unify (unifyTypes) import Control.Monad (forM, (>=>), foldM) import Language.PureScript.Errors ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) @@ -92,7 +86,6 @@ import Language.PureScript.CoreFn.Desugar.Utils getModuleName, getValueMeta, importToCoreFn, - inferType, printEnv, properToIdent, purusTy, @@ -100,7 +93,6 @@ import Language.PureScript.CoreFn.Desugar.Utils showIdent', ssA, toReExportRef, - traverseLit, wrapTrace, desugarConstraintTypes, M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs, instantiatePolyType, lookupDictType @@ -108,6 +100,7 @@ import Language.PureScript.CoreFn.Desugar.Utils import Text.Pretty.Simple (pShow) import Data.Text.Lazy qualified as LT import Data.Set qualified as S +import Data.Either (lefts) {- CONVERSION MACHINERY @@ -224,9 +217,18 @@ declToCoreFn _ _ = pure [] -- Desugars expressions from AST to typed CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) +-- Array & Object literals can contain non-literal expressions. Both of these types should always be tagged +-- (i.e. returned as an AST.TypedValue) after the initial typechecking phase, so we expect the type to be passed in exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do + traceM $ ppType 100 arrT arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts pure $ Literal (ss,[],Nothing) arrT arr +-- An empty list could either have a TyVar or a quantified type (or a concrete type, which is handled by the previous case) +exprToCoreFn mn ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do + pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral []) +exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ArrayLiteral _)) = + internalError $ "Error while desugaring Array Literal. No type provided for literal:\n" <> renderValue 100 astlit + exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do traceM $ "ObjLitTy: " <> show row let (tyFields,_) = rowToList row @@ -241,28 +243,37 @@ exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral expr' <- exprToCoreFn mn ss (Just fieldTy) expr pure $ (lbl,expr'):acc Nothing -> error $ "row type missing field " <> T.unpack (prettyPrintString lbl) --- Literal case is straightforward -exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do - litT <- purusTy <$> inferType mTy astLit - traceM $ "LIT TY: " <> ppType 1000 litT - lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit - pure $ Literal (ss, [], Nothing) litT lit' --- Accessor case is straightforward -exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do - expT <- purusTy <$> inferType mTy accessor - expr <- exprToCoreFn mn ss Nothing v - pure $ Accessor (ssA ss) expT name expr --- Object update is straightforward (this is basically a monadic wrapper around the old non-typed exprToCoreFn) -exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do - expT <- purusTy <$> inferType mTy objUpd +exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ObjectLiteral _)) = + internalError $ "Error while desugaring Object Literal. No type provided for literal:\n" <> renderValue 100 astlit + +-- Literals that aren't objects or arrays have deterministic types +exprToCoreFn _ _ _ (A.Literal ss (NumericLiteral (Left int))) = + pure $ Literal (ss,[],Nothing) tyInt (NumericLiteral (Left int)) +exprToCoreFn _ _ _ (A.Literal ss (NumericLiteral (Right number))) = + pure $ Literal (ss,[],Nothing) tyNumber (NumericLiteral (Right number)) +exprToCoreFn _ _ _ (A.Literal ss (CharLiteral char)) = + pure $ Literal (ss,[],Nothing) tyChar (CharLiteral char) +exprToCoreFn _ _ _ (A.Literal ss (BooleanLiteral boolean)) = + pure $ Literal (ss,[],Nothing) tyBoolean (BooleanLiteral boolean) +exprToCoreFn _ _ _ (A.Literal ss (StringLiteral string)) = + pure $ Literal (ss,[],Nothing) tyString (StringLiteral string) + +-- Accessor case is straightforward (these should always be typed explicitly) +exprToCoreFn mn ss (Just accT) accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do + v' <- exprToCoreFn mn ss Nothing v -- v should always have a type assigned during typechecking (i.e. it will be a TypedValue that will be unwrapped) + pure $ Accessor (ssA ss) accT name v' +exprToCoreFn _ _ Nothing accessor@(A.Accessor _ _) = + internalError $ "Error while desugaring record accessor. No type provided for expression: \n" <> renderValue 100 accessor + +exprToCoreFn mn ss (Just recT) objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do obj' <- exprToCoreFn mn ss Nothing obj vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs pure $ ObjectUpdate (ssA ss) - expT + recT obj' - (mTy >>= unchangedRecordFields (fmap fst vs)) + (unchangedRecordFields (fmap fst vs) recT) vs' where -- TODO: Optimize/Refactor Using Data.Set @@ -276,20 +287,30 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r collect _ = Nothing unchangedRecordFields _ _ = Nothing +exprToCoreFn _ _ Nothing objUpd@(A.ObjectUpdate _ _) = + internalError $ "Error while desugaring object update. No type provided for expression:\n" <> renderValue 100 objUpd + -- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here. exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ withInstantiatedFunType mn t $ \a b -> do body <- bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v pure $ Abs (ssA ssb) (function a b) name body - -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> renderValue 100 lam <> "\n\n" <> show (ppType 100 <$> t) --- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. --- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType --- TODO: Investigate whether still necessary --- FIXME: Something's off here, see output for 4310 + +{- The App case is substantially complicated by our need to correctly type + expressions that contain type class dictionary constructors, specifically expressions like: + + ``` + (C$Dict :: forall x. {method :: x -> (...)}) -> {method :: x -> (..)}) ({method: f}) + ```` + + Because the dictionary ctor and record of methods it is being applied to + are untouched by the PS typechecker, we have to instantiate the + quantified variables to conform with the supplied type. +-} exprToCoreFn mn ss mTy app@(A.App fun arg) | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do traceM $ "APP Dict type" <> show (ppType 100 <$> mTy) @@ -300,6 +321,7 @@ exprToCoreFn mn ss mTy app@(A.App fun arg) case mTy of Just iTy -> case analyzed of + -- Branch for a "normal" (i.e. non-empty) typeclass dictionary application Just (TypeConstructor _ (Qualified qb nm), args) -> do traceM $ "APP Dict name: " <> T.unpack (runProperName nm) env <- getEnv @@ -315,42 +337,29 @@ exprToCoreFn mn ss mTy app@(A.App fun arg) pure $ App (ss,[],Nothing) iTy fun' arg' _ -> error "dict ctor has to have a function type" _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ Qualified qb (coerceProperName nm) + -- This should actually be impossible here, so long as we desugared all the constrained types properly Just (other,_) -> error $ "APP Dict not a constructor type (impossible here?): \n" <> ppType 100 other + -- Case for handling empty dictionaries (with no methods) Nothing -> do - -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds - -- in the output + -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds in the output + -- REVIEW: We might want to match more specifically on both/either the expression and type level to + -- ensure that we are working only with empty dictionaries here. (Though anything else should be caught be the previous case) let (inner,g,act) = instantiatePolyType mn iTy act (exprToCoreFn mn ss (Just inner) app) >>= \case App ann' _ e1 e2 -> pure . g $ App ann' iTy e1 e2 - other -> error "An application desguared to something else. This should not be possible." + _ -> error "An application desguared to something else. This should not be possible." Nothing -> error $ "APP Dict w/o type passed in (impossible to infer):\n" <> renderValue 100 app - - -- type should be something like: Test$Dict (Tuple a b) - -- lookup the type of the Dict ctor (should have one quantified record arg), i.e. - -- forall a. { runTest :: a -> String } -> { runTest :: a -> String } - -- instantiate the args, giving something like: - -- {runTest :: Tuple a b -> String} - | otherwise = wrapTrace "exprToCoreFn APP" $ do traceM $ renderValue 100 app - case mTy of - Just appT -> do - fun' <- exprToCoreFn mn ss Nothing fun - let funTy = exprType fun' - traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' - withInstantiatedFunType mn funTy $ \a b -> do - arg' <- exprToCoreFn mn ss (Just a) arg - traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' - pure $ App (ss, [], Nothing) appT fun' arg' - Nothing -> do - fun' <- exprToCoreFn mn ss Nothing fun - let funTy = exprType fun' - traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' - withInstantiatedFunType mn funTy $ \a b -> do - arg' <- exprToCoreFn mn ss (Just a) arg - traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' - pure $ App (ss, [], Nothing) b fun' arg' + fun' <- exprToCoreFn mn ss Nothing fun + let funTy = exprType fun' + traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' + withInstantiatedFunType mn funTy $ \a b -> do + arg' <- exprToCoreFn mn ss (Just a) arg + traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' + pure $ App (ss, [], Nothing) (fromMaybe b mTy) fun' arg' + where isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name @@ -371,47 +380,60 @@ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ide traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) error "boom" -- If-Then-Else Turns into a case expression -exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do - -- NOTE/TODO: Don't need to call infer separately here - ifteTy <- inferType mTy ifte +exprToCoreFn mn ss (Just resT) (A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do condE <- exprToCoreFn mn ss (Just tyBoolean) cond - thE <- exprToCoreFn mn ss Nothing th - elE <- exprToCoreFn mn ss Nothing el - pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] + thE <- exprToCoreFn mn ss (Just resT) th + elE <- exprToCoreFn mn ss (Just resT) el + pure $ Case (ss, [], Nothing) resT [condE] [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] (Right thE) , CaseAlternative [NullBinder (ssAnn ss)] (Right elE) ] +exprToCoreFn _ _ Nothing ifte@(A.IfThenElse _ _ _) = + internalError $ "Error while desugaring If-then-else expression. No type provided for:\n " <> renderValue 100 ifte + -- Constructor case is straightforward, we should already have all of the type info -exprToCoreFn _ _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do - env <- gets checkEnv - let ctorMeta = getConstructorMeta env name - ctorType <- inferType mTy ctor - pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name +exprToCoreFn _ _ (Just ctorTy) (A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do + ctorMeta <- flip getConstructorMeta name <$> getEnv + pure $ Var (ss, [], Just ctorMeta) (purusTy ctorTy) $ fmap properToIdent name +exprToCoreFn _ _ Nothing ctor@(A.Constructor _ _) = + internalError $ "Error while desugaring Constructor expression. No type provided for:\n" <> renderValue 100 ctor + -- Case expressions -exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do +exprToCoreFn mn ss (Just caseTy) astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do traceM $ "CASE:\n" <> renderValue 100 astCase - traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy) - caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. + traceM $ "CASE TY:\n" <> show (ppType 100 caseTy) (vs',ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\ e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees* alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s) pure $ Case (ssA ss) (purusTy caseTy) vs' alts' +exprToCoreFn _ _ Nothing astCase@(A.Case _ _) = + internalError $ "Error while desugaring Case expression. No type provided for:\n" <> renderValue 100 astCase -- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct. exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $ exprToCoreFn mn ss (Just ty) v +-- If we encounter a TypedValue w/o a supplied type, we use the annotated type exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $ exprToCoreFn mn ss (Just ty) v --- Let bindings. Complicated. + +-- Complicated. See `transformLetBindings` exprToCoreFn mn ss _ (A.Let w ds v) = wrapTrace "exprToCoreFn LET" $ case NE.nonEmpty ds of Nothing -> error "declarations in a let binding can't be empty" Just _ -> do - (decls,expr) <- transformLetBindings mn ss [] ds v -- see transformLetBindings + (decls,expr) <- transformLetBindings mn ss [] ds v pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr + +-- Pretty sure we should prefer the positioned SourceSpan exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ exprToCoreFn mn ss ty v -exprToCoreFn _ _ _ e = - error $ "Unexpected value in exprToCoreFn mn: " ++ show e +-- Function should never reach this case, but there are a lot of AST Expressions that shouldn't ever appear here, so +-- we use a catchall case. +exprToCoreFn _ ss _ e = + internalError + $ "Unexpected value in exprToCoreFn:\n" + <> renderValue 100 e + <> "at position:\n" + <> show ss -- Desugars case alternatives from AST to CoreFn representation. altToCoreFn :: forall m @@ -467,9 +489,7 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret --- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context -transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do - -- ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} +transformLetBindings mn _ss seen (A.ValueDecl (ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do e <- exprToCoreFn mn ss Nothing val let ty = exprType e if not (containsUnknowns ty) -- TODO: Don't need this anymore (shouldn't ever contain unknowns) @@ -486,19 +506,27 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU <> "\nIf the identifier occurs in a compiler-generated `let-binding` with guards (e.g. in a guarded case branch), try removing the guarded expression (e.g. use a normal if-then expression)" -- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds - if null untyped - then do - let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + -- All of the types in the binding group should be TypedValues (after my modifications to the typechecker) + -- NOTE: We re-implement part of TypeChecker.Types.typeDictionaryForBindingGroup here because it *could* try to do + -- type checking/inference, which we want to avoid (because it mangles our types) + let types = go <$> NEL.toList ((\(i, _, v) -> (i, v)) <$> ds) + case sequence types of + Right typed -> do + let ds' = flip map typed $ \((sann,iden),(expr,ty)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + dict = M.fromList $ flip map typed $ \(((ss,_),ident),(_,ty)) -> (Qualified (BySourcePos $ spanStart ss) ident, (ty, Private, Undefined)) bindNames dict $ do makeBindingGroupVisible thisDecl <- concat <$> traverse (declToCoreFn mn) ds' let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope. - else error + Left _ -> error $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" - <> LT.unpack (pShow untyped) + <> LT.unpack (pShow $ lefts types) + where + go :: ((SourceAnn, Ident), A.Expr) -> Either ((SourceAnn,Ident), A.Expr) ((SourceAnn, Ident), (A.Expr, SourceType)) + go (annName,A.TypedValue _ expr ty) = Right (annName,(expr,ty)) + go (annName,other) = Left (annName,other) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" @@ -511,11 +539,11 @@ inferBinder' -> A.Binder -> m (M.Map Ident (SourceSpan, SourceType)) inferBinder' _ A.NullBinder = return M.empty -inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ unifyTypes val tyString >> return M.empty -inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ unifyTypes val tyChar >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ unifyTypes val tyInt >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ unifyTypes val tyNumber >> return M.empty -inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty +inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty +inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty +inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty +inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name)) $ return $ M.singleton name (ss, val) inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do traceM $ "InferBinder VAL:\n" <> ppType 100 val @@ -572,8 +600,8 @@ inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POS warnAndRethrowWithPositionTC pos $ inferBinder' val binder inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do (elabTy, kind) <- kindOf ty - checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner - unifyTypes val elabTy + -- checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner + -- unifyTypes val elabTy inferBinder' elabTy binder inferBinder' _ A.OpBinder{} = internalError "OpBinder should have been desugared before inferBinder'" diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index aa777e9c..bf0d62ce 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -4,7 +4,6 @@ module Language.PureScript.CoreFn.Desugar.Utils where import Prelude -import Prelude qualified as P import Protolude (MonadError (..), traverse_) import Data.Function (on) @@ -31,18 +30,15 @@ import Language.PureScript.Environment ( dictTypeName, TypeClassData (typeClassArguments), function, - pattern (:->), pattern (:$), isDictTypeName) + pattern (:->), + isDictTypeName) import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName) import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..), replaceTypeVars, everywhereOnTypes) -import Language.PureScript.AST.Binders qualified as A -import Language.PureScript.AST.Declarations qualified as A import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Strict (MonadState, gets, modify') import Control.Monad.Writer.Class ( MonadWriter ) import Language.PureScript.TypeChecker.Types - ( kindType, - TypedValue'(TypedValue'), - infer ) + ( kindType ) import Language.PureScript.Errors ( MultipleErrors ) import Debug.Trace (traceM, trace) @@ -55,7 +51,6 @@ import Language.PureScript.TypeChecker.Monad getEnv, withScopedTypeVars, CheckState(checkCurrentModule, checkEnv), debugNames ) -import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label(..)) import Data.Bifunctor (Bifunctor(..)) @@ -214,19 +209,6 @@ traverseLit f = \case ArrayLiteral xs -> ArrayLiteral <$> traverse f xs ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs -{- `exprtoCoreFn` takes a `Maybe SourceType` argument. While in principle we should never need to infer the type - using PS type inference machinery (we should always be able to reconstruct it w/ recursive applications of - `exprToCoreFn` on the components), I have to get around to rewriting the corefn desugaring code to avoid this. - - Should be DEPRECATED eventually. --} -inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType -inferType (Just t) _ = pure t -inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> - infer e >>= \case - TypedValue' _ _ t -> do - traceM ("TYPE: " <> ppType 100 t) - pure t -- Wrapper around instantiatePolyType to provide a better interface withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann) @@ -259,11 +241,11 @@ instantiatePolyType mn = \case -- FIXME: kindType? act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) in (inner, f . g, act') - fun@(a :-> r) -> case analyzeCtor a of + fun@(a :-> _) -> case analyzeCtor a of Just (TypeConstructor _ (Qualified _ nm), _) -> if isDictTypeName nm then - let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma + let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] ma in (fun,id,act') else (fun,id,id) _ -> (fun,id,id) @@ -289,13 +271,13 @@ traceNameTypes = do will always give us a "wrong" type. Let's try fixing them in the context! -} -desugarConstraintType' :: SourceType -> SourceType -desugarConstraintType' = \case +desugarConstraintType :: SourceType -> SourceType +desugarConstraintType = \case ForAll a vis var mbk t mSkol -> - let t' = desugarConstraintType' t + let t' = desugarConstraintType t in ForAll a vis var mbk t' mSkol ConstrainedType _ Constraint{..} t -> - let inner = desugarConstraintType' t + let inner = desugarConstraintType t dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass dictTyCon = srcTypeConstructor dictTyName dictTy = foldl srcTypeApp dictTyCon constraintArgs @@ -305,7 +287,7 @@ desugarConstraintType' = \case desugarConstraintTypes :: M m => m () desugarConstraintTypes = do env <- getEnv - let f = everywhereOnTypes desugarConstraintType' + let f = everywhereOnTypes desugarConstraintType oldNameTypes = names env desugaredNameTypes = (\(st,nk,nv) -> (f st,nk,nv)) <$> oldNameTypes @@ -330,11 +312,12 @@ desugarConstraintsInDecl :: A.Declaration -> A.Declaration desugarConstraintsInDecl = \case A.BindingGroupDeclaration decls -> A.BindingGroupDeclaration - $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType' expr)) <$> decls + $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType expr)) <$> decls A.ValueDecl ann name nk bs [A.MkUnguarded e] -> - A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType' e] + A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType e] A.DataDeclaration ann declTy tName args ctorDecs -> - let fixCtor (A.DataConstructorDeclaration a nm fields) = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType') <$> fields) + let fixCtor (A.DataConstructorDeclaration a nm fields) + = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType) <$> fields) in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs) other -> other diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 90c86c09..8c1d308c 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -84,7 +84,7 @@ prettyPrintValue d (Let _ _ ds val) = moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // (text "in " <> prettyPrintValue (d - 1) val) -- TODO: constraint kind args -prettyPrintValue d (Literal _ _ l) = prettyPrintLiteralValue d l +prettyPrintValue d (Literal _ ty l) = text "(" <> prettyPrintLiteralValue d l <> ": " <> text (oneLine (ppType 100 ty)) <> text ")" prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index df2cc914..561da8c7 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -379,9 +379,7 @@ pattern ArrayT :: Type a -> Type a pattern ArrayT a <- TypeApp _ (TypeConstructor _ C.Array) a -pattern (:$) :: Type a -> Type a -> Type a -pattern f :$ a <- - TypeApp _ f a + arrayT :: SourceType -> SourceType arrayT = TypeApp NullSourceAnn (TypeConstructor NullSourceAnn C.Array) From 161bdefa34ff719b393f9408f6da96ef679119a4 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 29 Feb 2024 21:06:06 -0500 Subject: [PATCH 31/44] Added some empty list tests --- tests/purus/passing/Misc/Lib.purs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs index 17fc3900..7f14dab3 100644 --- a/tests/purus/passing/Misc/Lib.purs +++ b/tests/purus/passing/Misc/Lib.purs @@ -168,6 +168,15 @@ polyInObjMatch = case polyInObj of aPred :: Int -> Boolean aPred _ = true +cons :: forall a. a -> Array a -> Array a +cons x xs = [x] + +emptyList = [] + +consEmptyList1 = cons 1 emptyList + +consEmptyList2 = cons "hello" emptyList + {- We should probably just remove guarded case branches, see slack msg guardedCase :: Int guardedCase = case polyInObj of From f35cdb00ab93d0238d992deed6e158a2bb6133ea Mon Sep 17 00:00:00 2001 From: gnumonik Date: Fri, 1 Mar 2024 21:06:30 -0500 Subject: [PATCH 32/44] Prettyprinter replacement implemented (still needs some tweaking) --- purescript.cabal | 4 + src/Language/PureScript/CoreFn/Desugar.hs | 6 +- src/Language/PureScript/CoreFn/Pretty.hs | 455 ++++++++++++++-------- src/Language/PureScript/Make.hs | 3 +- src/Language/PureScript/Make/Actions.hs | 8 +- 5 files changed, 309 insertions(+), 167 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index ae6ab30f..4b57b9f7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -86,6 +86,9 @@ common defaults -Wno-missing-export-lists -Wno-missing-kind-signatures -Wno-partial-fields + + -- TODO: Remove + -O0 default-language: Haskell2010 default-extensions: BangPatterns @@ -193,6 +196,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process ==1.6.13.1, pretty-simple, + prettyprinter, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 2da586de..3e357c13 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -64,7 +64,7 @@ import Control.Monad (forM, (>=>), foldM) import Language.PureScript.Errors ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) import Debug.Trace (traceM) -import Language.PureScript.CoreFn.Pretty ( ppType, renderExpr ) +import Language.PureScript.CoreFn.Pretty ( ppType, renderExprStr ) import Data.Text qualified as T import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.TypeChecker.Monad @@ -354,10 +354,10 @@ exprToCoreFn mn ss mTy app@(A.App fun arg) traceM $ renderValue 100 app fun' <- exprToCoreFn mn ss Nothing fun let funTy = exprType fun' - traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExpr 100 fun' + traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExprStr fun' withInstantiatedFunType mn funTy $ \a b -> do arg' <- exprToCoreFn mn ss (Just a) arg - traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg' + traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExprStr arg' pure $ App (ss, [], Nothing) (fromMaybe b mTy) fun' arg' where diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 8c1d308c..be20a375 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE TypeApplications, ScopedTypeVariables #-} module Language.PureScript.CoreFn.Pretty where import Prelude hiding ((<>)) -import Control.Arrow (second) + import Data.Text (Text) import Data.List.NonEmpty qualified as NEL @@ -15,19 +16,61 @@ import Language.PureScript.CoreFn.Module import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName) +import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified) import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) -import Language.PureScript.Pretty.Types ( typeAsBox, typeAtomAsBox, prettyPrintObjectKey) -import Language.PureScript.Types (Constraint(..), Type) -import Language.PureScript.PSString (PSString, prettyPrintString) +import Language.PureScript.Types (Constraint(..), Type (..), WildcardData (..), TypeVarVisibility (..), eqType) +import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement) +import System.IO (Handle) -import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, hcat, vsep, (//), (<>), render) -import Language.PureScript.Pretty.Types import Data.Map qualified as M +import Prettyprinter +import Prettyprinter.Render.Text +import qualified Prettyprinter.Render.String as STR +import Data.Bifunctor (first, Bifunctor (..)) +import Language.PureScript.Label (Label (..)) +import Control.Monad (void) + + + +withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Doc ann +withOpenRow l r (fields,open) = group $ align $ enclose (l <> softline) (softline <> r) $ hsep $ punctuate comma fields' + where + fields' = foldr (\x acc -> case acc of + [] -> [hsep [x,pipe <++> open]] + xs -> x : xs + ) [] fields + +openRow :: ([Doc ann], Doc ann) -> Doc ann +openRow = withOpenRow lparen rparen + +openRecord :: ([Doc ann], Doc ann) -> Doc ann +openRecord = withOpenRow lbrace rbrace + +recordLike :: [Doc ann] -> Doc ann +recordLike fields = + let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline) + in group $ align (fmtObj fields) + +record :: [Doc ann] -> Doc ann +record = recordLike + +object :: [Doc ann] -> Doc ann +object = recordLike + +commaSep :: [Doc ann] -> Doc ann +commaSep = vsep . punctuate comma + +indent' :: Int -> Doc ann -> Doc ann +indent' i doc = group . align $ flatAlt (indent i doc) doc + +parens' :: Doc ann -> Doc ann +parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d + + -- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack ppType :: Int -> Type a -> String -ppType i t = go [] $ prettyPrintType i t +ppType i t = "" {- go [] $ prettyPrintType i t where go :: String -> String -> String go acc [] = acc @@ -35,192 +78,284 @@ ppType i t = go [] $ prettyPrintType i t [] -> acc more -> go (acc `mappend` [' ']) more go acc (x:xs) = go (acc `mappend` [x]) xs +-} -textT :: Text -> Box -textT = text . T.unpack +instance Pretty Ident where + pretty = pretty . showIdent -oneLine :: String -> String -oneLine = filter (/= '\n') +instance Pretty PSString where + pretty = pretty . decodeStringWithReplacement --- | Render an aligned list of items separated with commas -list :: Char -> Char -> (a -> Box) -> [a] -> Box -list open close _ [] = text [open, close] -list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) - where - toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a +instance Pretty ModuleName where + pretty = pretty . runModuleName +instance Pretty Label where + pretty = pretty . runLabel -hlist :: Char -> Char -> (a -> Box) -> [a] -> Box -hlist open close _ [] = text [open, close] -hlist open close f xs = hcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) - where - toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a +ellipsis :: Doc ann +ellipsis = "..." + +(<:>) :: Doc ann -> Doc ann -> Doc ann +a <:> b = hcat [a,":"] <++> b + +(<::>) :: Doc ann -> Doc ann -> Doc ann +a <::> b = a <++> "::" <++> b + +(<=>) :: Doc ann -> Doc ann -> Doc ann +a <=> b = a <+> "=" <+> b + +() :: Doc ann -> Doc ann -> Doc ann +a b = a <+> line <+> b + +-- ensures the things being concatenated are always on the same line +(<++>) :: Doc ann -> Doc ann -> Doc ann +a <++> b = hsep [a,b] +arrow :: Doc ann +arrow = "->" -ellipsis :: Box -ellipsis = text "..." +lam :: Doc ann +lam = "\\" -prettyPrintObject :: Int -> [(PSString, Maybe (Expr a))] -> Box -prettyPrintObject d = hlist '{' '}' prettyPrintObjectProperty +doubleColon :: Doc ann +doubleColon = hcat [colon,colon] + +caseOf :: [Doc ann] -> [Doc ann] -> Doc ann +caseOf scrutinees branches = "case" <+> group (hsep scrutinees) <+> "of" indent 2 (vcat . map group $ branches) -- if wrong try hang instead of hang + +prettyPrintObjectKey :: PSString -> Doc ann +prettyPrintObjectKey = pretty . decodeStringWithReplacement + +prettyPrintObject :: [(PSString, Maybe (Expr a))] -> Doc ann +prettyPrintObject = encloseSep "{" "}" "," . map prettyPrintObjectProperty where - prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Box - prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value + prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Doc ann + prettyPrintObjectProperty (key, value) = (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (pretty @Text "_") prettyPrintValue value -prettyPrintUpdateEntry :: Int -> PSString -> Expr a -> Box -prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val +prettyPrintUpdateEntry :: PSString -> Expr a -> Doc ann +prettyPrintUpdateEntry key val = prettyPrintObjectKey key <+> "=" <+> prettyPrintValue val -- | Pretty-print an expression -prettyPrintValue :: Int -> Expr a -> Box --- prettyPrintValue d _ | d < 0 = text "..." -prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps -prettyPrintValue d (App ann ty val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") // (prettyPrintValue (d-1) val) -prettyPrintValue d (Case ann ty values binders) = - (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // - moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) -prettyPrintValue d (Let _ _ ds val) = - text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // - (text "in " <> prettyPrintValue (d - 1) val) --- TODO: constraint kind args -prettyPrintValue d (Literal _ ty l) = text "(" <> prettyPrintLiteralValue d l <> ": " <> text (oneLine (ppType 100 ty)) <> text ")" -prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr +prettyPrintValue :: Expr a -> Doc ann +-- prettyPrintValue _ | d < 0 = text "..." +prettyPrintValue (Accessor _ ty prop val) = group . align $ vcat [prettyPrintValueAtom val,hcat[dot,prettyPrintObjectKey prop]] +prettyPrintValue (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom o <+> encloseSep "{" "}" "," (uncurry prettyPrintUpdateEntry <$> ps) +prettyPrintValue (App ann ty val arg) = group . align $ vsep [prettyPrintValueAtom val,prettyPrintValueAtom arg] +prettyPrintValue (Abs ann ty arg val) = group . align $ flatAlt multiLine oneLine + where + multiLine = lam + <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty)) + <+> arrow + <> hardline + <> hang 2 (prettyPrintValue val) + + oneLine = lam + <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty)) + <+> arrow + <+> prettyPrintValue val + +prettyPrintValue (Case ann ty values binders) = + caseOf (prettyPrintValueAtom <$> values) (prettyPrintCaseAlternative <$> binders) +prettyPrintValue (Let _ _ ds val) = mappend line $ indent 2 $ vcat [ + "let", + indent 2 $ vcat $ prettyPrintDeclaration <$> ds, + "in" <+> align (prettyPrintValue val) + ] + +prettyPrintValue (Literal _ ty l) = parens $ prettyPrintLiteralValue l <:> prettyType ty +prettyPrintValue expr@Constructor{} = prettyPrintValueAtom expr +prettyPrintValue expr@Var{} = prettyPrintValueAtom expr -- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Int -> Expr a -> Box -prettyPrintValueAtom d (Literal _ _ l) = prettyPrintLiteralValue d l -prettyPrintValueAtom _ (Constructor _ _ _ name _) = text $ T.unpack $ runProperName name -prettyPrintValueAtom d (Var ann ty ident) = text . oneLine $ "(" ++ T.unpack (showIdent (disqualify ident)) ++ ": " ++ ppType d ty ++ ")" -prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" - -prettyPrintLiteralValue :: Int -> Literal (Expr a) -> Box -prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n -prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s -prettyPrintLiteralValue _ (CharLiteral c) = text $ show c -prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" -prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" -prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs -prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps - -prettyPrintDeclaration :: Int -> Bind a -> Box +prettyPrintValueAtom :: Expr a -> Doc ann +prettyPrintValueAtom (Literal _ _ l) = prettyPrintLiteralValue l +prettyPrintValueAtom (Constructor _ _ _ name _) = pretty $ T.unpack $ runProperName name +prettyPrintValueAtom (Var ann ty ident) = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty +prettyPrintValueAtom expr = (prettyPrintValue expr) + +prettyPrintLiteralValue :: Literal (Expr a) -> Doc ann +prettyPrintLiteralValue (NumericLiteral n) = pretty $ either show show n +prettyPrintLiteralValue (StringLiteral s) = pretty . T.unpack $ prettyPrintString s +prettyPrintLiteralValue (CharLiteral c) = viaShow . show $ c +prettyPrintLiteralValue (BooleanLiteral True) = "true" +prettyPrintLiteralValue (BooleanLiteral False) = "false" +prettyPrintLiteralValue (ArrayLiteral xs) = list $ prettyPrintValue <$> xs +prettyPrintLiteralValue (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps + +prettyPrintDeclaration :: Bind a -> Doc ann -- prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration d b = case b of - NonRec _ ident expr -> - vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here - +prettyPrintDeclaration b = case b of + NonRec _ ident expr -> vcat [ + pretty ident <::> prettyType (exprType expr), + pretty ident <=> prettyPrintValue expr -- not sure about the d here ] - Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> - vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr - + Rec bindings -> vcat $ concatMap (\((_,ident),expr) -> [ + pretty ident <::> prettyType (exprType expr), + pretty ident <=> prettyPrintValue expr ]) bindings -prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box +prettyPrintCaseAlternative :: forall a ann. CaseAlternative a -> Doc ann -- prettyPrintCaseAlternative d _ | d < 0 = ellipsis -prettyPrintCaseAlternative d (CaseAlternative binders result) = - text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result +prettyPrintCaseAlternative (CaseAlternative binders result) = + hsep (map prettyPrintBinderAtom binders) <> prettyPrintResult result where - prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Box + prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann prettyPrintResult = \case - Left ges -> vcat left $ map (prettyPrintGuardedValueSep' (text " | ")) ges - Right exp -> text " -> " <> prettyPrintValue (d-1) exp + Left ges -> vcat $ map prettyPrintGuardedValueSep' ges + Right exp' -> space <> arrow <+> prettyPrintValue exp' - prettyPrintGuardedValueSep' :: Box -> (Guard a, Expr a) -> Box - prettyPrintGuardedValueSep' sep (guardE, resultE) = - prettyPrintValue (d-1) guardE <> text " -> " <> prettyPrintValue (d-1) resultE + prettyPrintGuardedValueSep' :: (Guard a, Expr a) -> Doc ann + prettyPrintGuardedValueSep' (guardE, resultE) = + " | " <> prettyPrintValue guardE <+> arrow <+> prettyPrintValue resultE -prettyPrintModule :: Module a -> Box +prettyPrintModule :: Module a -> Doc ann prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = - vcat left $ - [text (show modName ++ " (" ++ modPath ++ ")")] - ++ ["Imported Modules: "] - ++ map (moveRight 2 . text . show . snd) modImports - ++ ["Exports: "] - ++ map (moveRight 2 . text . T.unpack . showIdent) modExports - ++ ["Re-Exports: "] - ++ map (moveRight 2 . goReExport) (M.toList modReExports) - ++ ["Foreign: "] - ++ map (moveRight 2. text . T.unpack . showIdent) modForeign - ++ ["Declarations: "] - ++ map (prettyPrintDeclaration 0) modDecls - where - goReExport :: (ModuleName,[Ident]) -> Box - goReExport (mn,idents) = vcat left $ flip map idents $ \i -> text (show mn ++ "." ++ T.unpack (showIdent i)) - -prettyPrintModule' :: Module a -> String -prettyPrintModule' = render . prettyPrintModule - -renderExpr :: Int -> Expr a -> String -renderExpr i e = render $ prettyPrintValue i e -{- - prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v - prettyPrintResult gs = - vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) - - prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box - prettyPrintGuardedValueSep _ (GuardedExpr [] val) = - text " -> " <> prettyPrintValue (d - 1) val - - prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = - foldl1 before [ sep - , prettyPrintGuard guard - , prettyPrintGuardedValueSep sep (GuardedExpr [] val) - ] - - prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = - vcat left [ foldl1 before - [ sep - , prettyPrintGuard guard - ] - , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) - ] - - prettyPrintGuard (ConditionGuard cond) = - prettyPrintValue (d - 1) cond - prettyPrintGuard (PatternGuard binder val) = - foldl1 before - [ text (T.unpack (prettyPrintBinder binder)) - , text " <- " - , prettyPrintValue (d - 1) val + vsep $ + [ pretty modName <+> parens (pretty modPath) + , "Imported Modules: " + , indent 2 . commaSep $ pretty . snd <$> modImports + ,"Exports: " + , indent 2 . commaSep $ pretty <$> modExports -- hang 2? + , "Re-Exports: " + , indent 2 . commaSep $ goReExport <$> M.toList modReExports + , "Foreign: " + , indent 2 . commaSep . map pretty $ modForeign + , "Declarations: " + , vcat . punctuate line $ prettyPrintDeclaration <$> modDecls ] --} + where + goReExport :: (ModuleName,[Ident]) -> Doc ann + goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i + +smartRender :: Doc ann -> Text +smartRender = renderStrict . layoutPretty defaultLayoutOptions + +writeModule :: Handle -> Module a -> IO () +writeModule h m = renderIO h + . layoutSmart defaultLayoutOptions + $ prettyPrintModule m + +prettyPrintModuleTxt :: Module a -> Text +prettyPrintModuleTxt = renderStrict . layoutPretty defaultLayoutOptions . prettyPrintModule + +prettyPrintModuleStr :: Module a -> String +prettyPrintModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyPrintModule + +renderExpr :: Expr a -> Text +renderExpr = smartRender . prettyPrintValue + +renderExprStr :: Expr a -> String +renderExprStr = T.unpack . renderExpr -prettyPrintBinderAtom :: Binder a -> Text +prettyTypeStr :: forall a. Show a => Type a -> String +prettyTypeStr = T.unpack . smartRender . prettyType + +prettyPrintBinderAtom :: Binder a -> Doc ann prettyPrintBinderAtom (NullBinder _) = "_" prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l -prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident -prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) -prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder - -prettyPrintLiteralBinder :: Literal (Binder a) -> Text -prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str -prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) -prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num +prettyPrintBinderAtom (VarBinder _ ident) = pretty ident +prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor) +prettyPrintBinderAtom b@ConstructorBinder{} = prettyPrintBinder b +prettyPrintBinderAtom (NamedBinder _ ident binder) = pretty ident <> "@" <> prettyPrintBinder binder + +prettyPrintLiteralBinder :: Literal (Binder a) -> Doc ann +prettyPrintLiteralBinder (StringLiteral str) = pretty $ prettyPrintString str +prettyPrintLiteralBinder (CharLiteral c) = viaShow c +prettyPrintLiteralBinder (NumericLiteral num) = either pretty pretty num prettyPrintLiteralBinder (BooleanLiteral True) = "true" prettyPrintLiteralBinder (BooleanLiteral False) = "false" -prettyPrintLiteralBinder (ObjectLiteral bs) = - "{ " - Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) - Monoid.<> " }" +prettyPrintLiteralBinder (ObjectLiteral bs) = object $ prettyPrintObjectPropertyBinder <$> bs where - prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Text - prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder -prettyPrintLiteralBinder (ArrayLiteral bs) = - "[ " - Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) - Monoid.<> " ]" + prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Doc ann + prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key <:> prettyPrintBinder binder +prettyPrintLiteralBinder (ArrayLiteral bs) = list (prettyPrintBinder <$> bs) -- | -- Generate a pretty-printed string representing a Binder -- -prettyPrintBinder :: Binder a -> Text -prettyPrintBinder (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder _ _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) +prettyPrintBinder :: Binder a -> Doc ann +prettyPrintBinder (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor) +prettyPrintBinder (ConstructorBinder _ _ ctor args) = + pretty (runProperName (disqualify ctor)) <+> hcat (prettyPrintBinderAtom <$> args) prettyPrintBinder b = prettyPrintBinderAtom b + + +{- TYPES (move later) -} + +prettyType :: forall a ann. Show a => Type a -> Doc ann +prettyType t= group $ case t of + TUnknown _ n -> "t" <> pretty n + + TypeVar _ txt -> pretty txt + + TypeLevelString _ pss -> pretty . prettyPrintString $ pss + + TypeLevelInt _ i -> pretty i + + TypeWildcard _ wcd -> case wcd of + HoleWildcard txt -> "?" <> pretty txt + _ -> "_" + + TypeConstructor _ qPropName -> pretty . runProperName . disqualify $ qPropName + + TypeOp a opName -> pretty $ showQualified runOpName opName + + TypeApp _ t1 t2 -> goTypeApp t1 t2 + + KindApp a k1 k2 -> prettyType k1 <> ("@" <> prettyType k2) + + ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of + (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner + + ConstrainedType _ constraint inner -> error "TODO: ConstrainedType" + + Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem" + + REmpty _ -> "{}" + + rcons@RCons{} -> either openRow tupled $ rowFields rcons + + -- this might be backwards + KindedType a ty kind -> parens $ prettyType ty <::> prettyType kind + + -- not sure what this is? + BinaryNoParensType a op l r -> prettyType l <++> prettyType op <++> prettyType r + + ParensInType _ ty -> parens (prettyType ty) + where + goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann + goForall xs inner = "forall" <++> hcat (renderBoundVar <$> xs) <> "." <++> prettyType inner + + prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann + prefixVis vis tv = case vis of + TypeVarVisible -> hcat ["@",tv] + TypeVarInvisible -> tv + + renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann + renderBoundVar (vis,var,mk) = case mk of + Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k + Nothing -> prefixVis vis (pretty var) + + stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a) + stripQuantifiers = \case + ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner + other -> ([],other) + + goTypeApp :: Type a -> Type a -> Doc ann + goTypeApp (TypeApp _ f a) b + | eqType f tyFunction = prettyType a <++> arrow <++> prettyType b + | otherwise = parens $ goTypeApp f a <++> prettyType b + goTypeApp o ty@RCons{} + | eqType o tyRecord = either openRecord record $ rowFields ty + goTypeApp a b = prettyType a <++> prettyType b + + rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann] + rowFields = \case + RCons _ lbl ty rest -> + let f = ((pretty lbl <::> prettyType ty):) + in bimap (first f) f $ rowFields rest + REmpty _ -> Right [] + KindApp _ REmpty{} _ -> Right [] -- REmpty is sometimes wrapped in a kind app? + TypeVar _ txt -> Left ([],pretty txt) + other -> error $ "Malformed row fields: \n" <> show other diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index dec70c72..6c778887 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -52,6 +52,7 @@ import Language.PureScript.CoreFn qualified as CFT import Language.PureScript.CoreFn.Pretty qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +import Prettyprinter.Util (putDocW) -- Temporary import Debug.Trace (traceM) @@ -123,7 +124,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- pTrace exps ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env') - traceM $ CFT.prettyPrintModule' coreFn + traceM . T.unpack $ CFT.prettyPrintModuleTxt coreFn let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index a1e13c32..512fea59 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -58,9 +58,10 @@ import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..)) import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix -import System.IO (stderr) +import System.IO (stderr, withFile, IOMode(WriteMode)) import Language.PureScript.CoreFn.ToJSON (moduleToJSON) -import Language.PureScript.CoreFn.Pretty (prettyPrintModule') +import Language.PureScript.CoreFn.Pretty (writeModule, prettyPrintModule) + -- | Determines when to rebuild a module data RebuildPolicy @@ -266,7 +267,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when (S.member CoreFn codegenTargets) $ do let targetFile = (targetFilename mn CoreFn) lift $ writeJSONFile targetFile (moduleToJSON (makeVersion [0,0,1]) m) - lift $ makeIO "write pretty core" $ writeFile (targetFile <> ".pretty") (prettyPrintModule' m) + lift $ makeIO "write pretty core" $ withFile (targetFile <> ".pretty") WriteMode $ \handle -> + writeModule handle m when (S.member CheckCoreFn codegenTargets) $ do let mn' = T.unpack (runModuleName mn) mabOldModule <- lift $ readJSONFile (targetFilename mn CoreFn) From b4f557e19fb1052bee06b2bcacb428f32c916b20 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Sat, 2 Mar 2024 01:16:46 -0500 Subject: [PATCH 33/44] prettyprinter improvements --- src/Language/PureScript/CoreFn/Pretty.hs | 341 ++++++++++++++--------- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 2 +- 3 files changed, 209 insertions(+), 136 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index be20a375..b1b2ebe7 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications, ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-} module Language.PureScript.CoreFn.Pretty where import Prelude hiding ((<>)) @@ -31,31 +31,84 @@ import Data.Bifunctor (first, Bifunctor (..)) import Language.PureScript.Label (Label (..)) import Control.Monad (void) +data LineFormat + = OneLine -- *DEFINITELY* Print on one line, even if doing so exceeds the page width + | MultiLine -- *Possibly* Print multiple lines. + deriving (Show, Eq) +-- TODO: Refactor to reader monad? +type Printer ann = LineFormat -> Doc ann -withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Doc ann -withOpenRow l r (fields,open) = group $ align $ enclose (l <> softline) (softline <> r) $ hsep $ punctuate comma fields' +type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann + +runPrinter :: LineFormat -> Printer ann -> Doc ann +runPrinter fmt p = p fmt + +asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann +asFmt fmt f x = case fmt of + OneLine -> asOneLine f x + MultiLine -> asDynamic f x + +asOneLine :: Formatter +asOneLine p x = runPrinter OneLine (p x) + +asDynamic :: Formatter +asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x)) + +ignoreFmt :: Doc ann -> Printer ann +ignoreFmt doc = printer doc doc + +fmtSep :: LineFormat -> [Doc ann] -> Doc ann +fmtSep = \case + OneLine -> hsep + MultiLine -> vsep + +fmtCat :: LineFormat -> [Doc ann] -> Doc ann +fmtCat = \case + OneLine -> hcat + MultiLine -> vcat + +fmtSpacer :: LineFormat -> Doc ann +fmtSpacer = \case + OneLine -> space + MultiLine -> softline + + +printer :: Doc ann -> Doc ann -> Printer ann +printer one multi = \case + OneLine -> one + MultiLine -> multi + +withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann +withOpenRow l r (fields,open) fmt = group $ align $ enclose (l <> spacer) (spacer <> r) $ fmtSep fmt $ punctuate comma fields' where + spacer = fmtSpacer fmt fields' = foldr (\x acc -> case acc of [] -> [hsep [x,pipe <++> open]] xs -> x : xs ) [] fields -openRow :: ([Doc ann], Doc ann) -> Doc ann +openRow :: ([Doc ann], Doc ann) -> Printer ann openRow = withOpenRow lparen rparen -openRecord :: ([Doc ann], Doc ann) -> Doc ann +openRecord :: ([Doc ann], Doc ann) -> Printer ann openRecord = withOpenRow lbrace rbrace -recordLike :: [Doc ann] -> Doc ann -recordLike fields = - let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline) - in group $ align (fmtObj fields) +recordLike :: [Doc ann] -> Printer ann +recordLike fields fmt = + enclose (lbrace <> spacer) (rbrace <> spacer) + . fmtSep fmt + . punctuate comma + $ fields + where + spacer = fmtSpacer fmt +-- let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline) +-- in group $ align (fmtObj fields) -record :: [Doc ann] -> Doc ann +record :: [Doc ann] -> Printer ann record = recordLike -object :: [Doc ann] -> Doc ann +object :: [Doc ann] -> Printer ann object = recordLike commaSep :: [Doc ann] -> Doc ann @@ -70,7 +123,7 @@ parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d -- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack ppType :: Int -> Type a -> String -ppType i t = "" {- go [] $ prettyPrintType i t +ppType i t = "" {- go [] $ prettyType i t where go :: String -> String -> String go acc [] = acc @@ -105,7 +158,7 @@ a <::> b = a <++> "::" <++> b a <=> b = a <+> "=" <+> b () :: Doc ann -> Doc ann -> Doc ann -a b = a <+> line <+> b +a b = a <+> hardline <+> b -- ensures the things being concatenated are always on the same line (<++>) :: Doc ann -> Doc ann -> Doc ann @@ -117,100 +170,119 @@ arrow = "->" lam :: Doc ann lam = "\\" +oneLineList :: [Doc ann] -> Doc ann +oneLineList = brackets . hcat . punctuate (comma <> space) + doubleColon :: Doc ann doubleColon = hcat [colon,colon] -caseOf :: [Doc ann] -> [Doc ann] -> Doc ann -caseOf scrutinees branches = "case" <+> group (hsep scrutinees) <+> "of" indent 2 (vcat . map group $ branches) -- if wrong try hang instead of hang - -prettyPrintObjectKey :: PSString -> Doc ann -prettyPrintObjectKey = pretty . decodeStringWithReplacement +prettyObjectKey :: PSString -> Doc ann +prettyObjectKey = pretty . decodeStringWithReplacement -prettyPrintObject :: [(PSString, Maybe (Expr a))] -> Doc ann -prettyPrintObject = encloseSep "{" "}" "," . map prettyPrintObjectProperty +prettyObject :: [(PSString, Maybe (Expr a))] -> Printer ann +prettyObject fields fmt = recordLike (prettyProperty <$> fields) fmt where - prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Doc ann - prettyPrintObjectProperty (key, value) = (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (pretty @Text "_") prettyPrintValue value + prettyProperty :: (PSString, Maybe (Expr a)) -> Doc ann + prettyProperty (key, value) = prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value -prettyPrintUpdateEntry :: PSString -> Expr a -> Doc ann -prettyPrintUpdateEntry key val = prettyPrintObjectKey key <+> "=" <+> prettyPrintValue val +prettyUpdateEntry :: PSString -> Expr a -> Printer ann +prettyUpdateEntry key val fmt = prettyObjectKey key <=> prettyValue val fmt -- | Pretty-print an expression -prettyPrintValue :: Expr a -> Doc ann --- prettyPrintValue _ | d < 0 = text "..." -prettyPrintValue (Accessor _ ty prop val) = group . align $ vcat [prettyPrintValueAtom val,hcat[dot,prettyPrintObjectKey prop]] -prettyPrintValue (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom o <+> encloseSep "{" "}" "," (uncurry prettyPrintUpdateEntry <$> ps) -prettyPrintValue (App ann ty val arg) = group . align $ vsep [prettyPrintValueAtom val,prettyPrintValueAtom arg] -prettyPrintValue (Abs ann ty arg val) = group . align $ flatAlt multiLine oneLine +prettyValue :: Expr a -> Printer ann +-- prettyValue _ | d < 0 = text "..." +prettyValue (Accessor _ ty prop val) fmt = fmtCat fmt [prettyValueAtom val fmt,hcat[dot,prettyObjectKey prop]] +prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt where - multiLine = lam - <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty)) - <+> arrow - <> hardline - <> hang 2 (prettyPrintValue val) + goUpdateEntry (str,e) = prettyUpdateEntry str e fmt +prettyValue (App ann ty val arg) fmt = group . align $ fmtSep fmt [prettyValueAtom val fmt, prettyValueAtom arg fmt] - oneLine = lam - <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty)) +prettyValue (Abs ann ty arg val) fmt = + lam + <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt) <+> arrow - <+> prettyPrintValue val - -prettyPrintValue (Case ann ty values binders) = - caseOf (prettyPrintValueAtom <$> values) (prettyPrintCaseAlternative <$> binders) -prettyPrintValue (Let _ _ ds val) = mappend line $ indent 2 $ vcat [ + <> fmtSpacer fmt + <> hang 2 (asFmt fmt prettyValue val) + +-- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) +prettyValue (Case ann ty values binders) _ = + "case" + <+> group (hsep scrutinees) + <+> "of" + indent 2 (vcat $ map group branches) + where + scrutinees = asOneLine prettyValueAtom <$> values + branches = group . asDynamic prettyCaseAlternative <$> binders +-- technically we could have a one line version of this but that's ugly af +prettyValue (Let _ _ ds val) fmt = align $ vcat [ "let", - indent 2 $ vcat $ prettyPrintDeclaration <$> ds, - "in" <+> align (prettyPrintValue val) + indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, + "in" <+> align (asDynamic prettyValue val) ] - -prettyPrintValue (Literal _ ty l) = parens $ prettyPrintLiteralValue l <:> prettyType ty -prettyPrintValue expr@Constructor{} = prettyPrintValueAtom expr -prettyPrintValue expr@Var{} = prettyPrintValueAtom expr + where + prefix = case fmt of + OneLine -> align + MultiLine -> (line <>) . indent 2 +prettyValue (Literal _ ty l) fmt = case fmt of {OneLine -> oneLine; MultiLine -> multiLine} + where + oneLine = parens $ hcat [ + asOneLine prettyLiteralValue l, + colon, + space, + asOneLine prettyType ty + ] + multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty +prettyValue expr@Constructor{} fmt = prettyValueAtom expr fmt +prettyValue expr@Var{} fmt = prettyValueAtom expr fmt -- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Expr a -> Doc ann -prettyPrintValueAtom (Literal _ _ l) = prettyPrintLiteralValue l -prettyPrintValueAtom (Constructor _ _ _ name _) = pretty $ T.unpack $ runProperName name -prettyPrintValueAtom (Var ann ty ident) = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty -prettyPrintValueAtom expr = (prettyPrintValue expr) - -prettyPrintLiteralValue :: Literal (Expr a) -> Doc ann -prettyPrintLiteralValue (NumericLiteral n) = pretty $ either show show n -prettyPrintLiteralValue (StringLiteral s) = pretty . T.unpack $ prettyPrintString s -prettyPrintLiteralValue (CharLiteral c) = viaShow . show $ c -prettyPrintLiteralValue (BooleanLiteral True) = "true" -prettyPrintLiteralValue (BooleanLiteral False) = "false" -prettyPrintLiteralValue (ArrayLiteral xs) = list $ prettyPrintValue <$> xs -prettyPrintLiteralValue (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps - -prettyPrintDeclaration :: Bind a -> Doc ann --- prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration b = case b of - NonRec _ ident expr -> vcat [ - pretty ident <::> prettyType (exprType expr), - pretty ident <=> prettyPrintValue expr -- not sure about the d here - ] - Rec bindings -> vcat $ concatMap (\((_,ident),expr) -> [ - pretty ident <::> prettyType (exprType expr), - pretty ident <=> prettyPrintValue expr - ]) bindings - -prettyPrintCaseAlternative :: forall a ann. CaseAlternative a -> Doc ann --- prettyPrintCaseAlternative d _ | d < 0 = ellipsis -prettyPrintCaseAlternative (CaseAlternative binders result) = - hsep (map prettyPrintBinderAtom binders) <> prettyPrintResult result +prettyValueAtom :: Expr a -> Printer ann +prettyValueAtom (Literal _ _ l) fmt = prettyLiteralValue l fmt +prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name +prettyValueAtom (Var ann ty ident) fmt = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty fmt +prettyValueAtom expr fmt = prettyValue expr fmt + +prettyLiteralValue :: Literal (Expr a) -> Printer ann +prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n +prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s +prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c +prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true" +prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false" +prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine where - prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann - prettyPrintResult = \case - Left ges -> vcat $ map prettyPrintGuardedValueSep' ges - Right exp' -> space <> arrow <+> prettyPrintValue exp' + oneLine = oneLineList $ asOneLine prettyValue <$> xs + -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine + multiLine = list $ asOneLine prettyValue <$> xs +prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps + +prettyDeclaration :: forall a ann. Bind a -> Printer ann +-- REVIEW: Maybe we don't want to ignore the format? +prettyDeclaration b = ignoreFmt $ case b of + NonRec _ ident expr -> goBind ident expr + Rec bindings -> vcat $ map (\((_,ident),expr) -> goBind ident expr) bindings + where + goBind :: Ident -> Expr a -> Doc ann + goBind ident expr = + pretty ident <::> asOneLine prettyType (exprType expr) + <> hardline + <> pretty ident <=> asDynamic prettyValue expr + +prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann +-- prettyCaseAlternative d _ | d < 0 = ellipsis +prettyCaseAlternative (CaseAlternative binders result) fmt = + hsep ( asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result + where + prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann + prettyResult = \case + Left ges -> vcat $ map prettyGuardedValueSep' ges + Right exp' -> space <> arrow <+> prettyValue exp' fmt - prettyPrintGuardedValueSep' :: (Guard a, Expr a) -> Doc ann - prettyPrintGuardedValueSep' (guardE, resultE) = - " | " <> prettyPrintValue guardE <+> arrow <+> prettyPrintValue resultE + prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann + prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue guardE fmt <+> arrow <+> prettyValue resultE fmt -prettyPrintModule :: Module a -> Doc ann -prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = +prettyModule :: Module a -> Doc ann +prettyModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = vsep $ [ pretty modName <+> parens (pretty modPath) , "Imported Modules: " @@ -222,7 +294,7 @@ prettyPrintModule (Module modSS modComments modName modPath modImports modExport , "Foreign: " , indent 2 . commaSep . map pretty $ modForeign , "Declarations: " - , vcat . punctuate line $ prettyPrintDeclaration <$> modDecls + , vcat . punctuate line $ asDynamic prettyDeclaration <$> modDecls ] where goReExport :: (ModuleName,[Ident]) -> Doc ann @@ -234,57 +306,57 @@ smartRender = renderStrict . layoutPretty defaultLayoutOptions writeModule :: Handle -> Module a -> IO () writeModule h m = renderIO h . layoutSmart defaultLayoutOptions - $ prettyPrintModule m + $ prettyModule m -prettyPrintModuleTxt :: Module a -> Text -prettyPrintModuleTxt = renderStrict . layoutPretty defaultLayoutOptions . prettyPrintModule +prettyModuleTxt :: Module a -> Text +prettyModuleTxt = renderStrict . layoutPretty defaultLayoutOptions . prettyModule -prettyPrintModuleStr :: Module a -> String -prettyPrintModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyPrintModule +prettyModuleStr :: Module a -> String +prettyModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyModule renderExpr :: Expr a -> Text -renderExpr = smartRender . prettyPrintValue +renderExpr = smartRender . asDynamic prettyValue renderExprStr :: Expr a -> String renderExprStr = T.unpack . renderExpr prettyTypeStr :: forall a. Show a => Type a -> String -prettyTypeStr = T.unpack . smartRender . prettyType - -prettyPrintBinderAtom :: Binder a -> Doc ann -prettyPrintBinderAtom (NullBinder _) = "_" -prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l -prettyPrintBinderAtom (VarBinder _ ident) = pretty ident -prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor) -prettyPrintBinderAtom b@ConstructorBinder{} = prettyPrintBinder b -prettyPrintBinderAtom (NamedBinder _ ident binder) = pretty ident <> "@" <> prettyPrintBinder binder - -prettyPrintLiteralBinder :: Literal (Binder a) -> Doc ann -prettyPrintLiteralBinder (StringLiteral str) = pretty $ prettyPrintString str -prettyPrintLiteralBinder (CharLiteral c) = viaShow c -prettyPrintLiteralBinder (NumericLiteral num) = either pretty pretty num -prettyPrintLiteralBinder (BooleanLiteral True) = "true" -prettyPrintLiteralBinder (BooleanLiteral False) = "false" -prettyPrintLiteralBinder (ObjectLiteral bs) = object $ prettyPrintObjectPropertyBinder <$> bs +prettyTypeStr = T.unpack . smartRender . asOneLine prettyType + +prettyBinderAtom :: Binder a -> Printer ann +prettyBinderAtom (NullBinder _) _ = "_" +prettyBinderAtom (LiteralBinder _ l) fmt = prettyLiteralBinder l fmt +prettyBinderAtom (VarBinder _ ident) _ = pretty ident +prettyBinderAtom (ConstructorBinder _ _ ctor []) _ = pretty $ runProperName (disqualify ctor) +prettyBinderAtom b@ConstructorBinder{} fmt = prettyBinder b fmt +prettyBinderAtom (NamedBinder _ ident binder) fmt = pretty ident <> "@" <> prettyBinder binder fmt + +prettyLiteralBinder :: Literal (Binder a) -> Printer ann +prettyLiteralBinder (StringLiteral str) _ = pretty $ prettyPrintString str +prettyLiteralBinder (CharLiteral c) _ = viaShow c +prettyLiteralBinder (NumericLiteral num) _ = either pretty pretty num +prettyLiteralBinder (BooleanLiteral True) _ = "true" +prettyLiteralBinder (BooleanLiteral False) _ = "false" +prettyLiteralBinder (ObjectLiteral bs) fmt = asFmt fmt object $ prettyObjectPropertyBinder <$> bs where - prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Doc ann - prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key <:> prettyPrintBinder binder -prettyPrintLiteralBinder (ArrayLiteral bs) = list (prettyPrintBinder <$> bs) + prettyObjectPropertyBinder :: (PSString, Binder a) -> Doc ann + prettyObjectPropertyBinder (key, binder) = prettyObjectKey key <:> prettyBinder binder fmt +prettyLiteralBinder (ArrayLiteral bs) fmt = list (asFmt fmt prettyBinder <$> bs) -- | -- Generate a pretty-printed string representing a Binder -- -prettyPrintBinder :: Binder a -> Doc ann -prettyPrintBinder (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder _ _ ctor args) = - pretty (runProperName (disqualify ctor)) <+> hcat (prettyPrintBinderAtom <$> args) -prettyPrintBinder b = prettyPrintBinderAtom b +prettyBinder :: Binder a -> Printer ann +prettyBinder (ConstructorBinder _ _ ctor []) fmt = pretty $ runProperName (disqualify ctor) +prettyBinder (ConstructorBinder _ _ ctor args) fmt = + pretty (runProperName (disqualify ctor)) <+> fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) +prettyBinder b fmt= prettyBinderAtom b fmt {- TYPES (move later) -} -prettyType :: forall a ann. Show a => Type a -> Doc ann -prettyType t= group $ case t of +prettyType :: forall a ann. Show a => Type a -> Printer ann +prettyType t fmt = group $ case t of TUnknown _ n -> "t" <> pretty n TypeVar _ txt -> pretty txt @@ -303,7 +375,7 @@ prettyType t= group $ case t of TypeApp _ t1 t2 -> goTypeApp t1 t2 - KindApp a k1 k2 -> prettyType k1 <> ("@" <> prettyType k2) + KindApp a k1 k2 -> prettyType k1 fmt <> ("@" <> prettyType k2 fmt) ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner @@ -314,18 +386,19 @@ prettyType t= group $ case t of REmpty _ -> "{}" - rcons@RCons{} -> either openRow tupled $ rowFields rcons + rcons@RCons{} -> either (asFmt fmt openRow) tupled $ rowFields rcons -- this might be backwards - KindedType a ty kind -> parens $ prettyType ty <::> prettyType kind + KindedType a ty kind -> parens $ prettyType ty fmt <::> prettyType kind fmt -- not sure what this is? - BinaryNoParensType a op l r -> prettyType l <++> prettyType op <++> prettyType r + BinaryNoParensType a op l r -> prettyType l fmt <+> prettyType op fmt <+> prettyType r fmt - ParensInType _ ty -> parens (prettyType ty) + ParensInType _ ty -> parens (prettyType ty fmt) where + goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann - goForall xs inner = "forall" <++> hcat (renderBoundVar <$> xs) <> "." <++> prettyType inner + goForall xs inner = "forall" <+> fmtCat fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann prefixVis vis tv = case vis of @@ -334,7 +407,7 @@ prettyType t= group $ case t of renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann renderBoundVar (vis,var,mk) = case mk of - Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k + Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k fmt Nothing -> prefixVis vis (pretty var) stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a) @@ -344,16 +417,16 @@ prettyType t= group $ case t of goTypeApp :: Type a -> Type a -> Doc ann goTypeApp (TypeApp _ f a) b - | eqType f tyFunction = prettyType a <++> arrow <++> prettyType b - | otherwise = parens $ goTypeApp f a <++> prettyType b + | eqType f tyFunction = fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt] + | otherwise = parens $ goTypeApp f a <+> prettyType b fmt goTypeApp o ty@RCons{} - | eqType o tyRecord = either openRecord record $ rowFields ty - goTypeApp a b = prettyType a <++> prettyType b + | eqType o tyRecord = either (asFmt fmt openRecord) (asFmt fmt record) $ rowFields ty + goTypeApp a b = fmtSep fmt [prettyType a fmt,prettyType b fmt] rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann] rowFields = \case RCons _ lbl ty rest -> - let f = ((pretty lbl <::> prettyType ty):) + let f = ((pretty lbl <::> prettyType ty fmt):) in bimap (first f) f $ rowFields rest REmpty _ -> Right [] KindApp _ REmpty{} _ -> Right [] -- REmpty is sometimes wrapped in a kind app? diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 6c778887..145f76b1 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -124,7 +124,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- pTrace exps ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env') - traceM . T.unpack $ CFT.prettyPrintModuleTxt coreFn + traceM . T.unpack $ CFT.prettyModuleTxt coreFn let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 512fea59..bd5c2ff5 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -60,7 +60,7 @@ import System.FilePath ((), makeRelative, splitPath, normalise, splitDirector import System.FilePath.Posix qualified as Posix import System.IO (stderr, withFile, IOMode(WriteMode)) import Language.PureScript.CoreFn.ToJSON (moduleToJSON) -import Language.PureScript.CoreFn.Pretty (writeModule, prettyPrintModule) +import Language.PureScript.CoreFn.Pretty (writeModule) -- | Determines when to rebuild a module From 7876fdb6038f2d5349b5d6ece595578c877f1801 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Sat, 2 Mar 2024 01:48:57 -0500 Subject: [PATCH 34/44] even prettier --- src/Language/PureScript/CoreFn/Pretty.hs | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index b1b2ebe7..4b798424 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -73,6 +73,10 @@ fmtSpacer = \case OneLine -> space MultiLine -> softline +fmtIndent :: LineFormat -> Doc ann -> Doc ann +fmtIndent = \case + OneLine -> id + MultiLine -> \doc -> line <> indent 2 doc printer :: Doc ann -> Doc ann -> Printer ann printer one multi = \case @@ -96,7 +100,7 @@ openRecord = withOpenRow lbrace rbrace recordLike :: [Doc ann] -> Printer ann recordLike fields fmt = - enclose (lbrace <> spacer) (rbrace <> spacer) + enclose (lbrace <> spacer) (space <> rbrace) . fmtSep fmt . punctuate comma $ fields @@ -201,8 +205,9 @@ prettyValue (Abs ann ty arg val) fmt = lam <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt) <+> arrow - <> fmtSpacer fmt - <> hang 2 (asFmt fmt prettyValue val) + <+> fmtIndent fmt (asFmt fmt prettyValue val) + -- <> fmtSpacer fmt + -- <> hang 2 (asFmt fmt prettyValue val) -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) prettyValue (Case ann ty values binders) _ = @@ -257,7 +262,7 @@ prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps prettyDeclaration :: forall a ann. Bind a -> Printer ann -- REVIEW: Maybe we don't want to ignore the format? -prettyDeclaration b = ignoreFmt $ case b of +prettyDeclaration b fmt = case b of NonRec _ ident expr -> goBind ident expr Rec bindings -> vcat $ map (\((_,ident),expr) -> goBind ident expr) bindings where @@ -265,17 +270,21 @@ prettyDeclaration b = ignoreFmt $ case b of goBind ident expr = pretty ident <::> asOneLine prettyType (exprType expr) <> hardline - <> pretty ident <=> asDynamic prettyValue expr + <> goInner ident expr + goInner :: Ident -> Expr a -> Doc ann + goInner ident expr = + let f g = pretty ident <=> g (asDynamic prettyValue expr) + in group $ flatAlt (f (fmtIndent fmt)) (f id) prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann -- prettyCaseAlternative d _ | d < 0 = ellipsis prettyCaseAlternative (CaseAlternative binders result) fmt = - hsep ( asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result + hsep (asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result where prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann prettyResult = \case Left ges -> vcat $ map prettyGuardedValueSep' ges - Right exp' -> space <> arrow <+> prettyValue exp' fmt + Right exp' -> space <> arrow <+> fmtIndent fmt (prettyValue exp' fmt) prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue guardE fmt <+> arrow <+> prettyValue resultE fmt From c862bd5586fc5c419acc0025504831668b5f70bc Mon Sep 17 00:00:00 2001 From: gnumonik Date: Sat, 2 Mar 2024 02:47:26 -0500 Subject: [PATCH 35/44] extremely pretty --- src/Language/PureScript/CoreFn/Pretty.hs | 65 ++++++++++++++---------- tests/purus/passing/Misc/Lib.purs | 10 ++++ 2 files changed, 48 insertions(+), 27 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 4b798424..8889af41 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,5 +1,11 @@ {-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-} -module Language.PureScript.CoreFn.Pretty where +module Language.PureScript.CoreFn.Pretty ( + writeModule, + ppType, + prettyTypeStr, + renderExprStr, + prettyModuleTxt +) where import Prelude hiding ((<>)) @@ -125,17 +131,9 @@ parens' :: Doc ann -> Doc ann parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d --- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack -ppType :: Int -> Type a -> String -ppType i t = "" {- go [] $ prettyType i t - where - go :: String -> String -> String - go acc [] = acc - go acc (' ':xs) = case dropWhile (== ' ') xs of - [] -> acc - more -> go (acc `mappend` [' ']) more - go acc (x:xs) = go (acc `mappend` [x]) xs --} +-- TODO: Remove +ppType :: Show a => Int -> Type a -> String +ppType i t = prettyTypeStr t instance Pretty Ident where pretty = pretty . showIdent @@ -177,8 +175,24 @@ lam = "\\" oneLineList :: [Doc ann] -> Doc ann oneLineList = brackets . hcat . punctuate (comma <> space) -doubleColon :: Doc ann -doubleColon = hcat [colon,colon] +-- helpers to ensure even formatting of applications + +analyzeApp :: Expr a -> Maybe (Expr a,[Expr a]) +analyzeApp t = (,appArgs t) <$> appFun t + where + appArgs :: Expr a -> [Expr a] + appArgs (App _ _ t1 t2) = appArgs t1 <> [t2] + appArgs _ = [] + + appFun :: Expr a -> Maybe (Expr a) + appFun (App _ _ t1 _) = go t1 + where + go (App _ _ tx _) = case appFun tx of + Nothing -> Just tx + Just tx' -> Just tx' + go other = Just other + appFun _ = Nothing + prettyObjectKey :: PSString -> Doc ann prettyObjectKey = pretty . decodeStringWithReplacement @@ -199,15 +213,17 @@ prettyValue (Accessor _ ty prop val) fmt = fmtCat fmt [prettyValueAtom val fmt, prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt where goUpdateEntry (str,e) = prettyUpdateEntry str e fmt -prettyValue (App ann ty val arg) fmt = group . align $ fmtSep fmt [prettyValueAtom val fmt, prettyValueAtom arg fmt] +prettyValue app@(App ann ty val arg) fmt = case analyzeApp app of + Just (fun,args) -> case fmt of + OneLine -> group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) + MultiLine -> group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args) + Nothing -> error "App isn't an App (impossible)" prettyValue (Abs ann ty arg val) fmt = lam <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt) <+> arrow <+> fmtIndent fmt (asFmt fmt prettyValue val) - -- <> fmtSpacer fmt - -- <> hang 2 (asFmt fmt prettyValue val) -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) prettyValue (Case ann ty values binders) _ = @@ -224,10 +240,6 @@ prettyValue (Let _ _ ds val) fmt = align $ vcat [ indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, "in" <+> align (asDynamic prettyValue val) ] - where - prefix = case fmt of - OneLine -> align - MultiLine -> (line <>) . indent 2 prettyValue (Literal _ ty l) fmt = case fmt of {OneLine -> oneLine; MultiLine -> multiLine} where oneLine = parens $ hcat [ @@ -244,8 +256,8 @@ prettyValue expr@Var{} fmt = prettyValueAtom expr fmt prettyValueAtom :: Expr a -> Printer ann prettyValueAtom (Literal _ _ l) fmt = prettyLiteralValue l fmt prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name -prettyValueAtom (Var ann ty ident) fmt = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty fmt -prettyValueAtom expr fmt = prettyValue expr fmt +prettyValueAtom (Var ann ty ident) fmt = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty fmt +prettyValueAtom expr fmt = parens $ prettyValue expr fmt prettyLiteralValue :: Literal (Expr a) -> Printer ann prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n @@ -389,9 +401,9 @@ prettyType t fmt = group $ case t of ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner - ConstrainedType _ constraint inner -> error "TODO: ConstrainedType" + ConstrainedType _ constraint inner -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)" - Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem" + Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" REmpty _ -> "{}" @@ -405,9 +417,8 @@ prettyType t fmt = group $ case t of ParensInType _ ty -> parens (prettyType ty fmt) where - goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann - goForall xs inner = "forall" <+> fmtCat fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt + goForall xs inner = "forall" <+> fmtSep fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann prefixVis vis tv = case vis of diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs index 7f14dab3..11a29e12 100644 --- a/tests/purus/passing/Misc/Lib.purs +++ b/tests/purus/passing/Misc/Lib.purs @@ -147,6 +147,16 @@ aFunction6 = aFunction [] go go :: forall (z :: Type). z -> Int go _ = 10 +nestedApplications :: Int +nestedApplications = i (f (g (h 2))) 4 + where + i x _ = x + f x = x + g _ = 5 + h = case _ of + 2 -> 3 + _ -> 5 + {- Objects -} anObj :: {foo :: Int} From 4b6112c5f89792c51c345d5630d36a07fc69d58c Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 5 Mar 2024 17:32:48 -0500 Subject: [PATCH 36/44] Refactored pretty printer update to use Reader monad (hopefully makes easier to read) --- src/Language/PureScript/CoreFn/Pretty.hs | 403 ++++++++++++++--------- 1 file changed, 252 insertions(+), 151 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 8889af41..4964ad26 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -9,33 +9,75 @@ module Language.PureScript.CoreFn.Pretty ( import Prelude hiding ((<>)) - - import Data.Text (Text) -import Data.List.NonEmpty qualified as NEL -import Data.Monoid qualified as Monoid ((<>)) import Data.Text qualified as T +import Data.Map qualified as M +import Data.Bifunctor (first, Bifunctor (..)) +import Control.Monad.Reader import Language.PureScript.Environment + ( tyRecord, tyFunction, getFunArgTy ) import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Module -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Binders -import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified) -import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) -import Language.PureScript.Types (Constraint(..), Type (..), WildcardData (..), TypeVarVisibility (..), eqType) + ( exprType, + Guard, + Bind(..), + CaseAlternative(CaseAlternative), + Expr(..) ) +import Language.PureScript.CoreFn.Module ( Module(Module) ) +import Language.PureScript.AST.Literals ( Literal(..) ) +import Language.PureScript.CoreFn.Binders ( Binder(..) ) +import Language.PureScript.Label (Label (..)) +import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified) +import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType) import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement) import System.IO (Handle) -import Data.Map qualified as M - import Prettyprinter -import Prettyprinter.Render.Text -import qualified Prettyprinter.Render.String as STR -import Data.Bifunctor (first, Bifunctor (..)) -import Language.PureScript.Label (Label (..)) -import Control.Monad (void) + ( (<>), + tupled, + layoutSmart, + defaultLayoutOptions, + layoutPretty, + list, + viaShow, + colon, + parens, + dot, + brackets, + hardline, + (<+>), + rbrace, + lbrace, + rparen, + lparen, + pipe, + comma, + punctuate, + enclose, + indent, + line, + softline, + space, + vcat, + hcat, + vsep, + hsep, + flatAlt, + align, + group, + Doc, + Pretty(pretty) ) +import Prettyprinter.Render.Text ( renderIO, renderStrict ) + +{- Rewritten prettyprinter that uses a modern printer library & is less convoluted. + + We primarily need this for writing the "prettified" CoreFn files for development purposes. + The existing printer is extremely difficult to modify for our needs (e.g. there isn't a clear way to force + an expression or type to print on one line). Because reading the CoreFn output is necessary + to ensure correctness, it's important that we get get something legible. + +-} + data LineFormat = OneLine -- *DEFINITELY* Print on one line, even if doing so exceeds the page width @@ -43,12 +85,12 @@ data LineFormat deriving (Show, Eq) -- TODO: Refactor to reader monad? -type Printer ann = LineFormat -> Doc ann +type Printer ann = Reader LineFormat (Doc ann) type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann runPrinter :: LineFormat -> Printer ann -> Doc ann -runPrinter fmt p = p fmt +runPrinter fmt p = runReader p fmt asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann asFmt fmt f x = case fmt of @@ -64,35 +106,37 @@ asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter ignoreFmt :: Doc ann -> Printer ann ignoreFmt doc = printer doc doc -fmtSep :: LineFormat -> [Doc ann] -> Doc ann -fmtSep = \case - OneLine -> hsep - MultiLine -> vsep +fmtSep :: [Doc ann] -> Printer ann +fmtSep docs = ask >>= \case + OneLine -> pure $ hsep docs + MultiLine -> pure $ vsep docs -fmtCat :: LineFormat -> [Doc ann] -> Doc ann -fmtCat = \case - OneLine -> hcat - MultiLine -> vcat +fmtCat :: [Doc ann] -> Printer ann +fmtCat docs = ask >>= \case + OneLine -> pure $ hcat docs + MultiLine -> pure $ vcat docs -fmtSpacer :: LineFormat -> Doc ann -fmtSpacer = \case - OneLine -> space - MultiLine -> softline +fmtSpacer :: Printer ann +fmtSpacer = ask >>= \case + OneLine -> pure space + MultiLine -> pure softline -fmtIndent :: LineFormat -> Doc ann -> Doc ann -fmtIndent = \case - OneLine -> id - MultiLine -> \doc -> line <> indent 2 doc +fmtIndent :: Doc ann -> Printer ann +fmtIndent doc = ask >>= \case + OneLine -> pure doc + MultiLine -> pure $ line <> indent 2 doc printer :: Doc ann -> Doc ann -> Printer ann -printer one multi = \case - OneLine -> one - MultiLine -> multi +printer one multi = ask >>= \case + OneLine -> pure one + MultiLine -> pure multi withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann -withOpenRow l r (fields,open) fmt = group $ align $ enclose (l <> spacer) (spacer <> r) $ fmtSep fmt $ punctuate comma fields' +withOpenRow l r (fields,open) = do + spacer <- fmtSpacer + fmtFields <- fmtSep $ punctuate comma fields' + pure . group . align $ enclose (l <> spacer) (spacer <> r) fmtFields where - spacer = fmtSpacer fmt fields' = foldr (\x acc -> case acc of [] -> [hsep [x,pipe <++> open]] xs -> x : xs @@ -105,15 +149,10 @@ openRecord :: ([Doc ann], Doc ann) -> Printer ann openRecord = withOpenRow lbrace rbrace recordLike :: [Doc ann] -> Printer ann -recordLike fields fmt = - enclose (lbrace <> spacer) (space <> rbrace) - . fmtSep fmt - . punctuate comma - $ fields - where - spacer = fmtSpacer fmt --- let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline) --- in group $ align (fmtObj fields) +recordLike fields = do + spacer <- fmtSpacer + fields' <- fmtSep $ punctuate comma fields + pure $ enclose (lbrace <> spacer) (space <> rbrace) fields' record :: [Doc ann] -> Printer ann record = recordLike @@ -147,9 +186,6 @@ instance Pretty ModuleName where instance Pretty Label where pretty = pretty . runLabel -ellipsis :: Doc ann -ellipsis = "..." - (<:>) :: Doc ann -> Doc ann -> Doc ann a <:> b = hcat [a,":"] <++> b @@ -176,7 +212,6 @@ oneLineList :: [Doc ann] -> Doc ann oneLineList = brackets . hcat . punctuate (comma <> space) -- helpers to ensure even formatting of applications - analyzeApp :: Expr a -> Maybe (Expr a,[Expr a]) analyzeApp t = (,appArgs t) <$> appFun t where @@ -194,39 +229,60 @@ analyzeApp t = (,appArgs t) <$> appFun t appFun _ = Nothing -prettyObjectKey :: PSString -> Doc ann -prettyObjectKey = pretty . decodeStringWithReplacement +-- Is a printer for consistency mainly +prettyObjectKey :: PSString -> Printer ann +prettyObjectKey = pure . pretty . decodeStringWithReplacement prettyObject :: [(PSString, Maybe (Expr a))] -> Printer ann -prettyObject fields fmt = recordLike (prettyProperty <$> fields) fmt +prettyObject fields = do + fields' <- traverse prettyProperty fields + recordLike fields' where - prettyProperty :: (PSString, Maybe (Expr a)) -> Doc ann - prettyProperty (key, value) = prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value + prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann + prettyProperty (key, value) = do + key' <- prettyObjectKey key + props' <- maybe (pure $ pretty @Text "_") prettyValue value + pure (key' <:> props') -- prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value prettyUpdateEntry :: PSString -> Expr a -> Printer ann -prettyUpdateEntry key val fmt = prettyObjectKey key <=> prettyValue val fmt +prettyUpdateEntry key val = do + key' <- prettyObjectKey key + val' <- prettyValue val + pure $ key' <=> val' -- | Pretty-print an expression prettyValue :: Expr a -> Printer ann -- prettyValue _ | d < 0 = text "..." -prettyValue (Accessor _ ty prop val) fmt = fmtCat fmt [prettyValueAtom val fmt,hcat[dot,prettyObjectKey prop]] -prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt +prettyValue (Accessor _ ty prop val) = do + prop' <- prettyObjectKey prop + val' <- prettyValueAtom val + fmtCat [val',hcat[dot,prop']] +prettyValue (ObjectUpdate ann _ty o _copyFields ps) = do + obj <- prettyValueAtom o + updateEntries <- traverse goUpdateEntry ps >>= recordLike + pure $ obj <+> updateEntries -- prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt where - goUpdateEntry (str,e) = prettyUpdateEntry str e fmt -prettyValue app@(App ann ty val arg) fmt = case analyzeApp app of - Just (fun,args) -> case fmt of - OneLine -> group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) - MultiLine -> group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args) + goUpdateEntry = uncurry prettyUpdateEntry +prettyValue app@(App ann ty val arg) = case analyzeApp app of + Just (fun,args) -> ask >>= \case + OneLine -> pure . group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) + MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args) Nothing -> error "App isn't an App (impossible)" -prettyValue (Abs ann ty arg val) fmt = - lam +prettyValue (Abs ann ty arg val) = do + ty' <- prettyType (getFunArgTy ty) + body' <- fmtIndent =<< prettyValue val + pure $ lam + <> parens (align $ pretty (showIdent arg) <:> ty') + <+> arrow + <+> body' + {- lam <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt) <+> arrow <+> fmtIndent fmt (asFmt fmt prettyValue val) - + -} -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) -prettyValue (Case ann ty values binders) _ = +prettyValue (Case ann ty values binders) = pure $ "case" <+> group (hsep scrutinees) <+> "of" @@ -235,12 +291,12 @@ prettyValue (Case ann ty values binders) _ = scrutinees = asOneLine prettyValueAtom <$> values branches = group . asDynamic prettyCaseAlternative <$> binders -- technically we could have a one line version of this but that's ugly af -prettyValue (Let _ _ ds val) fmt = align $ vcat [ +prettyValue (Let _ _ ds val) = pure . align $ vcat [ "let", indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, "in" <+> align (asDynamic prettyValue val) ] -prettyValue (Literal _ ty l) fmt = case fmt of {OneLine -> oneLine; MultiLine -> multiLine} +prettyValue (Literal _ ty l) = ask >>= \case {OneLine -> pure oneLine; MultiLine -> pure multiLine} where oneLine = parens $ hcat [ asOneLine prettyLiteralValue l, @@ -249,15 +305,16 @@ prettyValue (Literal _ ty l) fmt = case fmt of {OneLine -> oneLine; MultiLine - asOneLine prettyType ty ] multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty -prettyValue expr@Constructor{} fmt = prettyValueAtom expr fmt -prettyValue expr@Var{} fmt = prettyValueAtom expr fmt +prettyValue expr@Constructor{} = prettyValueAtom expr +prettyValue expr@Var{} = prettyValueAtom expr -- | Pretty-print an atomic expression, adding parentheses if necessary. prettyValueAtom :: Expr a -> Printer ann -prettyValueAtom (Literal _ _ l) fmt = prettyLiteralValue l fmt -prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name -prettyValueAtom (Var ann ty ident) fmt = parens $ pretty (showIdent (disqualify ident)) <:> prettyType ty fmt -prettyValueAtom expr fmt = parens $ prettyValue expr fmt +prettyValueAtom (Literal _ _ l) = prettyLiteralValue l +prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name +prettyValueAtom (Var ann ty ident) = prettyType ty >>= \ty' -> + pure . parens $ pretty (showIdent (disqualify ident)) <:> ty' +prettyValueAtom expr = parens <$> prettyValue expr prettyLiteralValue :: Literal (Expr a) -> Printer ann prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n @@ -274,32 +331,45 @@ prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps prettyDeclaration :: forall a ann. Bind a -> Printer ann -- REVIEW: Maybe we don't want to ignore the format? -prettyDeclaration b fmt = case b of +prettyDeclaration b = case b of NonRec _ ident expr -> goBind ident expr - Rec bindings -> vcat $ map (\((_,ident),expr) -> goBind ident expr) bindings + Rec bindings -> vcat <$> traverse (\((_,ident),expr) -> goBind ident expr) bindings where - goBind :: Ident -> Expr a -> Doc ann - goBind ident expr = - pretty ident <::> asOneLine prettyType (exprType expr) - <> hardline - <> goInner ident expr - goInner :: Ident -> Expr a -> Doc ann - goInner ident expr = - let f g = pretty ident <=> g (asDynamic prettyValue expr) - in group $ flatAlt (f (fmtIndent fmt)) (f id) + goBind :: Ident -> Expr a -> Printer ann + goBind ident expr = do + inner' <- goInner ident expr + let ty' = asOneLine prettyType (exprType expr) + pure $ + pretty ident <::> ty' + <> hardline + <> inner' + goInner :: Ident -> Expr a -> Printer ann + goInner ident expr = do + fmt <- ask + let ind docs = runReader (fmtIndent docs) fmt + f g = pretty ident <=> g (asDynamic prettyValue expr) + pure $ group $ flatAlt (f ind) (f id) prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann -- prettyCaseAlternative d _ | d < 0 = ellipsis -prettyCaseAlternative (CaseAlternative binders result) fmt = - hsep (asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result +prettyCaseAlternative (CaseAlternative binders result) = do + binders' <- traverse prettyBinderAtom binders + result' <- prettyResult result + pure $ hsep binders' <> result' -- hsep (asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result where - prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann + prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann prettyResult = \case - Left ges -> vcat $ map prettyGuardedValueSep' ges - Right exp' -> space <> arrow <+> fmtIndent fmt (prettyValue exp' fmt) + Left ges -> vcat <$> traverse prettyGuardedValueSep' ges + Right exp' -> do + body' <- prettyValue exp' >>= fmtIndent + pure $ space <> arrow <+> body' + -- space <> arrow <+> fmtIndent fmt (prettyValue exp' fmt) - prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann - prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue guardE fmt <+> arrow <+> prettyValue resultE fmt + prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann + prettyGuardedValueSep' (guardE, resultE) = do + guardE' <- prettyValue guardE + resultE' <- prettyValue resultE + pure $ " | " <> guardE' <+> arrow <+> resultE' prettyModule :: Module a -> Doc ann @@ -332,9 +402,6 @@ writeModule h m = renderIO h prettyModuleTxt :: Module a -> Text prettyModuleTxt = renderStrict . layoutPretty defaultLayoutOptions . prettyModule -prettyModuleStr :: Module a -> String -prettyModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyModule - renderExpr :: Expr a -> Text renderExpr = smartRender . asDynamic prettyValue @@ -345,58 +412,67 @@ prettyTypeStr :: forall a. Show a => Type a -> String prettyTypeStr = T.unpack . smartRender . asOneLine prettyType prettyBinderAtom :: Binder a -> Printer ann -prettyBinderAtom (NullBinder _) _ = "_" -prettyBinderAtom (LiteralBinder _ l) fmt = prettyLiteralBinder l fmt -prettyBinderAtom (VarBinder _ ident) _ = pretty ident -prettyBinderAtom (ConstructorBinder _ _ ctor []) _ = pretty $ runProperName (disqualify ctor) -prettyBinderAtom b@ConstructorBinder{} fmt = prettyBinder b fmt -prettyBinderAtom (NamedBinder _ ident binder) fmt = pretty ident <> "@" <> prettyBinder binder fmt +prettyBinderAtom (NullBinder _) = pure "_" +prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l +prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident +prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) +prettyBinderAtom b@ConstructorBinder{} = prettyBinder b +prettyBinderAtom (NamedBinder _ ident binder)= do + binder' <- prettyBinder binder + pure $ pretty ident <> "@" <> binder' prettyLiteralBinder :: Literal (Binder a) -> Printer ann -prettyLiteralBinder (StringLiteral str) _ = pretty $ prettyPrintString str -prettyLiteralBinder (CharLiteral c) _ = viaShow c -prettyLiteralBinder (NumericLiteral num) _ = either pretty pretty num -prettyLiteralBinder (BooleanLiteral True) _ = "true" -prettyLiteralBinder (BooleanLiteral False) _ = "false" -prettyLiteralBinder (ObjectLiteral bs) fmt = asFmt fmt object $ prettyObjectPropertyBinder <$> bs +prettyLiteralBinder (StringLiteral str) = pure . pretty $ prettyPrintString str +prettyLiteralBinder (CharLiteral c) = pure $ viaShow c +prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num +prettyLiteralBinder (BooleanLiteral True) = pure "true" +prettyLiteralBinder (BooleanLiteral False) = pure "false" +prettyLiteralBinder (ObjectLiteral bs) = object =<< traverse prettyObjectPropertyBinder bs where - prettyObjectPropertyBinder :: (PSString, Binder a) -> Doc ann - prettyObjectPropertyBinder (key, binder) = prettyObjectKey key <:> prettyBinder binder fmt -prettyLiteralBinder (ArrayLiteral bs) fmt = list (asFmt fmt prettyBinder <$> bs) + prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann + prettyObjectPropertyBinder (key, binder) = do + key' <- prettyObjectKey key + binder' <- prettyBinder binder + pure $ key' <:> binder' +prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs -- | -- Generate a pretty-printed string representing a Binder -- prettyBinder :: Binder a -> Printer ann -prettyBinder (ConstructorBinder _ _ ctor []) fmt = pretty $ runProperName (disqualify ctor) -prettyBinder (ConstructorBinder _ _ ctor args) fmt = - pretty (runProperName (disqualify ctor)) <+> fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) -prettyBinder b fmt= prettyBinderAtom b fmt +prettyBinder (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) +prettyBinder (ConstructorBinder _ _ ctor args) = do + args' <- fmtSep =<< traverse prettyBinderAtom args + pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) +prettyBinder b = prettyBinderAtom b {- TYPES (move later) -} prettyType :: forall a ann. Show a => Type a -> Printer ann -prettyType t fmt = group $ case t of - TUnknown _ n -> "t" <> pretty n +prettyType t = group <$> case t of + TUnknown _ n -> pure $ "t" <> pretty n - TypeVar _ txt -> pretty txt + TypeVar _ txt -> pure $ pretty txt - TypeLevelString _ pss -> pretty . prettyPrintString $ pss + TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss - TypeLevelInt _ i -> pretty i + TypeLevelInt _ i -> pure $ pretty i TypeWildcard _ wcd -> case wcd of - HoleWildcard txt -> "?" <> pretty txt - _ -> "_" + HoleWildcard txt -> pure $ "?" <> pretty txt + _ -> pure "_" - TypeConstructor _ qPropName -> pretty . runProperName . disqualify $ qPropName + TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName - TypeOp a opName -> pretty $ showQualified runOpName opName + TypeOp a opName -> pure . pretty $ showQualified runOpName opName TypeApp _ t1 t2 -> goTypeApp t1 t2 - KindApp a k1 k2 -> prettyType k1 fmt <> ("@" <> prettyType k2 fmt) + KindApp a k1 k2 -> do + k1' <- prettyType k1 + k2' <- prettyType k2 + pure $ k1' <> ("@" <> k2' ) ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner @@ -405,50 +481,75 @@ prettyType t fmt = group $ case t of Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" - REmpty _ -> "{}" + REmpty _ -> pure "{}" - rcons@RCons{} -> either (asFmt fmt openRow) tupled $ rowFields rcons + rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons -- this might be backwards - KindedType a ty kind -> parens $ prettyType ty fmt <::> prettyType kind fmt + KindedType a ty kind -> do + ty' <- prettyType ty + kind' <- prettyType kind + pure . parens $ ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt -- not sure what this is? - BinaryNoParensType a op l r -> prettyType l fmt <+> prettyType op fmt <+> prettyType r fmt + BinaryNoParensType a op l r -> do + l' <- prettyType l + op' <- prettyType op + r' <- prettyType r + pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt <+> prettyType r fmt - ParensInType _ ty -> parens (prettyType ty fmt) + ParensInType _ ty -> parens <$> prettyType ty where - goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann - goForall xs inner = "forall" <+> fmtSep fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt + goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann + goForall xs inner = do + boundVars <- fmtSep =<< traverse renderBoundVar xs + inner' <- prettyType inner + pure $ + "forall" <+> boundVars <> "." <+> inner' prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann prefixVis vis tv = case vis of TypeVarVisible -> hcat ["@",tv] TypeVarInvisible -> tv - renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann + renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann renderBoundVar (vis,var,mk) = case mk of - Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k fmt - Nothing -> prefixVis vis (pretty var) + Just k -> do + ty' <- prettyType k + pure . parens $ prefixVis vis (pretty var) <::> ty' + Nothing -> pure $ prefixVis vis (pretty var) stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a) stripQuantifiers = \case ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner other -> ([],other) - goTypeApp :: Type a -> Type a -> Doc ann + goTypeApp :: Type a -> Type a -> Printer ann goTypeApp (TypeApp _ f a) b - | eqType f tyFunction = fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt] - | otherwise = parens $ goTypeApp f a <+> prettyType b fmt + | eqType f tyFunction = do + a' <- prettyType a + b' <- prettyType b + fmtSep [a' <+> arrow,b'] + -- fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt] + | otherwise = do + f' <- goTypeApp f a + b' <- prettyType b + pure $ parens $ f' <+> b' goTypeApp o ty@RCons{} - | eqType o tyRecord = either (asFmt fmt openRecord) (asFmt fmt record) $ rowFields ty - goTypeApp a b = fmtSep fmt [prettyType a fmt,prettyType b fmt] + | eqType o tyRecord = + -- TODO: Rows aren't records -_- + either openRecord record =<< rowFields ty + + goTypeApp a b = fmtSep =<< traverse prettyType [a,b] -- [prettyType a fmt,prettyType b fmt] - rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann] + rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann]) rowFields = \case - RCons _ lbl ty rest -> - let f = ((pretty lbl <::> prettyType ty fmt):) - in bimap (first f) f $ rowFields rest - REmpty _ -> Right [] - KindApp _ REmpty{} _ -> Right [] -- REmpty is sometimes wrapped in a kind app? - TypeVar _ txt -> Left ([],pretty txt) + RCons _ lbl ty rest -> do + fmt <- ask + let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):) + rest' <- rowFields rest + pure $ bimap (first f) f rest' + REmpty _ -> pure $ Right [] + KindApp _ REmpty{} _ -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app? + TypeVar _ txt -> pure $ Left ([],pretty txt) other -> error $ "Malformed row fields: \n" <> show other From cb11738d48fdf4c565dbaa0e50fb9b700b8146c1 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 5 Mar 2024 18:06:44 -0500 Subject: [PATCH 37/44] Final cleanup/tweaks to pretty printer --- src/Language/PureScript/CoreFn/Pretty.hs | 124 ++++++++--------------- 1 file changed, 45 insertions(+), 79 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 4964ad26..268aa7f0 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-} +{-# LANGUAGE TypeApplications, ScopedTypeVariables #-} module Language.PureScript.CoreFn.Pretty ( writeModule, ppType, @@ -53,10 +53,8 @@ import Prettyprinter pipe, comma, punctuate, - enclose, indent, line, - softline, space, vcat, hcat, @@ -75,7 +73,6 @@ import Prettyprinter.Render.Text ( renderIO, renderStrict ) The existing printer is extremely difficult to modify for our needs (e.g. there isn't a clear way to force an expression or type to print on one line). Because reading the CoreFn output is necessary to ensure correctness, it's important that we get get something legible. - -} @@ -92,17 +89,17 @@ type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann runPrinter :: LineFormat -> Printer ann -> Doc ann runPrinter fmt p = runReader p fmt -asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann -asFmt fmt f x = case fmt of - OneLine -> asOneLine f x - MultiLine -> asDynamic f x - asOneLine :: Formatter asOneLine p x = runPrinter OneLine (p x) asDynamic :: Formatter asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x)) +onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann +onMultiline f doc = ask >>= \case + OneLine -> pure doc + MultiLine -> pure . f $ doc + ignoreFmt :: Doc ann -> Printer ann ignoreFmt doc = printer doc doc @@ -116,11 +113,6 @@ fmtCat docs = ask >>= \case OneLine -> pure $ hcat docs MultiLine -> pure $ vcat docs -fmtSpacer :: Printer ann -fmtSpacer = ask >>= \case - OneLine -> pure space - MultiLine -> pure softline - fmtIndent :: Doc ann -> Printer ann fmtIndent doc = ask >>= \case OneLine -> pure doc @@ -133,9 +125,8 @@ printer one multi = ask >>= \case withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann withOpenRow l r (fields,open) = do - spacer <- fmtSpacer - fmtFields <- fmtSep $ punctuate comma fields' - pure . group . align $ enclose (l <> spacer) (spacer <> r) fmtFields + fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields') + group . align <$> fmtSep [l,fmtFields, r] -- fmtFields where fields' = foldr (\x acc -> case acc of [] -> [hsep [x,pipe <++> open]] @@ -150,30 +141,17 @@ openRecord = withOpenRow lbrace rbrace recordLike :: [Doc ann] -> Printer ann recordLike fields = do - spacer <- fmtSpacer - fields' <- fmtSep $ punctuate comma fields - pure $ enclose (lbrace <> spacer) (space <> rbrace) fields' - -record :: [Doc ann] -> Printer ann -record = recordLike - -object :: [Doc ann] -> Printer ann -object = recordLike + fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields) + group . align <$> fmtSep [lbrace,fields',rbrace] commaSep :: [Doc ann] -> Doc ann commaSep = vsep . punctuate comma -indent' :: Int -> Doc ann -> Doc ann -indent' i doc = group . align $ flatAlt (indent i doc) doc - -parens' :: Doc ann -> Doc ann -parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d - - -- TODO: Remove ppType :: Show a => Int -> Type a -> String -ppType i t = prettyTypeStr t +ppType _ t = prettyTypeStr t +-- TODO: Move to modules where types are defined instance Pretty Ident where pretty = pretty . showIdent @@ -253,36 +231,31 @@ prettyUpdateEntry key val = do -- | Pretty-print an expression prettyValue :: Expr a -> Printer ann -- prettyValue _ | d < 0 = text "..." -prettyValue (Accessor _ ty prop val) = do +prettyValue (Accessor _ _ prop val) = do prop' <- prettyObjectKey prop val' <- prettyValueAtom val fmtCat [val',hcat[dot,prop']] -prettyValue (ObjectUpdate ann _ty o _copyFields ps) = do +prettyValue (ObjectUpdate _ _ty o _copyFields ps) = do obj <- prettyValueAtom o updateEntries <- traverse goUpdateEntry ps >>= recordLike pure $ obj <+> updateEntries -- prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt where goUpdateEntry = uncurry prettyUpdateEntry -prettyValue app@(App ann ty val arg) = case analyzeApp app of +prettyValue app@(App _ _ _ _) = case analyzeApp app of Just (fun,args) -> ask >>= \case OneLine -> pure . group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args) Nothing -> error "App isn't an App (impossible)" -prettyValue (Abs ann ty arg val) = do +prettyValue (Abs _ ty arg val) = do ty' <- prettyType (getFunArgTy ty) body' <- fmtIndent =<< prettyValue val pure $ lam <> parens (align $ pretty (showIdent arg) <:> ty') <+> arrow <+> body' - {- lam - <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt) - <+> arrow - <+> fmtIndent fmt (asFmt fmt prettyValue val) - -} -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) -prettyValue (Case ann ty values binders) = pure $ +prettyValue (Case _ _ values binders) = pure $ "case" <+> group (hsep scrutinees) <+> "of" @@ -296,15 +269,20 @@ prettyValue (Let _ _ ds val) = pure . align $ vcat [ indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, "in" <+> align (asDynamic prettyValue val) ] -prettyValue (Literal _ ty l) = ask >>= \case {OneLine -> pure oneLine; MultiLine -> pure multiLine} +prettyValue (Literal _ ty l) = ask >>= \case {OneLine -> oneLine; MultiLine -> multiLine} where - oneLine = parens $ hcat [ - asOneLine prettyLiteralValue l, - colon, - space, - asOneLine prettyType ty - ] - multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty + -- No type anns for object literals (already annotated in the fields, makes too ugly) + oneLine = case l of + ObjectLiteral{} -> prettyLiteralValue l + _ -> pure . parens $ hcat [ + asOneLine prettyLiteralValue l, + colon, + space, + asOneLine prettyType ty + ] + multiLine = case l of + ObjectLiteral{} -> prettyLiteralValue l + _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty prettyValue expr@Constructor{} = prettyValueAtom expr prettyValue expr@Var{} = prettyValueAtom expr @@ -312,7 +290,7 @@ prettyValue expr@Var{} = prettyValueAtom expr prettyValueAtom :: Expr a -> Printer ann prettyValueAtom (Literal _ _ l) = prettyLiteralValue l prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name -prettyValueAtom (Var ann ty ident) = prettyType ty >>= \ty' -> +prettyValueAtom (Var _ ty ident) = prettyType ty >>= \ty' -> pure . parens $ pretty (showIdent (disqualify ident)) <:> ty' prettyValueAtom expr = parens <$> prettyValue expr @@ -330,7 +308,6 @@ prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps prettyDeclaration :: forall a ann. Bind a -> Printer ann --- REVIEW: Maybe we don't want to ignore the format? prettyDeclaration b = case b of NonRec _ ident expr -> goBind ident expr Rec bindings -> vcat <$> traverse (\((_,ident),expr) -> goBind ident expr) bindings @@ -351,11 +328,10 @@ prettyDeclaration b = case b of pure $ group $ flatAlt (f ind) (f id) prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann --- prettyCaseAlternative d _ | d < 0 = ellipsis prettyCaseAlternative (CaseAlternative binders result) = do - binders' <- traverse prettyBinderAtom binders + let binders' = asOneLine prettyBinderAtom <$> binders result' <- prettyResult result - pure $ hsep binders' <> result' -- hsep (asFmt fmt prettyBinderAtom <$> binders) <> prettyResult result + pure $ hsep binders' <> result' where prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann prettyResult = \case @@ -363,7 +339,6 @@ prettyCaseAlternative (CaseAlternative binders result) = do Right exp' -> do body' <- prettyValue exp' >>= fmtIndent pure $ space <> arrow <+> body' - -- space <> arrow <+> fmtIndent fmt (prettyValue exp' fmt) prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann prettyGuardedValueSep' (guardE, resultE) = do @@ -371,10 +346,9 @@ prettyCaseAlternative (CaseAlternative binders result) = do resultE' <- prettyValue resultE pure $ " | " <> guardE' <+> arrow <+> resultE' - prettyModule :: Module a -> Doc ann -prettyModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = - vsep $ +prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) = + vsep [ pretty modName <+> parens (pretty modPath) , "Imported Modules: " , indent 2 . commaSep $ pretty . snd <$> modImports @@ -427,7 +401,7 @@ prettyLiteralBinder (CharLiteral c) = pure $ viaShow c prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num prettyLiteralBinder (BooleanLiteral True) = pure "true" prettyLiteralBinder (BooleanLiteral False) = pure "false" -prettyLiteralBinder (ObjectLiteral bs) = object =<< traverse prettyObjectPropertyBinder bs +prettyLiteralBinder (ObjectLiteral bs) = recordLike =<< traverse prettyObjectPropertyBinder bs where prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann prettyObjectPropertyBinder (key, binder) = do @@ -436,9 +410,6 @@ prettyLiteralBinder (ObjectLiteral bs) = object =<< traverse prettyObjectProper pure $ key' <:> binder' prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs --- | --- Generate a pretty-printed string representing a Binder --- prettyBinder :: Binder a -> Printer ann prettyBinder (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) prettyBinder (ConstructorBinder _ _ ctor args) = do @@ -446,9 +417,7 @@ prettyBinder (ConstructorBinder _ _ ctor args) = do pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) prettyBinder b = prettyBinderAtom b - {- TYPES (move later) -} - prettyType :: forall a ann. Show a => Type a -> Printer ann prettyType t = group <$> case t of TUnknown _ n -> pure $ "t" <> pretty n @@ -465,11 +434,11 @@ prettyType t = group <$> case t of TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName - TypeOp a opName -> pure . pretty $ showQualified runOpName opName + TypeOp _ opName -> pure . pretty $ showQualified runOpName opName TypeApp _ t1 t2 -> goTypeApp t1 t2 - KindApp a k1 k2 -> do + KindApp _ k1 k2 -> do k1' <- prettyType k1 k2' <- prettyType k2 pure $ k1' <> ("@" <> k2' ) @@ -477,22 +446,22 @@ prettyType t = group <$> case t of ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner - ConstrainedType _ constraint inner -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)" + ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)" - Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" + Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" REmpty _ -> pure "{}" rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons -- this might be backwards - KindedType a ty kind -> do + KindedType _ ty kind -> do ty' <- prettyType ty kind' <- prettyType kind pure . parens $ ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt -- not sure what this is? - BinaryNoParensType a op l r -> do + BinaryNoParensType _ op l r -> do l' <- prettyType l op' <- prettyType op r' <- prettyType r @@ -530,17 +499,14 @@ prettyType t = group <$> case t of a' <- prettyType a b' <- prettyType b fmtSep [a' <+> arrow,b'] - -- fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt] | otherwise = do f' <- goTypeApp f a b' <- prettyType b pure $ parens $ f' <+> b' goTypeApp o ty@RCons{} | eqType o tyRecord = - -- TODO: Rows aren't records -_- - either openRecord record =<< rowFields ty - - goTypeApp a b = fmtSep =<< traverse prettyType [a,b] -- [prettyType a fmt,prettyType b fmt] + either openRecord recordLike =<< rowFields ty + goTypeApp a b = fmtSep =<< traverse prettyType [a,b] rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann]) rowFields = \case @@ -550,6 +516,6 @@ prettyType t = group <$> case t of rest' <- rowFields rest pure $ bimap (first f) f rest' REmpty _ -> pure $ Right [] - KindApp _ REmpty{} _ -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app? + KindApp _ REmpty{} _ -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app TypeVar _ txt -> pure $ Left ([],pretty txt) other -> error $ "Malformed row fields: \n" <> show other From d295a011208f083f2bbb977987f1c4bb994bec5c Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 5 Mar 2024 19:06:07 -0500 Subject: [PATCH 38/44] Module-ized prettyprinter + some small tweaks --- purescript.cabal | 3 + src/Language/PureScript/CoreFn/Pretty.hs | 488 +----------------- .../PureScript/CoreFn/Pretty/Common.hs | 201 ++++++++ src/Language/PureScript/CoreFn/Pretty/Expr.hs | 261 ++++++++++ .../PureScript/CoreFn/Pretty/Types.hs | 135 +++++ 5 files changed, 620 insertions(+), 468 deletions(-) create mode 100644 src/Language/PureScript/CoreFn/Pretty/Common.hs create mode 100644 src/Language/PureScript/CoreFn/Pretty/Expr.hs create mode 100644 src/Language/PureScript/CoreFn/Pretty/Types.hs diff --git a/purescript.cabal b/purescript.cabal index 4b57b9f7..6fed7b2a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -252,6 +252,9 @@ library Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Optimizer Language.PureScript.CoreFn.Pretty + Language.PureScript.CoreFn.Pretty.Common + Language.PureScript.CoreFn.Pretty.Expr + Language.PureScript.CoreFn.Pretty.Types Language.PureScript.CoreFn.ToJSON Language.PureScript.CoreFn.Traversals Language.PureScript.CoreImp diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 268aa7f0..bb2af589 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,72 +1,38 @@ -{-# LANGUAGE TypeApplications, ScopedTypeVariables #-} module Language.PureScript.CoreFn.Pretty ( - writeModule, + module PRETTY, ppType, - prettyTypeStr, + smartRender, + writeModule, + prettyModuleTxt, + renderExpr, renderExprStr, - prettyModuleTxt + prettyTypeStr ) where import Prelude hiding ((<>)) import Data.Text (Text) import Data.Text qualified as T -import Data.Map qualified as M -import Data.Bifunctor (first, Bifunctor (..)) -import Control.Monad.Reader -import Language.PureScript.Environment - ( tyRecord, tyFunction, getFunArgTy ) -import Language.PureScript.CoreFn.Expr - ( exprType, - Guard, - Bind(..), - CaseAlternative(CaseAlternative), - Expr(..) ) -import Language.PureScript.CoreFn.Module ( Module(Module) ) -import Language.PureScript.AST.Literals ( Literal(..) ) -import Language.PureScript.CoreFn.Binders ( Binder(..) ) -import Language.PureScript.Label (Label (..)) -import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified) -import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType) -import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement) import System.IO (Handle) +import Language.PureScript.CoreFn.Expr + ( Expr(..) ) +import Language.PureScript.Types (Type (..)) +import Language.PureScript.CoreFn.Module (Module) + +import Language.PureScript.CoreFn.Pretty.Common as PRETTY +import Language.PureScript.CoreFn.Pretty.Expr as PRETTY +import Language.PureScript.CoreFn.Pretty.Types as PRETTY + import Prettyprinter - ( (<>), - tupled, - layoutSmart, + ( layoutSmart, defaultLayoutOptions, layoutPretty, - list, - viaShow, - colon, - parens, - dot, - brackets, - hardline, - (<+>), - rbrace, - lbrace, - rparen, - lparen, - pipe, - comma, - punctuate, - indent, - line, - space, - vcat, - hcat, - vsep, - hsep, - flatAlt, - align, - group, - Doc, - Pretty(pretty) ) + Doc ) import Prettyprinter.Render.Text ( renderIO, renderStrict ) + {- Rewritten prettyprinter that uses a modern printer library & is less convoluted. We primarily need this for writing the "prettified" CoreFn files for development purposes. @@ -76,295 +42,13 @@ import Prettyprinter.Render.Text ( renderIO, renderStrict ) -} -data LineFormat - = OneLine -- *DEFINITELY* Print on one line, even if doing so exceeds the page width - | MultiLine -- *Possibly* Print multiple lines. - deriving (Show, Eq) - --- TODO: Refactor to reader monad? -type Printer ann = Reader LineFormat (Doc ann) - -type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann - -runPrinter :: LineFormat -> Printer ann -> Doc ann -runPrinter fmt p = runReader p fmt - -asOneLine :: Formatter -asOneLine p x = runPrinter OneLine (p x) - -asDynamic :: Formatter -asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x)) - -onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann -onMultiline f doc = ask >>= \case - OneLine -> pure doc - MultiLine -> pure . f $ doc - -ignoreFmt :: Doc ann -> Printer ann -ignoreFmt doc = printer doc doc - -fmtSep :: [Doc ann] -> Printer ann -fmtSep docs = ask >>= \case - OneLine -> pure $ hsep docs - MultiLine -> pure $ vsep docs - -fmtCat :: [Doc ann] -> Printer ann -fmtCat docs = ask >>= \case - OneLine -> pure $ hcat docs - MultiLine -> pure $ vcat docs - -fmtIndent :: Doc ann -> Printer ann -fmtIndent doc = ask >>= \case - OneLine -> pure doc - MultiLine -> pure $ line <> indent 2 doc - -printer :: Doc ann -> Doc ann -> Printer ann -printer one multi = ask >>= \case - OneLine -> pure one - MultiLine -> pure multi - -withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann -withOpenRow l r (fields,open) = do - fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields') - group . align <$> fmtSep [l,fmtFields, r] -- fmtFields - where - fields' = foldr (\x acc -> case acc of - [] -> [hsep [x,pipe <++> open]] - xs -> x : xs - ) [] fields - -openRow :: ([Doc ann], Doc ann) -> Printer ann -openRow = withOpenRow lparen rparen - -openRecord :: ([Doc ann], Doc ann) -> Printer ann -openRecord = withOpenRow lbrace rbrace - -recordLike :: [Doc ann] -> Printer ann -recordLike fields = do - fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields) - group . align <$> fmtSep [lbrace,fields',rbrace] - -commaSep :: [Doc ann] -> Doc ann -commaSep = vsep . punctuate comma - -- TODO: Remove ppType :: Show a => Int -> Type a -> String ppType _ t = prettyTypeStr t --- TODO: Move to modules where types are defined -instance Pretty Ident where - pretty = pretty . showIdent - -instance Pretty PSString where - pretty = pretty . decodeStringWithReplacement - -instance Pretty ModuleName where - pretty = pretty . runModuleName - -instance Pretty Label where - pretty = pretty . runLabel - -(<:>) :: Doc ann -> Doc ann -> Doc ann -a <:> b = hcat [a,":"] <++> b - -(<::>) :: Doc ann -> Doc ann -> Doc ann -a <::> b = a <++> "::" <++> b - -(<=>) :: Doc ann -> Doc ann -> Doc ann -a <=> b = a <+> "=" <+> b - -() :: Doc ann -> Doc ann -> Doc ann -a b = a <+> hardline <+> b - --- ensures the things being concatenated are always on the same line -(<++>) :: Doc ann -> Doc ann -> Doc ann -a <++> b = hsep [a,b] - -arrow :: Doc ann -arrow = "->" - -lam :: Doc ann -lam = "\\" - -oneLineList :: [Doc ann] -> Doc ann -oneLineList = brackets . hcat . punctuate (comma <> space) - --- helpers to ensure even formatting of applications -analyzeApp :: Expr a -> Maybe (Expr a,[Expr a]) -analyzeApp t = (,appArgs t) <$> appFun t - where - appArgs :: Expr a -> [Expr a] - appArgs (App _ _ t1 t2) = appArgs t1 <> [t2] - appArgs _ = [] - - appFun :: Expr a -> Maybe (Expr a) - appFun (App _ _ t1 _) = go t1 - where - go (App _ _ tx _) = case appFun tx of - Nothing -> Just tx - Just tx' -> Just tx' - go other = Just other - appFun _ = Nothing - - --- Is a printer for consistency mainly -prettyObjectKey :: PSString -> Printer ann -prettyObjectKey = pure . pretty . decodeStringWithReplacement - -prettyObject :: [(PSString, Maybe (Expr a))] -> Printer ann -prettyObject fields = do - fields' <- traverse prettyProperty fields - recordLike fields' - where - prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann - prettyProperty (key, value) = do - key' <- prettyObjectKey key - props' <- maybe (pure $ pretty @Text "_") prettyValue value - pure (key' <:> props') -- prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value - -prettyUpdateEntry :: PSString -> Expr a -> Printer ann -prettyUpdateEntry key val = do - key' <- prettyObjectKey key - val' <- prettyValue val - pure $ key' <=> val' - --- | Pretty-print an expression -prettyValue :: Expr a -> Printer ann --- prettyValue _ | d < 0 = text "..." -prettyValue (Accessor _ _ prop val) = do - prop' <- prettyObjectKey prop - val' <- prettyValueAtom val - fmtCat [val',hcat[dot,prop']] -prettyValue (ObjectUpdate _ _ty o _copyFields ps) = do - obj <- prettyValueAtom o - updateEntries <- traverse goUpdateEntry ps >>= recordLike - pure $ obj <+> updateEntries -- prettyValueAtom o <+> recordLike ( goUpdateEntry <$> ps) fmt - where - goUpdateEntry = uncurry prettyUpdateEntry -prettyValue app@(App _ _ _ _) = case analyzeApp app of - Just (fun,args) -> ask >>= \case - OneLine -> pure . group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) - MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args) - Nothing -> error "App isn't an App (impossible)" - -prettyValue (Abs _ ty arg val) = do - ty' <- prettyType (getFunArgTy ty) - body' <- fmtIndent =<< prettyValue val - pure $ lam - <> parens (align $ pretty (showIdent arg) <:> ty') - <+> arrow - <+> body' --- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) -prettyValue (Case _ _ values binders) = pure $ - "case" - <+> group (hsep scrutinees) - <+> "of" - indent 2 (vcat $ map group branches) - where - scrutinees = asOneLine prettyValueAtom <$> values - branches = group . asDynamic prettyCaseAlternative <$> binders --- technically we could have a one line version of this but that's ugly af -prettyValue (Let _ _ ds val) = pure . align $ vcat [ - "let", - indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, - "in" <+> align (asDynamic prettyValue val) - ] -prettyValue (Literal _ ty l) = ask >>= \case {OneLine -> oneLine; MultiLine -> multiLine} - where - -- No type anns for object literals (already annotated in the fields, makes too ugly) - oneLine = case l of - ObjectLiteral{} -> prettyLiteralValue l - _ -> pure . parens $ hcat [ - asOneLine prettyLiteralValue l, - colon, - space, - asOneLine prettyType ty - ] - multiLine = case l of - ObjectLiteral{} -> prettyLiteralValue l - _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty -prettyValue expr@Constructor{} = prettyValueAtom expr -prettyValue expr@Var{} = prettyValueAtom expr - --- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyValueAtom :: Expr a -> Printer ann -prettyValueAtom (Literal _ _ l) = prettyLiteralValue l -prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name -prettyValueAtom (Var _ ty ident) = prettyType ty >>= \ty' -> - pure . parens $ pretty (showIdent (disqualify ident)) <:> ty' -prettyValueAtom expr = parens <$> prettyValue expr - -prettyLiteralValue :: Literal (Expr a) -> Printer ann -prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n -prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s -prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c -prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true" -prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false" -prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine - where - oneLine = oneLineList $ asOneLine prettyValue <$> xs - -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine - multiLine = list $ asOneLine prettyValue <$> xs -prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps - -prettyDeclaration :: forall a ann. Bind a -> Printer ann -prettyDeclaration b = case b of - NonRec _ ident expr -> goBind ident expr - Rec bindings -> vcat <$> traverse (\((_,ident),expr) -> goBind ident expr) bindings - where - goBind :: Ident -> Expr a -> Printer ann - goBind ident expr = do - inner' <- goInner ident expr - let ty' = asOneLine prettyType (exprType expr) - pure $ - pretty ident <::> ty' - <> hardline - <> inner' - goInner :: Ident -> Expr a -> Printer ann - goInner ident expr = do - fmt <- ask - let ind docs = runReader (fmtIndent docs) fmt - f g = pretty ident <=> g (asDynamic prettyValue expr) - pure $ group $ flatAlt (f ind) (f id) - -prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann -prettyCaseAlternative (CaseAlternative binders result) = do - let binders' = asOneLine prettyBinderAtom <$> binders - result' <- prettyResult result - pure $ hsep binders' <> result' - where - prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann - prettyResult = \case - Left ges -> vcat <$> traverse prettyGuardedValueSep' ges - Right exp' -> do - body' <- prettyValue exp' >>= fmtIndent - pure $ space <> arrow <+> body' - - prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann - prettyGuardedValueSep' (guardE, resultE) = do - guardE' <- prettyValue guardE - resultE' <- prettyValue resultE - pure $ " | " <> guardE' <+> arrow <+> resultE' - -prettyModule :: Module a -> Doc ann -prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) = - vsep - [ pretty modName <+> parens (pretty modPath) - , "Imported Modules: " - , indent 2 . commaSep $ pretty . snd <$> modImports - ,"Exports: " - , indent 2 . commaSep $ pretty <$> modExports -- hang 2? - , "Re-Exports: " - , indent 2 . commaSep $ goReExport <$> M.toList modReExports - , "Foreign: " - , indent 2 . commaSep . map pretty $ modForeign - , "Declarations: " - , vcat . punctuate line $ asDynamic prettyDeclaration <$> modDecls - ] - where - goReExport :: (ModuleName,[Ident]) -> Doc ann - goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i +-- TODO (maybe): It wouldn't be too hard to determine the terminal width and write a +-- display function that prints correctly-formatted-for-the-size smartRender :: Doc ann -> Text smartRender = renderStrict . layoutPretty defaultLayoutOptions @@ -385,137 +69,5 @@ renderExprStr = T.unpack . renderExpr prettyTypeStr :: forall a. Show a => Type a -> String prettyTypeStr = T.unpack . smartRender . asOneLine prettyType -prettyBinderAtom :: Binder a -> Printer ann -prettyBinderAtom (NullBinder _) = pure "_" -prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l -prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident -prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) -prettyBinderAtom b@ConstructorBinder{} = prettyBinder b -prettyBinderAtom (NamedBinder _ ident binder)= do - binder' <- prettyBinder binder - pure $ pretty ident <> "@" <> binder' - -prettyLiteralBinder :: Literal (Binder a) -> Printer ann -prettyLiteralBinder (StringLiteral str) = pure . pretty $ prettyPrintString str -prettyLiteralBinder (CharLiteral c) = pure $ viaShow c -prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num -prettyLiteralBinder (BooleanLiteral True) = pure "true" -prettyLiteralBinder (BooleanLiteral False) = pure "false" -prettyLiteralBinder (ObjectLiteral bs) = recordLike =<< traverse prettyObjectPropertyBinder bs - where - prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann - prettyObjectPropertyBinder (key, binder) = do - key' <- prettyObjectKey key - binder' <- prettyBinder binder - pure $ key' <:> binder' -prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs - -prettyBinder :: Binder a -> Printer ann -prettyBinder (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) -prettyBinder (ConstructorBinder _ _ ctor args) = do - args' <- fmtSep =<< traverse prettyBinderAtom args - pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) -prettyBinder b = prettyBinderAtom b {- TYPES (move later) -} -prettyType :: forall a ann. Show a => Type a -> Printer ann -prettyType t = group <$> case t of - TUnknown _ n -> pure $ "t" <> pretty n - - TypeVar _ txt -> pure $ pretty txt - - TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss - - TypeLevelInt _ i -> pure $ pretty i - - TypeWildcard _ wcd -> case wcd of - HoleWildcard txt -> pure $ "?" <> pretty txt - _ -> pure "_" - - TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName - - TypeOp _ opName -> pure . pretty $ showQualified runOpName opName - - TypeApp _ t1 t2 -> goTypeApp t1 t2 - - KindApp _ k1 k2 -> do - k1' <- prettyType k1 - k2' <- prettyType k2 - pure $ k1' <> ("@" <> k2' ) - - ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of - (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner - - ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)" - - Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" - - REmpty _ -> pure "{}" - - rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons - - -- this might be backwards - KindedType _ ty kind -> do - ty' <- prettyType ty - kind' <- prettyType kind - pure . parens $ ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt - - -- not sure what this is? - BinaryNoParensType _ op l r -> do - l' <- prettyType l - op' <- prettyType op - r' <- prettyType r - pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt <+> prettyType r fmt - - ParensInType _ ty -> parens <$> prettyType ty - where - goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann - goForall xs inner = do - boundVars <- fmtSep =<< traverse renderBoundVar xs - inner' <- prettyType inner - pure $ - "forall" <+> boundVars <> "." <+> inner' - - prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann - prefixVis vis tv = case vis of - TypeVarVisible -> hcat ["@",tv] - TypeVarInvisible -> tv - - renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann - renderBoundVar (vis,var,mk) = case mk of - Just k -> do - ty' <- prettyType k - pure . parens $ prefixVis vis (pretty var) <::> ty' - Nothing -> pure $ prefixVis vis (pretty var) - - stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a) - stripQuantifiers = \case - ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner - other -> ([],other) - - goTypeApp :: Type a -> Type a -> Printer ann - goTypeApp (TypeApp _ f a) b - | eqType f tyFunction = do - a' <- prettyType a - b' <- prettyType b - fmtSep [a' <+> arrow,b'] - | otherwise = do - f' <- goTypeApp f a - b' <- prettyType b - pure $ parens $ f' <+> b' - goTypeApp o ty@RCons{} - | eqType o tyRecord = - either openRecord recordLike =<< rowFields ty - goTypeApp a b = fmtSep =<< traverse prettyType [a,b] - - rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann]) - rowFields = \case - RCons _ lbl ty rest -> do - fmt <- ask - let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):) - rest' <- rowFields rest - pure $ bimap (first f) f rest' - REmpty _ -> pure $ Right [] - KindApp _ REmpty{} _ -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app - TypeVar _ txt -> pure $ Left ([],pretty txt) - other -> error $ "Malformed row fields: \n" <> show other diff --git a/src/Language/PureScript/CoreFn/Pretty/Common.hs b/src/Language/PureScript/CoreFn/Pretty/Common.hs new file mode 100644 index 00000000..0d8628d9 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Pretty/Common.hs @@ -0,0 +1,201 @@ +module Language.PureScript.CoreFn.Pretty.Common where + +import Prelude hiding ((<>)) + +import Control.Monad.Reader ( MonadReader(ask), runReader, Reader ) + +import Language.PureScript.CoreFn.Expr + ( Expr(..) ) +import Language.PureScript.Label (Label (..)) +import Language.PureScript.Names (runModuleName, showIdent, Ident, ModuleName) +import Language.PureScript.PSString (PSString, decodeStringWithReplacement) + +import Prettyprinter + ( (<>), + brackets, + hardline, + (<+>), + rbrace, + lbrace, + rparen, + lparen, + pipe, + comma, + punctuate, + indent, + line, + space, + vcat, + hcat, + vsep, + hsep, + flatAlt, + align, + group, + Doc, + Pretty(pretty) ) + +{- One thing that we often wish to do, but cannot easily do either with + the Prettyprinter library or the ancient lib PureScript uses, is to + *force* particular sub-expressions to print on a single line. + + (`Prettyprinter.group` does give us the ability to express: "Try to + print this on one line, but if you can't, use the multi-line format", and we + use that when choosing between one- and multi-line formats.) + + This gives us a nice little abstraction for convenient auto-formatting + (single line/multi line) where we want it, while also giving us the ability to + override particular locations in the AST that we want to force to one-line (e.g. case + expression binders, applied types, etc). +-} +data LineFormat + = OneLine -- *DEFINITELY* Print on one line, even if doing so exceeds the page width + | MultiLine -- *Possibly* Print multiple lines. + deriving (Show, Eq) + +-- A document with a structure that depends on a formatting context +type Printer ann = Reader LineFormat (Doc ann) + +-- Convenience type +type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann + +-- runReader with flipped arguments (how it should be!) +runPrinter :: LineFormat -> Printer ann -> Doc ann +runPrinter fmt p = runReader p fmt + +asOneLine :: Formatter +asOneLine p x = runPrinter OneLine (p x) + +-- Helper for dynamic formatting. `asMultiLine` doesn't make sense (we always want to choose +-- between single and multiline formats in a context where we aren't forcing a one-line format) +asDynamic :: Formatter +asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x)) + +-- Applies the supplied function to the Doc if we're in a Multiline context. +-- Primarily used for correct formatting of Records/Rows/Objects +onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann +onMultiline f doc = ask >>= \case + OneLine -> pure doc + MultiLine -> pure . f $ doc + +-- For docs w/ a structure that does not vary based on the line format options +-- Used primarily for `let` expressions (where we want uniformity) +ignoreFmt :: Doc ann -> Printer ann +ignoreFmt doc = printer doc doc + +-- Choose between hsep and vsep based on the context +fmtSep :: [Doc ann] -> Printer ann +fmtSep docs = ask >>= \case + OneLine -> pure $ hsep docs + MultiLine -> pure $ vsep docs + +-- Choose between hcat and vcat based on the context +fmtCat :: [Doc ann] -> Printer ann +fmtCat docs = ask >>= \case + OneLine -> pure $ hcat docs + MultiLine -> pure $ vcat docs + +-- Choose between newline + indent or no change, depending on the context. +-- NOTE: This is kind of the whole reason we need LineFormat + the Reader monad. +-- `group` isn't sufficient here +fmtIndent :: Doc ann -> Printer ann +fmtIndent doc = ask >>= \case + OneLine -> pure doc + MultiLine -> pure $ line <> indent 2 doc + +-- Helper function for constructing a printer expr +printer :: Doc ann -> Doc ann -> Printer ann +printer one multi = ask >>= \case + OneLine -> pure one + MultiLine -> pure multi + +{- Higher-order Printers for Row Types, Record Types, and Object lits -} + +-- Helper for open rows. The `| r` part requires special handling. +withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann +withOpenRow l r (fields,open) = do + fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields') + group . align <$> fmtSep [l,fmtFields, r] -- fmtFields + where + fields' = foldr (\x acc -> case acc of + [] -> [hsep [x,pipe <+> open]] + xs -> x : xs + ) [] fields + +openRow :: ([Doc ann], Doc ann) -> Printer ann +openRow = withOpenRow lparen rparen + +openRecord :: ([Doc ann], Doc ann) -> Printer ann +openRecord = withOpenRow lbrace rbrace + +-- Printer for record like things (Object literals, record types) +recordLike :: [Doc ann] -> Printer ann +recordLike fields = do + fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields) + group . align <$> fmtSep [lbrace,fields',rbrace] + +{- Misc Utils and custom combinators. + Most of these are just for readability. (a <:> type), + to me anyway, is a lot easier on the eyes than + (a <> ":" <> space <> type) +-} +commaSep :: [Doc ann] -> Doc ann +commaSep = vsep . punctuate comma + +-- Our "special" type annotations are indicated w/ a single colon. +(<:>) :: Doc ann -> Doc ann -> Doc ann +a <:> b = hcat [a,":"] <+> b + +-- Actual type annotations & signatures (that are in the source explicitly or +-- inferred by the compiler before we get the AST) are indicated in the normal way, +-- that is, with '::' +(<::>) :: Doc ann -> Doc ann -> Doc ann +a <::> b = a <+> "::" <+> b + +(<=>) :: Doc ann -> Doc ann -> Doc ann +a <=> b = a <+> "=" <+> b + +-- Forces a line break. Shouldn't be used except in cases where we want to ignore +-- the dynamic formatting (e.g. case expressions) +() :: Doc ann -> Doc ann -> Doc ann +a b = a <+> hardline <+> b + +arrow :: Doc ann +arrow = "->" + +lam :: Doc ann +lam = "\\" + +-- Like `list` but forces one line format. +oneLineList :: [Doc ann] -> Doc ann +oneLineList = brackets . hcat . punctuate (comma <> space) + +-- Splits an `App` expr into a function/ctor and a list of arguments. +analyzeApp :: Expr a -> Maybe (Expr a,[Expr a]) +analyzeApp t = (,appArgs t) <$> appFun t + where + appArgs :: Expr a -> [Expr a] + appArgs (App _ _ t1 t2) = appArgs t1 <> [t2] + appArgs _ = [] + + appFun :: Expr a -> Maybe (Expr a) + appFun (App _ _ t1 _) = go t1 + where + go (App _ _ tx _) = case appFun tx of + Nothing -> Just tx + Just tx' -> Just tx' + go other = Just other + appFun _ = Nothing + +-- TODO: Move to modules where types are defined +instance Pretty Ident where + pretty = pretty . showIdent + +instance Pretty PSString where + pretty = pretty . decodeStringWithReplacement + +instance Pretty ModuleName where + pretty = pretty . runModuleName + +instance Pretty Label where + pretty = pretty . runLabel diff --git a/src/Language/PureScript/CoreFn/Pretty/Expr.hs b/src/Language/PureScript/CoreFn/Pretty/Expr.hs new file mode 100644 index 00000000..b692092e --- /dev/null +++ b/src/Language/PureScript/CoreFn/Pretty/Expr.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE TypeApplications, ScopedTypeVariables #-} +module Language.PureScript.CoreFn.Pretty.Expr where + + +import Prelude hiding ((<>)) + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Map qualified as M +import Data.Bifunctor (Bifunctor (..)) +import Control.Monad.Reader ( MonadReader(ask), runReader ) + +import Language.PureScript.Environment + ( getFunArgTy ) +import Language.PureScript.CoreFn.Expr + ( exprType, + Guard, + Bind(..), + CaseAlternative(CaseAlternative), + Expr(..) ) +import Language.PureScript.CoreFn.Module ( Module(Module) ) +import Language.PureScript.AST.Literals ( Literal(..) ) +import Language.PureScript.CoreFn.Binders ( Binder(..) ) +import Language.PureScript.Names (ProperName(..), disqualify, showIdent, Ident, ModuleName) +import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement) + +import Prettyprinter + ( (<>), + list, + viaShow, + colon, + parens, + dot, + hardline, + (<+>), + punctuate, + indent, + line, + space, + vcat, + hcat, + vsep, + hsep, + flatAlt, + align, + group, + Doc, + Pretty(pretty) ) +import Language.PureScript.CoreFn.Pretty.Common + ( Printer, + LineFormat(MultiLine, OneLine), + asOneLine, + asDynamic, + ignoreFmt, + fmtSep, + fmtCat, + fmtIndent, + printer, + recordLike, + commaSep, + (<:>), + (<::>), + (<=>), + (), + arrow, + lam, + oneLineList, + analyzeApp ) +import Language.PureScript.CoreFn.Pretty.Types ( prettyType ) + + +prettyModule :: Module a -> Doc ann +prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) = + vsep + [ pretty modName <+> parens (pretty modPath) + , "Imported Modules: " + , indent 2 . commaSep $ pretty . snd <$> modImports + ,"Exports: " + , indent 2 . commaSep $ pretty <$> modExports -- hang 2? + , "Re-Exports: " + , indent 2 . commaSep $ goReExport <$> M.toList modReExports + , "Foreign: " + , indent 2 . commaSep . map pretty $ modForeign + , "Declarations: " + , vcat . punctuate line $ asDynamic prettyDeclaration <$> modDecls + ] + where + goReExport :: (ModuleName,[Ident]) -> Doc ann + goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i + +-- Is a printer for consistency mainly +prettyObjectKey :: PSString -> Printer ann +prettyObjectKey = pure . pretty . decodeStringWithReplacement + +prettyObject :: [(PSString, Maybe (Expr a))] -> Printer ann +prettyObject fields = do + fields' <- traverse prettyProperty fields + recordLike fields' + where + prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann + prettyProperty (key, value) = do + key' <- prettyObjectKey key + props' <- maybe (pure $ pretty @Text "_") prettyValue value + pure (key' <:> props') + +prettyUpdateEntry :: PSString -> Expr a -> Printer ann +prettyUpdateEntry key val = do + key' <- prettyObjectKey key + val' <- prettyValue val + pure $ key' <=> val' + +-- | Pretty-print an expression +prettyValue :: Expr a -> Printer ann +prettyValue (Accessor _ _ prop val) = do + prop' <- prettyObjectKey prop + val' <- prettyValueAtom val + fmtCat [val',hcat[dot,prop']] +prettyValue (ObjectUpdate _ _ty o _copyFields ps) = do + obj <- prettyValueAtom o + updateEntries <- traverse goUpdateEntry ps >>= recordLike + pure $ obj <+> updateEntries + where + goUpdateEntry = uncurry prettyUpdateEntry +prettyValue app@(App _ _ _ _) = case analyzeApp app of + Just (fun,args) -> ask >>= \case + OneLine -> pure . group . align . hsep . map (asOneLine prettyValueAtom) $ (fun:args) + MultiLine -> pure . group . align . vsep . map (asDynamic prettyValueAtom) $ (fun:args) + Nothing -> error "App isn't an App (impossible)" +prettyValue (Abs _ ty arg val) = do + ty' <- prettyType (getFunArgTy ty) + body' <- fmtIndent =<< prettyValue val + pure $ lam + <> parens (align $ pretty (showIdent arg) <:> ty') + <+> arrow + <+> body' +-- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?) +prettyValue (Case _ _ values binders) = pure $ + "case" + <+> group (hsep scrutinees) + <+> "of" + indent 2 (vcat $ map group branches) + where + scrutinees = asOneLine prettyValueAtom <$> values + branches = group . asDynamic prettyCaseAlternative <$> binders +-- technically we could have a one line version of this but that's ugly af imo +prettyValue (Let _ _ ds val) = pure . align $ vcat [ + "let", + indent 2 . vcat $ asDynamic prettyDeclaration <$> ds, + "in" <+> align (asDynamic prettyValue val) + ] +prettyValue (Literal _ ty l) = ask >>= \case {OneLine -> oneLine; MultiLine -> multiLine} + where + -- No type anns for object literals (already annotated in the fields, makes too ugly) + oneLine = case l of + ObjectLiteral{} -> prettyLiteralValue l + _ -> pure . parens $ hcat [ + asOneLine prettyLiteralValue l, + colon, + space, + asOneLine prettyType ty + ] + multiLine = case l of + ObjectLiteral{} -> prettyLiteralValue l + _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty +prettyValue expr@Constructor{} = prettyValueAtom expr +prettyValue expr@Var{} = prettyValueAtom expr + +-- | Pretty-print an atomic expression, adding parentheses if necessary. +prettyValueAtom :: Expr a -> Printer ann +prettyValueAtom (Literal _ _ l) = prettyLiteralValue l +prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name +prettyValueAtom (Var _ ty ident) = prettyType ty >>= \ty' -> + pure . parens $ pretty (showIdent (disqualify ident)) <:> ty' +prettyValueAtom expr = parens <$> prettyValue expr + +prettyLiteralValue :: Literal (Expr a) -> Printer ann +prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n +prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s +prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c +prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true" +prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false" +prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine + where + oneLine = oneLineList $ asOneLine prettyValue <$> xs + -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine + multiLine = list $ asOneLine prettyValue <$> xs +prettyLiteralValue (ObjectLiteral ps) = prettyObject $ second Just `map` ps + +prettyDeclaration :: forall a ann. Bind a -> Printer ann +prettyDeclaration b = case b of + NonRec _ ident expr -> goBind ident expr + Rec bindings -> vcat <$> traverse (\((_,ident),expr) -> goBind ident expr) bindings + where + goBind :: Ident -> Expr a -> Printer ann + goBind ident expr = do + inner' <- goInner ident expr + let ty' = asOneLine prettyType (exprType expr) + pure $ + pretty ident <::> ty' + <> hardline + <> inner' + goInner :: Ident -> Expr a -> Printer ann + goInner ident expr = do + fmt <- ask + let ind docs = runReader (fmtIndent docs) fmt + f g = pretty ident <=> g (asDynamic prettyValue expr) + pure $ group $ flatAlt (f ind) (f id) + +prettyCaseAlternative :: forall a ann. CaseAlternative a -> Printer ann +prettyCaseAlternative (CaseAlternative binders result) = do + let binders' = asOneLine prettyBinderAtom <$> binders + result' <- prettyResult result + pure $ hsep binders' <> result' + where + prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann + prettyResult = \case + Left ges -> vcat <$> traverse prettyGuardedValueSep' ges + Right exp' -> do + body' <- prettyValue exp' >>= fmtIndent + pure $ space <> arrow <+> body' + + prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann + prettyGuardedValueSep' (guardE, resultE) = do + guardE' <- prettyValue guardE + resultE' <- prettyValue resultE + pure $ " | " <> guardE' <+> arrow <+> resultE' + + + + +prettyBinderAtom :: Binder a -> Printer ann +prettyBinderAtom (NullBinder _) = pure "_" +prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l +prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident +prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) +prettyBinderAtom b@ConstructorBinder{} = prettyBinder b +prettyBinderAtom (NamedBinder _ ident binder)= do + binder' <- prettyBinder binder + pure $ pretty ident <> "@" <> binder' + +prettyLiteralBinder :: Literal (Binder a) -> Printer ann +prettyLiteralBinder (StringLiteral str) = pure . pretty $ prettyPrintString str +prettyLiteralBinder (CharLiteral c) = pure $ viaShow c +prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num +prettyLiteralBinder (BooleanLiteral True) = pure "true" +prettyLiteralBinder (BooleanLiteral False) = pure "false" +prettyLiteralBinder (ObjectLiteral bs) = recordLike =<< traverse prettyObjectPropertyBinder bs + where + prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann + prettyObjectPropertyBinder (key, binder) = do + key' <- prettyObjectKey key + binder' <- prettyBinder binder + pure $ key' <:> binder' +prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs + +prettyBinder :: Binder a -> Printer ann +prettyBinder (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor) +prettyBinder (ConstructorBinder _ _ ctor args) = do + args' <- fmtSep =<< traverse prettyBinderAtom args + pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args) +prettyBinder b = prettyBinderAtom b diff --git a/src/Language/PureScript/CoreFn/Pretty/Types.hs b/src/Language/PureScript/CoreFn/Pretty/Types.hs new file mode 100644 index 00000000..b172ea11 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Pretty/Types.hs @@ -0,0 +1,135 @@ +module Language.PureScript.CoreFn.Pretty.Types where + +import Prelude hiding ((<>)) + +import Data.Text (Text) +import Data.Bifunctor (first, Bifunctor (..)) +import Control.Monad.Reader ( MonadReader(ask), Reader ) + +import Language.PureScript.Environment + ( tyRecord, tyFunction ) +import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, showQualified) +import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType) +import Language.PureScript.PSString (prettyPrintString) + +import Prettyprinter + ( (<>), + tupled, + parens, + (<+>), + hcat, + group, + Doc, + Pretty(pretty) ) +import Language.PureScript.CoreFn.Pretty.Common + ( Printer, + LineFormat, + runPrinter, + fmtSep, + openRow, + openRecord, + recordLike, + (<::>), + arrow ) + +prettyType :: forall a ann. Show a => Type a -> Printer ann +prettyType t = group <$> case t of + TUnknown _ n -> pure $ "t" <> pretty n + + TypeVar _ txt -> pure $ pretty txt + + TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss + + TypeLevelInt _ i -> pure $ pretty i + + TypeWildcard _ wcd -> case wcd of + HoleWildcard txt -> pure $ "?" <> pretty txt + _ -> pure "_" + + TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName + + TypeOp _ opName -> pure . pretty $ showQualified runOpName opName + + TypeApp _ t1 t2 -> goTypeApp t1 t2 + + KindApp _ k1 k2 -> do + k1' <- prettyType k1 + k2' <- prettyType k2 + pure $ k1' <> ("@" <> k2' ) + + ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of + (quantified,inner) -> goForall ([(vis,var,mKind)] <> quantified) inner + + ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)" + + Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)" + + REmpty _ -> pure "{}" + + rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons + + -- this might be backwards + KindedType _ ty kind -> do + ty' <- prettyType ty + kind' <- prettyType kind + pure . parens $ ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt + + -- not sure what this is? + BinaryNoParensType _ op l r -> do + l' <- prettyType l + op' <- prettyType op + r' <- prettyType r + pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt <+> prettyType r fmt + + ParensInType _ ty -> parens <$> prettyType ty + where + goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann + goForall xs inner = do + boundVars <- fmtSep =<< traverse renderBoundVar xs + inner' <- prettyType inner + pure $ + "forall" <+> boundVars <> "." <+> inner' + + prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann + prefixVis vis tv = case vis of + TypeVarVisible -> hcat ["@",tv] + TypeVarInvisible -> tv + + renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann + renderBoundVar (vis,var,mk) = case mk of + Just k -> do + ty' <- prettyType k + pure . parens $ prefixVis vis (pretty var) <::> ty' + Nothing -> pure $ prefixVis vis (pretty var) + + stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a) + stripQuantifiers = \case + ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner + other -> ([],other) + + goTypeApp :: Type a -> Type a -> Printer ann + goTypeApp (TypeApp _ f a) b + | eqType f tyFunction = do + a' <- prettyType a + b' <- prettyType b + fmtSep [a' <+> arrow,b'] + | otherwise = do + f' <- goTypeApp f a + b' <- prettyType b + pure $ parens $ f' <+> b' + goTypeApp o ty@RCons{} + | eqType o tyRecord = + either openRecord recordLike =<< rowFields ty + goTypeApp a b = fmtSep =<< traverse prettyType [a,b] + + rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann]) + rowFields = \case + RCons _ lbl ty rest -> do + fmt <- ask + let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):) + rest' <- rowFields rest + pure $ bimap (first f) f rest' + REmpty _ -> pure $ Right [] + KindApp _ REmpty{} _ -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app + TypeVar _ txt -> pure $ Left ([],pretty txt) + other -> error $ "Malformed row fields: \n" <> show other From ae4f7030bdc9c834ec64daf5cf35396d38bbaa48 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 12:52:49 -0700 Subject: [PATCH 39/44] Nix setup --- .gitignore | 3 + cabal.project | 4 + default.nix | 20 + flake.lock | 813 +++++++++++++++++++++++++++++++++++++ flake.nix | 107 +++++ fourmolu.yaml | 8 + nix/fourmolu/default.nix | 13 + nix/haskell/default.nix | 36 ++ nix/haskell/lib.nix | 91 +++++ nix/haskell/mk-hackage.nix | 132 ++++++ nix/plutarch/default.nix | 28 ++ nix/plutarch/lib.nix | 44 ++ nix/utils/default.nix | 22 + nix/utils/lib.nix | 39 ++ purescript.cabal | 2 +- shell.nix | 21 - 16 files changed, 1361 insertions(+), 22 deletions(-) create mode 100644 default.nix create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 fourmolu.yaml create mode 100644 nix/fourmolu/default.nix create mode 100644 nix/haskell/default.nix create mode 100644 nix/haskell/lib.nix create mode 100644 nix/haskell/mk-hackage.nix create mode 100644 nix/plutarch/default.nix create mode 100644 nix/plutarch/lib.nix create mode 100644 nix/utils/default.nix create mode 100644 nix/utils/lib.nix delete mode 100644 shell.nix diff --git a/.gitignore b/.gitignore index 0454beff..9b55e739 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,6 @@ TAGS *.ps *.svg tests/purs/make/ +.direnv/ +/.pre-commit-config.yaml +/result* diff --git a/cabal.project b/cabal.project index aa859b8b..29ca61bc 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,7 @@ repository cardano-haskell-packages packages: purescript.cabal + +-- HACK: plutus core cannot build without it, remove after bump. +constraints: + nothunks < 0.2 diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..83f611fb --- /dev/null +++ b/default.nix @@ -0,0 +1,20 @@ +{ + perSystem = { self', config, ... }: + let + purus = config.libPlutarch.mkPackage { + name = "purus"; + src = ./.; + }; + in + { + devShells.purus = purus.devShell; + + packages = { + purs = purus.packages."purescript:exe:purs"; + }; + + apps = { + purs.program = "${self'.packages.purs}/bin/purs"; + }; + }; +} diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..34d0f876 --- /dev/null +++ b/flake.lock @@ -0,0 +1,813 @@ +{ + "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-compat_2": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-parts": { + "inputs": { + "nixpkgs-lib": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1706830856, + "narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1701680307, + "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc98X": { + "flake": false, + "locked": { + "lastModified": 1696643148, + "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", + "ref": "ghc-9.8", + "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", + "revCount": 61642, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "ref": "ghc-9.8", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc99": { + "flake": false, + "locked": { + "lastModified": 1701580282, + "narHash": "sha256-drA01r3JrXnkKyzI+owMZGxX0JameMzjK0W5jJE/+V4=", + "ref": "refs/heads/master", + "rev": "f5eb0f2982e9cf27515e892c4bdf634bcfb28459", + "revCount": 62197, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "pre-commit-hooks-nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1703887061, + "narHash": "sha256-gGPa9qWNc6eCXT/+Z5/zMkyYOuRZqeFZBDbopNZQkuY=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "43e1aa1308018f37118e34d3a9cb4f5e75dc11d5", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1708215850, + "narHash": "sha256-jaxFHCObJ3uON5RNbeon795RmBG/SUFcFM77TAxx3hg=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "f5c26f4307f80cdc8ba7b762e0738c09d40a4685", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskell-nix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc98X": "ghc98X", + "ghc99": "ghc99", + "hackage": "hackage", + "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", + "iserv-proxy": "iserv-proxy", + "nix-tools-static": "nix-tools-static", + "nixpkgs": [ + "haskell-nix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-2111": "nixpkgs-2111", + "nixpkgs-2205": "nixpkgs-2205", + "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1708217408, + "narHash": "sha256-Ri9PXSAvg25bBvcJOCTsi6pRhaT8Wp37037KMfXYeOU=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "2fb6466a23873e590ef96066ee18a75998830c7b", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hci-effects": { + "inputs": { + "flake-parts": [ + "flake-parts" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1704029560, + "narHash": "sha256-a4Iu7x1OP+uSYpqadOu8VCPY+MPF3+f6KIi+MAxlgyw=", + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "rev": "d5cbf433a6ae9cae05400189a8dbc6412a03ba16", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "type": "github" + } + }, + "hls-1.10": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "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" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskell-nix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1691634696, + "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", + "ref": "hkm/remote-iserv", + "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", + "revCount": 14, + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + }, + "original": { + "ref": "hkm/remote-iserv", + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + } + }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1661606874, + "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", + "owner": "NixOS", + "repo": "nix", + "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.11.0", + "repo": "nix", + "type": "github" + } + }, + "nix-tools-static": { + "flake": false, + "locked": { + "lastModified": 1706266250, + "narHash": "sha256-9t+GRk3eO9muCtKdNAwBtNBZ5dH1xHcnS17WaQyftwA=", + "owner": "input-output-hk", + "repo": "haskell-nix-example", + "rev": "580cb6db546a7777dad3b9c0fa487a366c045c4e", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "nix", + "repo": "haskell-nix-example", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1657693803, + "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-22.05-small", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1659914493, + "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1659446231, + "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2205": { + "locked": { + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2211": { + "locked": { + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "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": { + "locked": { + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1708276637, + "narHash": "sha256-+gICdImzDvxULC/+iqsmLsvwEv5LQuFglxn2fk/VyQM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ec841889d30aabad381acfa9529fe6045268bdbd", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "pre-commit-hooks-nix": { + "inputs": { + "flake-compat": "flake-compat_2", + "flake-utils": "flake-utils", + "gitignore": "gitignore", + "nixpkgs": [ + "nixpkgs" + ], + "nixpkgs-stable": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1708018599, + "narHash": "sha256-M+Ng6+SePmA8g06CmUZWi1AjG2tFBX9WCXElBHEKnyM=", + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "rev": "5df5a70ad7575f6601d91f0efec95dd9bc619431", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-parts": "flake-parts", + "haskell-nix": "haskell-nix", + "hci-effects": "hci-effects", + "nixpkgs": "nixpkgs_2", + "pre-commit-hooks-nix": "pre-commit-hooks-nix" + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1708214991, + "narHash": "sha256-PCVnVqnBctf/qkpTBnBxwDHvfZaxXeq0bO98LxoKfhY=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "0a279134ea4ae6269b93f76638c4ed9ccd9a496a", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..dbd6c47f --- /dev/null +++ b/flake.nix @@ -0,0 +1,107 @@ +{ + description = "uplc-benchmark"; + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs"; + flake-parts = { + url = "github:hercules-ci/flake-parts"; + inputs.nixpkgs-lib.follows = "nixpkgs"; + }; + pre-commit-hooks-nix = { + url = "github:cachix/pre-commit-hooks.nix"; + inputs.nixpkgs.follows = "nixpkgs"; + inputs.nixpkgs-stable.follows = "nixpkgs"; + }; + hci-effects = { + url = "github:hercules-ci/hercules-ci-effects"; + inputs.nixpkgs.follows = "nixpkgs"; + inputs.flake-parts.follows = "flake-parts"; + }; + haskell-nix = { + url = "github:input-output-hk/haskell.nix"; + }; + }; + outputs = inputs: + let + flakeModules = { + haskell = ./nix/haskell; + plutarch = ./nix/plutarch; + utils = ./nix/utils; + }; + in + inputs.flake-parts.lib.mkFlake { inherit inputs; } ({ self, ... }: { + imports = [ + inputs.pre-commit-hooks-nix.flakeModule + inputs.hci-effects.flakeModule + ./. + ] ++ (builtins.attrValues flakeModules); + + # `nix flake show --impure` hack + systems = + if builtins.hasAttr "currentSystem" builtins + then [ builtins.currentSystem ] + else inputs.nixpkgs.lib.systems.flakeExposed; + + herculesCI.ciSystems = [ "x86_64-linux" ]; + + flake.flakeModules = flakeModules; + + perSystem = + { config + , pkgs + , lib + , system + , self' + , ... + }: { + _module.args.pkgs = import self.inputs.nixpkgs { + inherit system; + config.allowBroken = true; + }; + + pre-commit.settings = { + hooks = { + deadnix.enable = true; + # TODO: Enable in separate PR, causes mass changes. + # fourmolu.enable = true; + nixpkgs-fmt.enable = true; + typos.enable = true; + }; + + tools = { + fourmolu = lib.mkForce (pkgs.callPackage ./nix/fourmolu { + mkHaskellPackage = config.libHaskell.mkPackage; + }); + }; + + settings = { + latexindent.flags = config.libUtils.mkCli { + yaml = "\"defaultIndent:' ', onlyOneBackUp: 1\""; + local = true; + silent = true; + overwriteIfDifferent = true; + logfile = "/dev/null"; + }; + deadnix.edit = true; + }; + + excludes = [ + ".materialized" + ]; + }; + + devShells = { + default = pkgs.mkShell { + shellHook = config.pre-commit.installationScript; + + inputsFrom = [ + self'.devShells.purus + ]; + + nativeBuildInputs = [ + pkgs.fd + ]; + }; + }; + }; + }); +} diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..ed2de01b --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 2 +comma-style: leading +record-brace-space: true +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 diff --git a/nix/fourmolu/default.nix b/nix/fourmolu/default.nix new file mode 100644 index 00000000..954cbfaa --- /dev/null +++ b/nix/fourmolu/default.nix @@ -0,0 +1,13 @@ +{ mkHaskellPackage +, fetchFromGitHub +}: + +(mkHaskellPackage { + name = "fourmolu"; + src = fetchFromGitHub { + owner = "fourmolu"; + repo = "fourmolu"; + rev = "v0.13.1.0"; + hash = "sha256-abUK9KdvVI7di84X/L3vHZM97pOsciyx503aDjUnoc4="; + }; +}).packages."fourmolu:exe:fourmolu" diff --git a/nix/haskell/default.nix b/nix/haskell/default.nix new file mode 100644 index 00000000..fc5dd740 --- /dev/null +++ b/nix/haskell/default.nix @@ -0,0 +1,36 @@ +{ self +, lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; + inherit (lib) types mkOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, system, pkgs, ... }: { + options = { + libHaskell = mkOption { + type = types.anything; + default = { }; + }; + }; + + config = + let + mkHaskellPackage = pkgs.callPackage ./lib.nix { + inherit lib system; + haskellNixNixpkgs = self.inputs.haskell-nix.inputs.nixpkgs; + haskellNixOverlay = self.inputs.haskell-nix.overlay; + }; + + in + { + libHaskell = { + mkPackage = mkHaskellPackage; + }; + }; + }); + }; +} diff --git a/nix/haskell/lib.nix b/nix/haskell/lib.nix new file mode 100644 index 00000000..2dcbb208 --- /dev/null +++ b/nix/haskell/lib.nix @@ -0,0 +1,91 @@ +{ lib +, fetchFromGitHub + # e.g. "x86_64-linux" +, system # : string +, haskellNixNixpkgs # : nixpkgs +, haskellNixOverlay # : overlay +}: + +let + iohk-nix = fetchFromGitHub { + owner = "input-output-hk"; + repo = "iohk-nix"; + rev = "4848df60660e21fbb3fe157d996a8bac0a9cf2d6"; + hash = "sha256-ediFkDOBP7yVquw1XtHiYfuXKoEnvKGjTIAk9mC6qxo="; + }; + + pkgs = import haskellNixNixpkgs { + inherit system; + overlays = [ + (import "${iohk-nix}/overlays/crypto") + haskellNixOverlay + ]; + }; +in + +{ name # : string +, src # : path +, ghcVersion ? "ghc928" # : string +, haskellModules ? [ ] +, externalDependencies ? [ ] +, externalRepositories ? { } +}: +let + mkHackage = pkgs.callPackage ./mk-hackage.nix { + nix-tools = pkgs.haskell-nix.nix-tools-set { + compiler-nix-name = ghcVersion; + }; + }; + + # This looks like a noop but without it haskell.nix throws a runtime + # error about `pkgs` attribute not being present which is nonsense + # https://input-output-hk.github.io/haskell.nix/reference/library.html?highlight=cabalProject#modules + fixedHaskellModules = map (m: args @ { ... }: m args) haskellModules; + + flatExternalDependencies = + lib.lists.concatMap + (dep: [ (dep.passthru or { }).src or dep ] ++ + (flatExternalDependencies (dep.passthru or { }).externalDependencies or [ ])); + + flattenedExternalDependencies = flatExternalDependencies externalDependencies; + + customHackages = mkHackage { + srcs = map toString flattenedExternalDependencies; + inherit name; + }; + + project = pkgs.haskell-nix.cabalProject' { + inherit src; + name = name; + + compiler-nix-name = ghcVersion; + inputMap = lib.mapAttrs (_: toString) externalRepositories; + + modules = customHackages.modules ++ fixedHaskellModules; + inherit (customHackages) extra-hackages extra-hackage-tarballs; + + shell = { + withHoogle = true; + exactDeps = true; + + tools = { + cabal = { }; + haskell-language-server = { }; + }; + }; + }; + + projectFlake = project.flake { }; + + augmentedPackages = builtins.mapAttrs + (_: package: + package // { + passthru = (package.passthru or { }) // { + inherit src externalDependencies; + }; + }) + (projectFlake.packages or { }); +in +projectFlake // { + packages = augmentedPackages; +} diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix new file mode 100644 index 00000000..9bd43db8 --- /dev/null +++ b/nix/haskell/mk-hackage.nix @@ -0,0 +1,132 @@ +{ gzip +, runCommand +, lib +, nix-tools +}: +let + mkPackageSpec = src: + with lib; + let + cabalFiles = concatLists (mapAttrsToList + (name: type: if type == "regular" && hasSuffix ".cabal" name then [ name ] else [ ]) + (builtins.readDir src)); + + cabalPath = + if length cabalFiles == 1 + then src + "/${builtins.head cabalFiles}" + else builtins.abort "Could not find unique file with .cabal suffix in source: ${src}"; + cabalFile = builtins.readFile cabalPath; + parse = field: + let + lines = filter (s: builtins.match "^${field} *:.*$" (toLower s) != null) (splitString "\n" cabalFile); + line = + if lines != [ ] + then head lines + else builtins.abort "Could not find line with prefix ''${field}:' in ${cabalPath}"; + in + replaceStrings [ " " ] [ "" ] (head (tail (splitString ":" line))); + pname = parse "name"; + version = parse "version"; + in + { inherit src pname version; }; + + mkHackageDir = { pname, version, src }: + runCommand "${pname}-${version}-hackage" + { } '' + set -e + mkdir -p $out/${pname}/${version} + md5=11111111111111111111111111111111 + sha256=1111111111111111111111111111111111111111111111111111111111111111 + length=1 + cat < $out/"${pname}"/"${version}"/package.json + { + "signatures" : [], + "signed" : { + "_type" : "Targets", + "expires" : null, + "targets" : { + "/package/${pname}-${version}.tar.gz" : { + "hashes" : { + "md5" : "$md5", + "sha256" : "$sha256" + }, + "length" : $length + } + }, + "version" : 0 + } + } + EOF + cp ${src}/*.cabal $out/"${pname}"/"${version}"/ + ''; + + mkHackageTarballFromDirs = name: hackageDirs: + runCommand "${name}-hackage-index.tar.gz" { } '' + mkdir hackage + ${builtins.concatStringsSep "" (map (dir: '' + echo ${dir} + ln -sf ${dir}/* hackage/ + '') hackageDirs)} + cd hackage + tar --sort=name --owner=root:0 --group=root:0 --mtime='UTC 2009-01-01' -hczvf $out */*/* + ''; + + mkHackageTarball = name: pkg-specs: + mkHackageTarballFromDirs name (map mkHackageDir pkg-specs); + + mkHackageNix = name: hackageTarball: + runCommand "${name}-hackage-nix" + { + nativeBuildInputs = [ + gzip + nix-tools + ]; + } '' + set -e + export LC_CTYPE=C.UTF-8 + export LC_ALL=C.UTF-8 + export LANG=C.UTF-8 + cp ${hackageTarball} 01-index.tar.gz + gunzip 01-index.tar.gz + hackage-to-nix $out 01-index.tar "https://mkHackageNix/" + ''; + + mkModule = extraHackagePackages: { + packages = lib.listToAttrs (map + (spec: { + name = spec.pname; + value = { + inherit (spec) src; + }; + }) + extraHackagePackages); + }; + + mkHackageFromSpec = name: extraHackagePackages: rec { + extra-hackage-tarball = mkHackageTarball name extraHackagePackages; + extra-hackage = mkHackageNix name extra-hackage-tarball; + module = mkModule extraHackagePackages; + }; + +in +{ srcs # : [string] +, name # : string +}: + +if builtins.length srcs == 0 +then { + modules = [ ]; + extra-hackage-tarballs = { }; + extra-hackages = [ ]; +} +else + let + hackage = mkHackageFromSpec name (map mkPackageSpec srcs); + in + { + modules = [ hackage.module ]; + extra-hackage-tarballs = { + "${name}-hackage-tarball" = hackage.extra-hackage-tarball; + }; + extra-hackages = [ (import hackage.extra-hackage) ]; + } diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix new file mode 100644 index 00000000..afb64fb4 --- /dev/null +++ b/nix/plutarch/default.nix @@ -0,0 +1,28 @@ +{ lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, pkgs, ... }: { + options = { + libPlutarch = lib.mkOption { + type = lib.types.anything; + default = { }; + }; + }; + + config = { + libPlutarch = { + mkPackage = pkgs.callPackage ./lib.nix { + mkHaskellPackage = config.libHaskell.mkPackage; + inherit (config.libUtils) applyPatches; + }; + }; + }; + }); + }; +} diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix new file mode 100644 index 00000000..3ec84f23 --- /dev/null +++ b/nix/plutarch/lib.nix @@ -0,0 +1,44 @@ +{ fetchFromGitHub +, mkHaskellPackage +, applyPatches +, fetchpatch +}: + +let + plutarchPackage = applyPatches { + name = "plutarch-patched"; + src = fetchFromGitHub { + owner = "Plutonomicon"; + repo = "plutarch-plutus"; + rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master + hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0="; + }; + + patches = [ + # https://github.com/Plutonomicon/plutarch-plutus/pull/650 + (fetchpatch { + url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch"; + hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek="; + }) + ]; + }; + + cardanoPackages = fetchFromGitHub { + owner = "input-output-hk"; + repo = "cardano-haskell-packages"; + rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo + hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; + }; +in + +args: +mkHaskellPackage (args // { + externalRepositories = { + "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; + } // (args.externalRepositories or { }); + + externalDependencies = [ + "${plutarchPackage}" + "${plutarchPackage}/plutarch-extra" + ] ++ (args.externalDependencies or [ ]); +}) diff --git a/nix/utils/default.nix b/nix/utils/default.nix new file mode 100644 index 00000000..851ab543 --- /dev/null +++ b/nix/utils/default.nix @@ -0,0 +1,22 @@ +{ lib +, flake-parts-lib +, ... +}: +let + inherit (flake-parts-lib) mkPerSystemOption; + inherit (lib) types mkOption; +in +{ + options = { + perSystem = mkPerSystemOption ({ config, pkgs, ... }: { + options = { + libUtils = mkOption { + type = types.anything; + default = { }; + }; + }; + + config.libUtils = pkgs.callPackage ./lib.nix { }; + }); + }; +} diff --git a/nix/utils/lib.nix b/nix/utils/lib.nix new file mode 100644 index 00000000..c5b2f51b --- /dev/null +++ b/nix/utils/lib.nix @@ -0,0 +1,39 @@ +{ stdenv +, lib +}: + +let + applyPatches = args @ { patches, ... }: stdenv.mkDerivation ({ + inherit patches; + + dontConfigure = true; + dontBuild = true; + + installPhase = '' + mkdir -p "$out" + cp -r * "$out" + ''; + + dontFixup = true; + } // args); + + mkFlag = flag: value: "--${flag}=${value}"; + + mkFlags = flag: values: builtins.concatStringsSep " " (map (mkFlag flag) values); + + mkCli = args: + builtins.concatStringsSep " " + (lib.attrsets.mapAttrsToList + (flag: value: + if builtins.isList value + then mkFlags flag value + else if builtins.isBool value then (if value then "--${flag}" else "") + else mkFlag flag "${value}" + ) + args); + + withNameAttr = f: name: args: f (args // { inherit name; }); +in +{ + inherit applyPatches mkCli withNameAttr; +} diff --git a/purescript.cabal b/purescript.cabal index 6fed7b2a..e51452b8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -122,7 +122,7 @@ common defaults TypeFamilies ViewPatterns build-tool-depends: - happy:happy ==1.20.0 + happy:happy ^>= 1.20.0 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 7e50545d..00000000 --- a/shell.nix +++ /dev/null @@ -1,21 +0,0 @@ -with (import {}); -let haskell928 = haskell.packages.ghc928; - ghc928 = haskell.compiler.ghc928; -in mkShell { - nativeBuildInputs = [ - pkg-config - haskell928.haskell-language-server - ghc928 - cabal-install - ]; - - buildInputs = [ - zlib - libsodium - secp256k1 - ]; - - shellHook = '' - export LC_ALL=C.utf8 - ''; -} From 991c7588101714c772b3abecf873202cfbc78f24 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:12:04 -0700 Subject: [PATCH 40/44] Trigger CI From 4214ae69af340dba297684f868c31908440c849d Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:35:20 -0700 Subject: [PATCH 41/44] Remove unused configs --- flake.nix | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/flake.nix b/flake.nix index dbd6c47f..fb3d0f68 100644 --- a/flake.nix +++ b/flake.nix @@ -72,21 +72,6 @@ mkHaskellPackage = config.libHaskell.mkPackage; }); }; - - settings = { - latexindent.flags = config.libUtils.mkCli { - yaml = "\"defaultIndent:' ', onlyOneBackUp: 1\""; - local = true; - silent = true; - overwriteIfDifferent = true; - logfile = "/dev/null"; - }; - deadnix.edit = true; - }; - - excludes = [ - ".materialized" - ]; }; devShells = { @@ -96,10 +81,6 @@ inputsFrom = [ self'.devShells.purus ]; - - nativeBuildInputs = [ - pkgs.fd - ]; }; }; }; From 63494726daf887189f3703b5ec0d6f9bcf61565f Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 18 Feb 2024 14:49:26 -0700 Subject: [PATCH 42/44] Disable typos check Too many of them to fix now --- .envrc | 2 +- flake.nix | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.envrc b/.envrc index 1d953f4b..3550a30f 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -use nix +use flake diff --git a/flake.nix b/flake.nix index fb3d0f68..9552252a 100644 --- a/flake.nix +++ b/flake.nix @@ -64,7 +64,6 @@ # TODO: Enable in separate PR, causes mass changes. # fourmolu.enable = true; nixpkgs-fmt.enable = true; - typos.enable = true; }; tools = { From ed35645d28d5d83ac462c5c2a1158971b220bbcd Mon Sep 17 00:00:00 2001 From: t4ccer Date: Thu, 22 Feb 2024 18:08:06 -0700 Subject: [PATCH 43/44] Remove Nix Plutarch wrapper --- default.nix | 15 +++++++++++-- flake.nix | 1 - nix/haskell/mk-hackage.nix | 2 ++ nix/plutarch/default.nix | 28 ------------------------ nix/plutarch/lib.nix | 44 -------------------------------------- 5 files changed, 15 insertions(+), 75 deletions(-) delete mode 100644 nix/plutarch/default.nix delete mode 100644 nix/plutarch/lib.nix diff --git a/default.nix b/default.nix index 83f611fb..4ff7fc51 100644 --- a/default.nix +++ b/default.nix @@ -1,9 +1,20 @@ { - perSystem = { self', config, ... }: + perSystem = { self', pkgs, config, ... }: let - purus = config.libPlutarch.mkPackage { + cardanoPackages = pkgs.fetchFromGitHub { + owner = "input-output-hk"; + repo = "cardano-haskell-packages"; + rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo + hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; + }; + + purus = config.libHaskell.mkPackage { name = "purus"; src = ./.; + + externalRepositories = { + "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; + }; }; in { diff --git a/flake.nix b/flake.nix index 9552252a..555cfe2e 100644 --- a/flake.nix +++ b/flake.nix @@ -24,7 +24,6 @@ let flakeModules = { haskell = ./nix/haskell; - plutarch = ./nix/plutarch; utils = ./nix/utils; }; in diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix index 9bd43db8..fc89862f 100644 --- a/nix/haskell/mk-hackage.nix +++ b/nix/haskell/mk-hackage.nix @@ -1,3 +1,5 @@ +# Adapted from https://github.com/mlabs-haskell/mlabs-tooling.nix/blob/cd0cf0d29f17980befe384248c16937589912c69/mk-hackage.nix + { gzip , runCommand , lib diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix deleted file mode 100644 index afb64fb4..00000000 --- a/nix/plutarch/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -{ lib -, flake-parts-lib -, ... -}: -let - inherit (flake-parts-lib) mkPerSystemOption; -in -{ - options = { - perSystem = mkPerSystemOption ({ config, pkgs, ... }: { - options = { - libPlutarch = lib.mkOption { - type = lib.types.anything; - default = { }; - }; - }; - - config = { - libPlutarch = { - mkPackage = pkgs.callPackage ./lib.nix { - mkHaskellPackage = config.libHaskell.mkPackage; - inherit (config.libUtils) applyPatches; - }; - }; - }; - }); - }; -} diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix deleted file mode 100644 index 3ec84f23..00000000 --- a/nix/plutarch/lib.nix +++ /dev/null @@ -1,44 +0,0 @@ -{ fetchFromGitHub -, mkHaskellPackage -, applyPatches -, fetchpatch -}: - -let - plutarchPackage = applyPatches { - name = "plutarch-patched"; - src = fetchFromGitHub { - owner = "Plutonomicon"; - repo = "plutarch-plutus"; - rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master - hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0="; - }; - - patches = [ - # https://github.com/Plutonomicon/plutarch-plutus/pull/650 - (fetchpatch { - url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch"; - hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek="; - }) - ]; - }; - - cardanoPackages = fetchFromGitHub { - owner = "input-output-hk"; - repo = "cardano-haskell-packages"; - rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo - hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ="; - }; -in - -args: -mkHaskellPackage (args // { - externalRepositories = { - "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages; - } // (args.externalRepositories or { }); - - externalDependencies = [ - "${plutarchPackage}" - "${plutarchPackage}/plutarch-extra" - ] ++ (args.externalDependencies or [ ]); -}) From a9f7a144d890e1f892be6917b449e69dd08175c4 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Tue, 5 Mar 2024 19:34:15 -0500 Subject: [PATCH 44/44] Removed some dead comments, testing pre-commit hooks --- src/Language/PureScript/CoreFn/Desugar.hs | 25 ++++++++----------- .../PureScript/CoreFn/Desugar/Utils.hs | 3 --- 2 files changed, 11 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 3e357c13..244d97ac 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -224,7 +224,7 @@ exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts) arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts pure $ Literal (ss,[],Nothing) arrT arr -- An empty list could either have a TyVar or a quantified type (or a concrete type, which is handled by the previous case) -exprToCoreFn mn ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do +exprToCoreFn _ ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral []) exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ArrayLiteral _)) = internalError $ "Error while desugaring Array Literal. No type provided for literal:\n" <> renderValue 100 astlit @@ -376,8 +376,7 @@ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ide Nothing -> lookupDictType ident >>= \case Just ty -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident Nothing -> do - -- pEnv <- printEnv - traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) + traceM $ "No known type for identifier " <> show ident error "boom" -- If-Then-Else Turns into a case expression exprToCoreFn mn ss (Just resT) (A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do @@ -539,11 +538,11 @@ inferBinder' -> A.Binder -> m (M.Map Ident (SourceSpan, SourceType)) inferBinder' _ A.NullBinder = return M.empty -inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty -inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty -inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty +inferBinder' _ (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty +inferBinder' _ (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ return M.empty +inferBinder' _ (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty +inferBinder' _ (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty +inferBinder' _ (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name)) $ return $ M.singleton name (ss, val) inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do traceM $ "InferBinder VAL:\n" <> ppType 100 val @@ -559,7 +558,7 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. + peelArgs :: Type a -> ([Type a], Type a) peelArgs = go [] where go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret @@ -578,7 +577,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin -- The type-level labels are authoritative diff = S.difference typeKeys exprKeys if S.null diff - then deduceRowProperties (M.fromList rowItems) props' -- M.unions <$> zipWithM inferBinder' (snd <$> rowItems) (snd <$> props') + then deduceRowProperties (M.fromList rowItems) props' else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff where deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType)) @@ -598,10 +597,8 @@ inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMED return $ M.insert name (ss, val) m inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POSITIONEDBINDER" $ warnAndRethrowWithPositionTC pos $ inferBinder' val binder -inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do - (elabTy, kind) <- kindOf ty - -- checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner - -- unifyTypes val elabTy +inferBinder' _ (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do + (elabTy, _) <- kindOf ty inferBinder' elabTy binder inferBinder' _ A.OpBinder{} = internalError "OpBinder should have been desugared before inferBinder'" diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index bf0d62ce..0d630612 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -260,7 +260,6 @@ unwrapRecord = \case go :: RowListItem a -> (PSString, Type a) go RowListItem{..} = (runLabel rowListLabel, rowListType) - traceNameTypes :: M m => m () traceNameTypes = do nametypes <- getEnv >>= pure . debugNames @@ -321,7 +320,6 @@ desugarConstraintsInDecl = \case in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs) other -> other - -- Gives much more readable output (with colors for brackets/parens!) than plain old `show` pTrace :: (Monad m, Show a) => a -> m () pTrace = traceM . LT.unpack . pShow @@ -339,7 +337,6 @@ wrapTrace msg act = do startMsg = pad $ "BEGIN " <> msg endMsg = pad $ "END " <> msg - {- This is used to solve a problem that arises with re-exported instances.