diff --git a/.envrc b/.envrc new file mode 100644 index 000000000..3550a30f2 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/.gitignore b/.gitignore index 0454beffc..9b55e7393 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 51c7ecb87..29ca61bcc 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,18 @@ +repository cardano-haskell-packages + url: https://input-output-hk.github.io/cardano-haskell-packages + secure: True + root-keys: + 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f + 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 + a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 + bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 + c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 + d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee + + 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 000000000..4ff7fc519 --- /dev/null +++ b/default.nix @@ -0,0 +1,31 @@ +{ + perSystem = { self', pkgs, config, ... }: + let + 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 + { + 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 000000000..34d0f876a --- /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 000000000..555cfe2e7 --- /dev/null +++ b/flake.nix @@ -0,0 +1,86 @@ +{ + 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; + 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; + }; + + tools = { + fourmolu = lib.mkForce (pkgs.callPackage ./nix/fourmolu { + mkHaskellPackage = config.libHaskell.mkPackage; + }); + }; + }; + + devShells = { + default = pkgs.mkShell { + shellHook = config.pre-commit.installationScript; + + inputsFrom = [ + self'.devShells.purus + ]; + }; + }; + }; + }); +} diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 000000000..ed2de01bd --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 2 +comma-style: leading +record-brace-space: true +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 000000000..397604162 --- /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/nix/fourmolu/default.nix b/nix/fourmolu/default.nix new file mode 100644 index 000000000..954cbfaa0 --- /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 000000000..fc5dd7400 --- /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 000000000..2dcbb208b --- /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 000000000..fc89862f6 --- /dev/null +++ b/nix/haskell/mk-hackage.nix @@ -0,0 +1,134 @@ +# Adapted from https://github.com/mlabs-haskell/mlabs-tooling.nix/blob/cd0cf0d29f17980befe384248c16937589912c69/mk-hackage.nix + +{ 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/utils/default.nix b/nix/utils/default.nix new file mode 100644 index 000000000..851ab543a --- /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 000000000..c5b2f51b4 --- /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 a608c61ca..e51452b83 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 @@ -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 @@ -119,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 @@ -155,9 +158,10 @@ 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.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, @@ -191,6 +195,8 @@ common defaults parsec >=3.1.15.0 && <3.2, 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, @@ -201,14 +207,16 @@ 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, 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, + plutus-core:plutus-ir library import: defaults @@ -230,21 +238,23 @@ library Language.PureScript.AST.Utils Language.PureScript.Bundle Language.PureScript.CodeGen - Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Printer + Language.PureScript.CodeGen.UPLC Language.PureScript.Constants.Libs Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann 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.Laziness Language.PureScript.CoreFn.Meta 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 @@ -406,13 +416,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 @@ -437,6 +469,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, @@ -477,6 +510,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 83% rename from app/Command/Compile.hs rename to purs-lib/Command/Compile.hs index 8f348da9d..9cd29b37f 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: " ++) @@ -130,11 +149,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 +177,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/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/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index cfa2e880e..6cb94a40c 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/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index 02edf9ec4..a552ce52b 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 14d122a37..000000000 --- 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 e02946890..000000000 --- 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 6740e2a7a..000000000 --- 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/CodeGen/UPLC.hs b/src/Language/PureScript/CodeGen/UPLC.hs new file mode 100644 index 000000000..a993c3584 --- /dev/null +++ b/src/Language/PureScript/CodeGen/UPLC.hs @@ -0,0 +1,154 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE TypeApplications #-} +module Language.PureScript.CodeGen.UPLC where + +import Prelude ((.), ($)) +import Protolude + ( ($), + Monad, + Maybe, + (.), + MonadError, + MonadIO(..), + print, + undefined, + MonadReader, + MonadState, (<$>) ) +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.AST qualified as AST +import Language.PureScript.CoreFn (Ann, Module(..), Expr(..), Literal(..), Meta) +import Language.PureScript.Errors (MultipleErrors(..)) +import Language.PureScript.Options (Options(..)) + +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 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 PIRProgram +moduleToUPLC = error "Error: UPLC Backend not yet implemented!" + + + +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/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 4b64b97c4..62d1fcf71 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/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 576243c25..b7ceaafc8 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 34bf08f1f..244d97ac6 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,272 +1,608 @@ -module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where +{- HLINT ignore "Use void" -} +{- HLINT ignore "Use <$" -} -import Prelude -import Protolude (ordNub, orEmpty) +module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where -import Control.Arrow (second) +import Prelude +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap)) -import Data.Function (on) -import Data.Maybe (mapMaybe) -import Data.Tuple (swap) +import Data.Maybe (mapMaybe, fromMaybe) 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.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) -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 (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) +import Language.PureScript.Environment ( + pattern (:->), + pattern ArrayT, + DataDeclType(..), + Environment(..), + NameKind(..), + isDictTypeName, + lookupConstructor, + lookupValue, + NameVisibility (..), + tyBoolean, + tyFunction, + tyString, + tyChar, + tyInt, + tyNumber, + function, + pattern RecordT ) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) -import Language.PureScript.AST qualified as A +import Language.PureScript.Names ( + pattern ByNullSourcePos, Ident(..), + ModuleName, + ProperName(..), + Qualified(..), + QualifiedBy(..), + mkQualified, + runIdent, + coerceProperName, + Name (DctorName)) +import Language.PureScript.PSString (PSString, prettyPrintString) +import Language.PureScript.Types ( + pattern REmptyKinded, + SourceType, + 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 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 Data.List.NonEmpty qualified as NE +import Control.Monad (forM, (>=>), foldM) +import Language.PureScript.Errors + ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) +import Debug.Trace (traceM) +import Language.PureScript.CoreFn.Pretty ( ppType, renderExprStr ) +import Data.Text qualified as T +import Language.PureScript.Pretty.Values (renderValue) +import Language.PureScript.TypeChecker.Monad + ( bindLocalVariables, + bindNames, + getEnv, + makeBindingGroupVisible, + warnAndRethrowWithPositionTC, + withBindingGroupVisible, + CheckState(checkEnv, checkCurrentModule) ) +import Language.PureScript.CoreFn.Desugar.Utils + ( binderToCoreFn, + dedupeImports, + exportToCoreFn, + externToCoreFn, + findQualModules, + getConstructorMeta, + getLetMeta, + getModuleName, + getValueMeta, + importToCoreFn, + printEnv, + properToIdent, + purusTy, + reExportsToCoreFn, + showIdent', + ssA, + toReExportRef, + wrapTrace, + desugarConstraintTypes, + 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 Data.Either (lefts) + +{- + 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. +-} -- | 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 (A.Module modSS coms mn _decls (Just exps)) = do + setModuleName + 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) externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap declToCoreFn decls - in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' + 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} + +{- | 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 <- getModuleName + env <- gets checkEnv + 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,_,nv) -> do + traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty + pure (ty,nv) + Just (ty,_,nv) -> do + 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. + + TODO: The module name can be retrieved from the monadic context and doesn't need to be passed around +-} + +-- newtype T = T Foo turns into T :: Foo -> Foo +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 $ 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" where - -- 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) - - -- 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 + 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)) $ traverse go ctors + where + go ctorDecl = do + env <- gets checkEnv + let ctor = A.dataCtorName ctorDecl + (_, _, ctorTy, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) + pure $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) (purusTy ctorTy) tyName ctor fields +-- 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 + 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] +-- 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 typed = NE.toList $ extractTypeAndPrepareBind <$> ds + toBind = snd <$> typed + recBody <- bindLocalVariables toBind $ traverse goRecBindings typed + pure [Rec recBody] + where + -- 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 (((_,_),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,_)) = do + expr' <- exprToCoreFn mn ss' (Just ty) expr + pure ((ssA ss',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) +-- 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 _ 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 + 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) +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) + recT + obj' + (unchangedRecordFields (fmap fst vs) recT) + 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) = + 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 _ _ Nothing objUpd@(A.ObjectUpdate _ _) = + internalError $ "Error while desugaring object update. No type provided for expression:\n" <> renderValue 100 objUpd - 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 +-- 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) + +{- 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) + 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 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 + 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) + -- 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: 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 + _ -> 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 + + | otherwise = wrapTrace "exprToCoreFn APP" $ do + traceM $ renderValue 100 app + fun' <- exprToCoreFn mn ss Nothing fun + let funTy = exprType 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" <> renderExprStr arg' + pure $ App (ss, [], Nothing) (fromMaybe b mTy) fun' arg' + + where + isDictCtor = \case + A.Constructor _ (Qualified _ name) -> isDictTypeName name + A.TypedValue _ e _ -> isDictCtor e + _ -> 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" +-- 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 -> lookupDictType ident >>= \case + Just ty -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident + Nothing -> do + 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 + condE <- exprToCoreFn mn ss (Just tyBoolean) cond + 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 _ _ (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 (Just caseTy) astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do + traceM $ "CASE:\n" <> renderValue 100 astCase + 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 + +-- 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 + 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 +-- 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 + . 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 (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) +altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCoreFn" $ do + env <- gets checkEnv + 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 + ege <- go toBind vs + pure $ CaseAlternative binders ege + 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 -- 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 toBind gs = bindLocalVariables toBind $ do + ges <- forM gs $ \case + A.GuardedExpr g e -> do + let cond = guardToExpr g + condE <- exprToCoreFn mn ss (Just tyBoolean) cond -- (Just tyBoolean)? + eE <- exprToCoreFn mn ss (Just ret) e + pure (condE,eE) + pure . Left $ ges + guardToExpr [A.ConditionGuard cond] = cond + guardToExpr _ = internalError "Guard not correctly desugared" + +{- Dirty hacks. If something breaks, odds are pretty good that it has something do with something here. + + These two functions are adapted from utilities in Language.PureScript.TypeChecker.Types: + - transformLetBindings is a modification of inferLetBindings + - inferBinder' is a modification of inferBinder' + + 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. + +-} +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 <> " :: " <> 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 (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) + then bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do + let thisDecl = [NonRec (ssA ss) ident e] + 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 + <> "\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 + -- 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. + Left _ -> error + $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" + <> 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" + + +-- | 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) + => SourceType + -> A.Binder + -> m (M.Map Ident (SourceSpan, SourceType)) +inferBinder' _ A.NullBinder = 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 + 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 + 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 + peelArgs :: Type a -> ([Type a], Type a) + peelArgs = go [] + where + 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 + $ "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' + else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff where - 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) -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 + deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType)) + 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 + 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" $ 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 + m <- inferBinder' val binder + return $ M.insert name (ss, val) m +inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POSITIONEDBINDER" $ + warnAndRethrowWithPositionTC pos $ inferBinder' val binder +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'" +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/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs new file mode 100644 index 000000000..0d630612b --- /dev/null +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -0,0 +1,603 @@ +{- HLINT ignore "Use void" -} +{- HLINT ignore "Use <$" -} +{- HLINT ignore "Use <&>" -} +module Language.PureScript.CoreFn.Desugar.Utils where + +import Prelude +import Protolude (MonadError (..), traverse_) + +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, overTypes) +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 ( + pattern RecordT, + DataDeclType(..), + Environment(..), + NameKind(..), + lookupConstructor, + lookupValue, + NameVisibility (..), + dictTypeName, + TypeClassData (typeClassArguments), + function, + 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 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 ) +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), debugNames ) +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 -} +--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] +ctorArgs _ = [] + +-- Extract the TyCon ("function") part of an applied Type Constructor +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 + + +{- 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 +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 + 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 + + +-- 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,_,_) -> 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. + 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. + 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 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 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') + fun@(a :-> _) -> 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) + _ -> (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 +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 + 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 + +desugarConstraintTypes :: M m => m () +desugarConstraintTypes = do + env <- getEnv + 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` +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 + +{- + 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 + 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 + 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. +-- 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 +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 _ _ _) = [] diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 20ab33301..9b9591808 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, SourceType) + + +type PurusType = SourceType -- 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 d0426b6f8..1f083f51a 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -26,8 +26,14 @@ 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) +-- 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 @@ -189,8 +195,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 +206,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 9941fd41c..000000000 --- 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/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 09f5189c4..f874ab311 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/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 722893c43..f5439ee0c 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/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs new file mode 100644 index 000000000..bb2af5892 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -0,0 +1,73 @@ +module Language.PureScript.CoreFn.Pretty ( + module PRETTY, + ppType, + smartRender, + writeModule, + prettyModuleTxt, + renderExpr, + renderExprStr, + prettyTypeStr +) where + +import Prelude hiding ((<>)) + +import Data.Text (Text) +import Data.Text qualified as T + +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 + ( layoutSmart, + defaultLayoutOptions, + layoutPretty, + 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. + 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. +-} + + +-- TODO: Remove +ppType :: Show a => Int -> Type a -> String +ppType _ t = prettyTypeStr t + + +-- 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 + +writeModule :: Handle -> Module a -> IO () +writeModule h m = renderIO h + . layoutSmart defaultLayoutOptions + $ prettyModule m + +prettyModuleTxt :: Module a -> Text +prettyModuleTxt = renderStrict . layoutPretty defaultLayoutOptions . prettyModule + +renderExpr :: Expr a -> Text +renderExpr = smartRender . asDynamic prettyValue + +renderExprStr :: Expr a -> String +renderExprStr = T.unpack . renderExpr + +prettyTypeStr :: forall a. Show a => Type a -> String +prettyTypeStr = T.unpack . smartRender . asOneLine prettyType + + +{- TYPES (move later) -} diff --git a/src/Language/PureScript/CoreFn/Pretty/Common.hs b/src/Language/PureScript/CoreFn/Pretty/Common.hs new file mode 100644 index 000000000..0d8628d9b --- /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 000000000..b692092ec --- /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 000000000..b172ea11e --- /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 diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 1b20ac4e6..3b6aa4c58 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 @@ -162,50 +186,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 f0684d34d..288faf126 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/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031..561da8c75 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 @@ -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,41 @@ 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 a -> Type a -> Type a +pattern a :-> b <- + TypeApp _ + (TypeApp _ (TypeConstructor _ C.Function) a) + b + +pattern ArrayT :: Type a -> Type a +pattern ArrayT a <- + TypeApp _ (TypeConstructor _ C.Array) a + + + +arrayT :: SourceType -> SourceType +arrayT = TypeApp NullSourceAnn (TypeConstructor NullSourceAnn C.Array) + +pattern RecordT :: Type a -> Type a +pattern RecordT a <- + TypeApp _ (TypeConstructor _ C.Record) a + + + +getFunArgTy :: Type a -> Type a +getFunArgTy = \case + a :-> _ -> a + ForAll _ _ _ _ t _ -> getFunArgTy t + other -> other + -- To make reading the kind signatures below easier (-:>) :: SourceType -> SourceType -> SourceType (-:>) = function diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339e..923e10b8c 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 8340d77ca..145f76b1c 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,8 +48,16 @@ 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 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) +import Language.PureScript.CoreFn.Pretty (ppType) +import Language.PureScript.CoreFn.Desugar.Utils (pTrace) -- | Rebuild a single module. -- @@ -90,17 +98,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 @@ -109,11 +117,19 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ desugarCaseGuards elaborated 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 + 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 . T.unpack $ CFT.prettyModuleTxt 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, @@ -129,8 +145,20 @@ 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 + 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. -- @@ -148,7 +176,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 f138327c8..bd5c2ff5f 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,26 +21,26 @@ 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 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 +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 @@ -57,7 +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 (writeModule) + -- | Determines when to rebuild a module data RebuildPolicy @@ -181,18 +185,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,10 +209,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" + CoreFn -> outputFilename mn "index.cfn" + CheckCoreFn -> outputFilename mn "index.cfn" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -250,33 +257,34 @@ 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 - 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 CoreFn codegenTargets) $ do + let targetFile = (targetFilename mn CoreFn) + lift $ writeJSONFile targetFile (moduleToJSON (makeVersion [0,0,1]) 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) + 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 @@ -432,7 +440,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 @@ -448,8 +457,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 d94d344cf..ae4131559 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -18,15 +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 | CoreFn | Docs +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) - , ("sourcemaps", JSSourceMap) - , ("corefn", CoreFn) + [ ("coreFn", CoreFn) + , ("checkCoreFn", CheckCoreFn) + -- , ("corefn", CoreFn) , ("docs", Docs) ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20de0ed9e..fafc3a2fe 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,6 +37,7 @@ import Language.PureScript.Label (Label(..)) import Text.PrettyPrint.Boxes (Box(..), hcat, hsep, left, moveRight, nullBox, render, text, top, vcat, (<>)) + 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]) @@ -75,7 +78,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) @@ -123,7 +126,7 @@ prettyPrintRowWith tro open close labels rest = ([], 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 ..] ++ @@ -192,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/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4d5a5ec60..f8bca7e49 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 "..." diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index a54e39f1e..cd7bdfd89 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. diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 4d713d541..fdaf44fd8 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 4f3129baf..ccb699db2 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]) @@ -300,9 +300,10 @@ 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)) + -- 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))) @@ -362,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.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f01..fde27f1ef 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 ba27d0299..46be3f3e1 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. } @@ -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 3f758805c..9faf7830d 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -5,6 +5,19 @@ module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) , typesOf , checkTypeKind + , check + , infer + , inferBinder + , freshTypeWithKind + , kindType + , TypedValue' (..) + , instantiatePolyTypeWithUnknowns + , instantiateForBinders + , tvToExpr + , SplitBindingGroup(..) + , typeDictionaryForBindingGroup + , typeForBindingGroupElement + , checkTypedBindingGroupElement ) where {- @@ -595,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 @@ -713,9 +729,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 diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 93a0cabe5..7da70065c 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 b8f6ea979..6b8ec2c0e 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 588c6817b..07b757e96 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 610e8465c..6cd5347f4 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 000000000..d14d7ad0b --- /dev/null +++ b/tests/TestPurus.hs @@ -0,0 +1,124 @@ +{-# 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", + "Misc", + "NonOrphanInstanceFunDepExtra", + "NonOrphanInstanceMulti", + "PendingConflictingImports", + "PendingConflictingImports2", + "RedefinedFixity", + "ReExportQualified", + "ResolvableScopeConflict", + "ResolvableScopeConflict2", + "ResolvableScopeConflict3", + "ShadowedModuleName", + "TransitiveImport" + ] + + +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 5b91017d5..ae931b886 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 000000000..bff4cd039 --- /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 000000000..c87647d4c --- /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 000000000..3c433e0b1 --- /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 000000000..cd6e73d34 --- /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 000000000..055b3c783 --- /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 000000000..fc5f850e7 --- /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 000000000..89ccc3043 --- /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 000000000..645940a23 --- /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 000000000..2c5b87070 --- /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 000000000..c9eca67a7 --- /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 000000000..cca268cfb --- /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 000000000..3fdef618d --- /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 000000000..a428343a2 --- /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 000000000..5f8ef12ae --- /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 000000000..d2c06e960 --- /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 000000000..5195d0e96 --- /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 000000000..aa78149f1 --- /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 000000000..d28a9a5cc --- /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 000000000..ec5358550 --- /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 000000000..a6a9846e7 --- /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 000000000..cf27f2df6 --- /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 000000000..719a1a03e --- /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 000000000..c96669335 --- /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/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs new file mode 100644 index 000000000..11a29e12a --- /dev/null +++ b/tests/purus/passing/Misc/Lib.purs @@ -0,0 +1,196 @@ +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 + + +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 + +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} +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 + +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 + {bar: _, baz: x} + | eq @Int x 4 -> x + _ -> 0 +-} diff --git a/tests/purus/passing/ModuleDeps/M1.purs b/tests/purus/passing/ModuleDeps/M1.purs new file mode 100644 index 000000000..535aa287c --- /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 000000000..017e70e3f --- /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 000000000..f07167b71 --- /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 000000000..590977109 --- /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 000000000..49b5b73e0 --- /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 diff --git a/tests/purus/passing/PendingConflictingImports/A.purs b/tests/purus/passing/PendingConflictingImports/A.purs new file mode 100644 index 000000000..302b0328d --- /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 000000000..076bf7ea5 --- /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 000000000..b42cd06fd --- /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 000000000..302b0328d --- /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 000000000..81c3d821d --- /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 000000000..ae231283a --- /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 000000000..2e149222f --- /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 000000000..589f37bc4 --- /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 000000000..af2f8d272 --- /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 000000000..703e37bfb --- /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 000000000..f7ddf1946 --- /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 000000000..cd62cc115 --- /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 000000000..a796c5790 --- /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 000000000..302b0328d --- /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 000000000..4ad4bb6f4 --- /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 000000000..aa2bed42e --- /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 000000000..943011cd7 --- /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 000000000..899fadecb --- /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 000000000..302b0328d --- /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 000000000..204008202 --- /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 000000000..80061b5fb --- /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 000000000..b30eb2dfd --- /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 000000000..57e2a2b10 --- /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 000000000..2d735b509 --- /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 000000000..5d7ad43c4 --- /dev/null +++ b/tests/purus/passing/TransitiveImport/TransitiveImport.purs @@ -0,0 +1,6 @@ +module Main where + + import Middle + + main :: Unit + main = (middle unit)