diff --git a/.envrc b/.envrc index 1d953f4bd..3550a30f2 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -use nix +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 aa859b8b7..29ca61bcc 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,7 @@ repository cardano-haskell-packages packages: purescript.cabal + +-- HACK: plutus core cannot build without it, remove after bump. +constraints: + nothunks < 0.2 diff --git a/default.nix b/default.nix new file mode 100644 index 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/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 31f72e7d3..e51452b83 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -86,6 +86,9 @@ common defaults -Wno-missing-export-lists -Wno-missing-kind-signatures -Wno-partial-fields + + -- TODO: Remove + -O0 default-language: Haskell2010 default-extensions: BangPatterns @@ -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,6 +158,7 @@ common defaults -- specific version. aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, + aeson-diff, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.18, @@ -192,6 +196,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process ==1.6.13.1, pretty-simple, + prettyprinter, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, @@ -247,6 +252,9 @@ library Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Optimizer Language.PureScript.CoreFn.Pretty + Language.PureScript.CoreFn.Pretty.Common + Language.PureScript.CoreFn.Pretty.Expr + Language.PureScript.CoreFn.Pretty.Types Language.PureScript.CoreFn.ToJSON Language.PureScript.CoreFn.Traversals Language.PureScript.CoreImp @@ -408,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 @@ -439,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, @@ -479,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/shell.nix b/shell.nix deleted file mode 100644 index 7e50545de..000000000 --- a/shell.nix +++ /dev/null @@ -1,21 +0,0 @@ -with (import {}); -let haskell928 = haskell.packages.ghc928; - ghc928 = haskell.compiler.ghc928; -in mkShell { - nativeBuildInputs = [ - pkg-config - haskell928.haskell-language-server - ghc928 - cabal-install - ]; - - buildInputs = [ - zlib - libsodium - secp256k1 - ]; - - shellHook = '' - export LC_ALL=C.utf8 - ''; -} diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 9c361f43e..244d97ac6 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,17 +1,17 @@ {- HLINT ignore "Use void" -} {- HLINT ignore "Use <$" -} -{-# LANGUAGE TypeApplications #-} + module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn) +import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap)) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.SourcePos (SourceSpan(..), SourceAnn) import Language.PureScript.CoreFn.Ann (Ann, ssAnn) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType) @@ -27,33 +27,31 @@ import Language.PureScript.Environment ( isDictTypeName, lookupConstructor, lookupValue, - purusFun, NameVisibility (..), tyBoolean, tyFunction, tyString, tyChar, tyInt, - tyNumber ) + tyNumber, + function, + pattern RecordT ) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names ( pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), - ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified, runIdent, coerceProperName, Name (DctorName)) -import Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString, prettyPrintString) import Language.PureScript.Types ( pattern REmptyKinded, SourceType, - Type(..), - srcTypeConstructor, - srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns) + 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 @@ -61,19 +59,12 @@ import Language.PureScript.Constants.Prim qualified as C import Control.Monad.State.Strict (MonadState, gets, modify) import Control.Monad.Writer.Class ( MonadWriter ) import Language.PureScript.TypeChecker.Kinds ( kindOf ) -import Language.PureScript.TypeChecker.Types - ( checkTypeKind, - SplitBindingGroup(SplitBindingGroup), - TypedValue'(TypedValue'), - typeDictionaryForBindingGroup, - infer ) import Data.List.NonEmpty qualified as NE -import Language.PureScript.TypeChecker.Unify (unifyTypes) -import Control.Monad (forM, (>=>)) +import Control.Monad (forM, (>=>), foldM) import Language.PureScript.Errors ( MultipleErrors, errorMessage', SimpleErrorMessage(..)) import Debug.Trace (traceM) -import Language.PureScript.CoreFn.Pretty ( ppType ) +import Language.PureScript.CoreFn.Pretty ( ppType, renderExprStr ) import Data.Text qualified as T import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.TypeChecker.Monad @@ -93,12 +84,8 @@ import Language.PureScript.CoreFn.Desugar.Utils getConstructorMeta, getLetMeta, getModuleName, - getTypeClassArgs, getValueMeta, importToCoreFn, - inferType, - instantiatePolyType, - pTrace, printEnv, properToIdent, purusTy, @@ -106,13 +93,14 @@ import Language.PureScript.CoreFn.Desugar.Utils showIdent', ssA, toReExportRef, - traverseLit, wrapTrace, - M, unwrapRecord, withInstantiatedFunType, + 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 @@ -131,9 +119,11 @@ import Data.Set qualified as S moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann) moduleToCoreFn (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn (A.Module modSS coms mn decls (Just exps)) = do +moduleToCoreFn (A.Module modSS coms mn _decls (Just exps)) = do setModuleName - let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) + desugarConstraintTypes + let decls = desugarConstraintsInDecl <$> _decls + importHelper ds = fmap (ssAnn modSS,) (findQualModules ds) imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls exps' = ordNub $ concatMap exportToCoreFn exps reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) @@ -156,7 +146,7 @@ lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibil lookupType sp tn = do mn <- getModuleName env <- gets checkEnv - case M.lookup (Qualified (BySourcePos sp) tn) (names env) of + case M.lookup (Qualified (BySourcePos sp) tn) (names env) of Nothing -> case M.lookup (mkQualified tn mn) (names env) of Nothing -> do pEnv <- printEnv @@ -178,7 +168,7 @@ declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann] declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of [(_,wrappedTy)] -> do -- traceM (show ctor) - let innerFunTy = quantify $ purusFun wrappedTy wrappedTy + let innerFunTy = quantify $ function wrappedTy wrappedTy pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))] _ -> error "Found newtype with multiple fields" @@ -188,8 +178,7 @@ declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ( declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d -- Data declarations get turned into value declarations for the constructor(s) -declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ do - traverse go ctors +declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <> T.unpack (runProperName tyName)) $ traverse go ctors where go ctorDecl = do env <- gets checkEnv @@ -201,7 +190,9 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DA -- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here? -- NOTE: Should be impossible to have a guarded expr here, make it an error declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do + traceM $ renderValue 100 e (valDeclTy,nv) <- lookupType (spanStart ss) name + 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] @@ -215,10 +206,10 @@ declToCoreFn mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDIN -- If we only ever call this on a top-level binding group then this should be OK, all the exprs should be explicitly typed extractTypeAndPrepareBind :: ((A.SourceAnn, Ident), NameKind, A.Expr) -> (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) extractTypeAndPrepareBind (((ss',_),ident),_,A.TypedValue _ e ty) = (e,(ss',ident,ty,Defined)) - extractTypeAndPrepareBind (((ss',_),ident),_,_) = error $ "Top level declaration " <> (showIdent' ident) <> " should have a type annotation, but does not" + extractTypeAndPrepareBind (((_,_),ident),_,_) = error $ "Top level declaration " <> showIdent' ident <> " should have a type annotation, but does not" goRecBindings :: (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) -> m ((Ann, Ident), Expr Ann) - goRecBindings (expr,(ss',ident,ty,nv)) = do + goRecBindings (expr,(ss',ident,ty,_)) = do expr' <- exprToCoreFn mn ss' (Just ty) expr pure ((ssA ss',ident), expr') -- TODO: Avoid catchall case @@ -226,27 +217,63 @@ declToCoreFn _ _ = pure [] -- Desugars expressions from AST to typed CoreFn representation. exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann) --- Literal case is straightforward -exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do - litT <- purusTy <$> inferType mTy astLit - lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit - pure $ Literal (ss, [], Nothing) litT lit' --- Accessor case is straightforward -exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do - expT <- purusTy <$> inferType mTy accessor - expr <- exprToCoreFn mn ss Nothing v - pure $ Accessor (ssA ss) expT name expr --- Object update is straightforward (this is basically a monadic wrapper around the old non-typed exprToCoreFn) -exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do - expT <- purusTy <$> inferType mTy objUpd +-- 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) - expT + recT obj' - (mTy >>= unchangedRecordFields (fmap fst vs)) + (unchangedRecordFields (fmap fst vs) recT) vs' where -- TODO: Optimize/Refactor Using Data.Set @@ -260,60 +287,84 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r collect _ = Nothing unchangedRecordFields _ _ = Nothing +exprToCoreFn _ _ Nothing objUpd@(A.ObjectUpdate _ _) = + internalError $ "Error while desugaring object update. No type provided for expression:\n" <> renderValue 100 objUpd + -- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here. exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $ withInstantiatedFunType mn t $ \a b -> do body <- bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v - pure $ Abs (ssA ssb) (purusFun a b) name body - + pure $ Abs (ssA ssb) (function a b) name body -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction exprToCoreFn _ _ t lam@(A.Abs _ _) = - internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t) --- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code. --- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType --- TODO: Investigate whether still necessary -exprToCoreFn mn ss mTy app@(A.App v1 v2) - | isDictCtor v2 && isDictInstCase v1 = wrapTrace "exprToCoreFn APP DICT" $ do - v2' <- exprToCoreFn mn ss Nothing v2 - toBind <- mkDictInstBinder v1 - v1' <- bindLocalVariables toBind $ exprToCoreFn mn ss Nothing v1 - appT <- inferType mTy app - pure $ App (ss, [], Just IsSyntheticApp) (purusTy appT) v1' v2' - - - | otherwise = wrapTrace "exprToCoreFn APP" $ do - appT <- inferType mTy app - v1' <- exprToCoreFn mn ss Nothing v1 - v2' <- exprToCoreFn mn ss Nothing v2 - pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2' - where - mkDictInstBinder = \case - A.TypedValue _ e _ -> mkDictInstBinder e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do - let className :: Qualified (ProperName 'ClassName) = coerceProperName <$> cn - args' <- getTypeClassArgs className - let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show @Int i)) [1..] args' - dictTyCon = srcTypeConstructor (coerceProperName <$> cn) - dictTyFreeVars = foldl srcTypeApp dictTyCon args - ty = quantify dictTyFreeVars - pure [(A.NullSourceSpan,Ident "dict",ty,Defined)] - _ -> error "invalid dict accesor expr" - - isDictInstCase = \case - A.TypedValue _ e _ -> isDictInstCase e - A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name - _ -> False + 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 - isSynthetic = \case - A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 - A.Accessor _ v3 -> isSynthetic v3 - A.Var NullSourceSpan _ -> True - A.Unused{} -> True - _ -> False -- Dunno what to do here. Haven't encountered an Unused so far, will need to see one to figure out how to handle them exprToCoreFn _ _ _ (A.Unused _) = -- ????? need to figure out what this _is_ error "Don't know what to do w/ exprToCoreFn A.Unused" @@ -322,57 +373,66 @@ exprToCoreFn _ _ _ (A.Unused _) = -- ????? need to figure out what this _is_ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $ gets checkEnv >>= \env -> case lookupValue env ident of Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident - Nothing -> do - -- pEnv <- printEnv - traceM $ "No known type for identifier " <> show ident -- <> "\n in:\n" <> LT.unpack (pShow $ names env) - error "boom" + 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 mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do - -- NOTE/TODO: Don't need to call infer separately here - ifteTy <- inferType mTy ifte +exprToCoreFn mn ss (Just resT) (A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do condE <- exprToCoreFn mn ss (Just tyBoolean) cond - thE <- exprToCoreFn mn ss Nothing th - elE <- exprToCoreFn mn ss Nothing el - pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE] + thE <- exprToCoreFn mn ss (Just resT) th + elE <- exprToCoreFn mn ss (Just resT) el + pure $ Case (ss, [], Nothing) resT [condE] [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] (Right thE) , CaseAlternative [NullBinder (ssAnn ss)] (Right elE) ] +exprToCoreFn _ _ Nothing ifte@(A.IfThenElse _ _ _) = + internalError $ "Error while desugaring If-then-else expression. No type provided for:\n " <> renderValue 100 ifte + -- Constructor case is straightforward, we should already have all of the type info -exprToCoreFn _ _ mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do - env <- gets checkEnv - let ctorMeta = getConstructorMeta env name - ctorType <- inferType mTy ctor - pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name +exprToCoreFn _ _ (Just ctorTy) (A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do + ctorMeta <- flip getConstructorMeta name <$> getEnv + pure $ Var (ss, [], Just ctorMeta) (purusTy ctorTy) $ fmap properToIdent name +exprToCoreFn _ _ Nothing ctor@(A.Constructor _ _) = + internalError $ "Error while desugaring Constructor expression. No type provided for:\n" <> renderValue 100 ctor + -- Case expressions -exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do - traceM $ renderValue 100 astCase - caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in. - traceM "CASE.1" - ts <- traverse (infer >=> pure . tvType) vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list) - traceM $ ppType 100 caseTy - pTrace vs - vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe zipWithM +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' - where - tvType (TypedValue' _ _ t) = t +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. --- (I think we have to do this - the inferred type is "wrong" if it contains a class constraint) exprToCoreFn mn ss (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $ exprToCoreFn mn ss (Just ty) v +-- If we encounter a TypedValue w/o a supplied type, we use the annotated type exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $ exprToCoreFn mn ss (Just ty) v --- Let bindings. Complicated. + +-- Complicated. See `transformLetBindings` exprToCoreFn mn ss _ (A.Let w ds v) = wrapTrace "exprToCoreFn LET" $ case NE.nonEmpty ds of Nothing -> error "declarations in a let binding can't be empty" Just _ -> do - (decls,expr) <- transformLetBindings mn ss [] ds v -- see transformLetBindings + (decls,expr) <- transformLetBindings mn ss [] ds v pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr + +-- Pretty sure we should prefer the positioned SourceSpan exprToCoreFn mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $ exprToCoreFn mn ss ty v -exprToCoreFn _ _ _ e = - error $ "Unexpected value in exprToCoreFn mn: " ++ show e +-- Function should never reach this case, but there are a lot of AST Expressions that shouldn't ever appear here, so +-- we use a catchall case. +exprToCoreFn _ ss _ e = + internalError + $ "Unexpected value in exprToCoreFn:\n" + <> renderValue 100 e + <> "at position:\n" + <> show ss -- Desugars case alternatives from AST to CoreFn representation. altToCoreFn :: forall m @@ -419,10 +479,6 @@ altToCoreFn mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo an unknown type is correct *during the initial typechecking phase*, but it is disastrous for us because we need to preserve the quantifiers explicitly in the typed AST. - Both of these functions work for reasonably simple examples, but may fail in more complex cases. - The primary reason for this is: I'm not sure how to write PS source that contains some of the - weirder cases in the AST. We'll have to deal with any problems once we have examples that - clearly isolate the problematic syntax nodes. -} transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann) transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret) @@ -432,12 +488,12 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret --- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context -transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do - ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -} - if not (containsUnknowns ty) +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 - thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)]) + let thisDecl = [NonRec (ssA ss) ident e] let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret else error @@ -445,22 +501,31 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU <> showIdent' ident <> "'\ncontains unification variables:\n " <> ppType 1000 ty - <> "\nPlease add a type signature for '" <> showIdent' ident <> "'" + <> "\nIf this let-bound identifier occurs in a user-defined `let-binding`, please add a type signature for '" <> showIdent' ident <> "'" + <> "\nIf the identifier occurs in a compiler-generated `let-binding` with guards (e.g. in a guarded case branch), try removing the guarded expression (e.g. use a normal if-then expression)" -- NOTE/TODO: This is super hack-ey. Ugh. transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds - if null untyped - then do - let ds' = flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + -- All of the types in the binding group should be TypedValues (after my modifications to the typechecker) + -- NOTE: We re-implement part of TypeChecker.Types.typeDictionaryForBindingGroup here because it *could* try to do + -- type checking/inference, which we want to avoid (because it mangles our types) + let types = go <$> NEL.toList ((\(i, _, v) -> (i, v)) <$> ds) + case sequence types of + Right typed -> do + let ds' = flip map typed $ \((sann,iden),(expr,ty)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)] + dict = M.fromList $ flip map typed $ \(((ss,_),ident),(_,ty)) -> (Qualified (BySourcePos $ spanStart ss) ident, (ty, Private, Undefined)) bindNames dict $ do makeBindingGroupVisible thisDecl <- concat <$> traverse (declToCoreFn mn) ds' let seen' = seen ++ thisDecl transformLetBindings mn _ss seen' rest ret -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope. - else error + Left _ -> error $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n" - <> LT.unpack (pShow untyped) + <> LT.unpack (pShow $ lefts types) + where + go :: ((SourceAnn, Ident), A.Expr) -> Either ((SourceAnn,Ident), A.Expr) ((SourceAnn, Ident), (A.Expr, SourceType)) + go (annName,A.TypedValue _ expr ty) = Right (annName,(expr,ty)) + go (annName,other) = Left (annName,other) transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings" @@ -473,30 +538,33 @@ inferBinder' -> A.Binder -> m (M.Map Ident (SourceSpan, SourceType)) inferBinder' _ A.NullBinder = return M.empty -inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ unifyTypes val tyString >> return M.empty -inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ unifyTypes val tyChar >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ unifyTypes val tyInt >> return M.empty -inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ unifyTypes val tyNumber >> return M.empty -inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty +inferBinder' _ (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 - traceM (ppType 100 ty) - let (args, ret) = peelArgs ty - unifyTypes ret val -- TODO: Check whether necesseary? + Just (_, _, _ty, _) -> do + let ty = instantiate _ty cArgs + traceM $ "InferBinder CTOR TY:\n" <> ppType 100 ty + let (args, _) = peelArgs ty + traceM $ "InferBinder ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") args M.unions <$> zipWithM inferBinder' (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - -- NOTE: Maybe forbid invalid return types? - peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test. + peelArgs :: Type a -> ([Type a], Type a) peelArgs = go [] where - go args (ForAll _ _ _ _ innerTy _) = go args innerTy go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) 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 @@ -509,11 +577,11 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin -- The type-level labels are authoritative diff = S.difference typeKeys exprKeys if S.null diff - then deduceRowProperties (M.fromList rowItems) props' -- M.unions <$> zipWithM inferBinder' (snd <$> rowItems) (snd <$> props') + then deduceRowProperties (M.fromList rowItems) props' else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff where deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType)) - deduceRowProperties types [] = pure M.empty + deduceRowProperties _ [] = pure M.empty deduceRowProperties types ((lbl,bndr):rest) = case M.lookup lbl types of Nothing -> error $ "Cannot deduce type information for record with label " <> show lbl -- should be impossible after typechecking Just ty -> do @@ -521,8 +589,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin xs <- deduceRowProperties types rest pure $ M.union x xs -- TODO: Remove ArrayT pattern synonym -inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ do - M.unions <$> traverse (inferBinder' val) binders +inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $ M.unions <$> traverse (inferBinder' val) binders inferBinder' _ (A.LiteralBinder _ (ArrayLiteral _)) = internalError "bad type in array binder " inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $ warnAndRethrowWithPositionTC ss $ do @@ -530,10 +597,8 @@ inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMED return $ M.insert name (ss, val) m inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POSITIONEDBINDER" $ warnAndRethrowWithPositionTC pos $ inferBinder' val binder -inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do - (elabTy, kind) <- kindOf ty - checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner - unifyTypes val elabTy +inferBinder' _ (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do + (elabTy, _) <- kindOf ty inferBinder' elabTy binder inferBinder' _ A.OpBinder{} = internalError "OpBinder should have been desugared before inferBinder'" diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index d92ed3e88..0d630612b 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -4,16 +4,16 @@ module Language.PureScript.CoreFn.Desugar.Utils where import Prelude -import Prelude qualified as P 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) +import Language.PureScript.AST.Traversals (everythingOnValues, overTypes) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders (Binder(..)) import Language.PureScript.CoreFn.Expr (Expr(..), PurusType) @@ -30,18 +30,15 @@ import Language.PureScript.Environment ( dictTypeName, TypeClassData (typeClassArguments), function, - pattern (:->)) + pattern (:->), + isDictTypeName) import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName) -import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..)) -import Language.PureScript.AST.Binders qualified as A -import Language.PureScript.AST.Declarations qualified as A +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, - TypedValue'(TypedValue'), - infer ) + ( kindType ) import Language.PureScript.Errors ( MultipleErrors ) import Debug.Trace (traceM, trace) @@ -54,16 +51,154 @@ import Language.PureScript.TypeChecker.Monad getEnv, withScopedTypeVars, CheckState(checkCurrentModule, checkEnv), debugNames ) -import Language.PureScript.Pretty.Values (renderValue) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label(..)) +import Data.Bifunctor (Bifunctor(..)) +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 @@ -74,21 +209,13 @@ traverseLit f = \case ArrayLiteral xs -> ArrayLiteral <$> traverse f xs ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs --- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code) -inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType -inferType (Just t) _ = pure t -inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >> - infer e >>= \case - TypedValue' _ _ t -> do - traceM ("TYPE: " <> ppType 100 t) - pure t -- Wrapper around instantiatePolyType to provide a better interface withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann) withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of (a :-> b, replaceForalls, bindAct) -> bindAct $ replaceForalls <$> act a b - (other,_,_) -> error - $ "Internal error. Expected a function type, but got: " <> ppType 1000 other + (other,_,_) -> let !showty = LT.unpack (pShow other) + in error $ "Internal error. Expected a function type, but got: " <> showty {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that: - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function. @@ -105,22 +232,23 @@ withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of -- TODO: Explicitly return two sourcetypes for arg/return types instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a) instantiatePolyType mn = \case - ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of + ForAll ann vis var mbk t mSkol -> case instantiatePolyType mn t of (inner,g,act) -> let f = \case Abs ann' ty' ident' expr' -> - Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' + Abs ann' (ForAll ann vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr' other -> other -- FIXME: kindType? act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?) in (inner, f . g, act') - ConstrainedType _ Constraint{..} t -> case instantiatePolyType mn t of - (inner,g,act) -> - let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass - dictTyCon = srcTypeConstructor dictTyName - dictTy = foldl srcTypeApp dictTyCon constraintArgs - act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma - in (function dictTy inner,g,act') + fun@(a :-> _) -> 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 @@ -142,31 +270,55 @@ traceNameTypes = do will always give us a "wrong" type. Let's try fixing them in the context! -} -desugarConstraintType' :: SourceType -> SourceType -desugarConstraintType' = \case +desugarConstraintType :: SourceType -> SourceType +desugarConstraintType = \case ForAll a vis var mbk t mSkol -> - let t' = desugarConstraintType' t + let t' = desugarConstraintType t in ForAll a vis var mbk t' mSkol ConstrainedType _ Constraint{..} t -> - let inner = desugarConstraintType' t + let inner = desugarConstraintType t dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass dictTyCon = srcTypeConstructor dictTyName dictTy = foldl srcTypeApp dictTyCon constraintArgs in function dictTy inner other -> other -desugarConstraintType :: M m => Qualified Ident -> m () -desugarConstraintType i = do +desugarConstraintTypes :: M m => m () +desugarConstraintTypes = do env <- getEnv - let oldNameTypes = names env - case M.lookup i oldNameTypes of - Just (t,k,v) -> do - let newVal = (desugarConstraintType' t, k, v) - newNameTypes = M.insert i newVal oldNameTypes - newEnv = env {names = newNameTypes} - modify' $ \checkstate -> checkstate {checkEnv = newEnv} - - + let f = everywhereOnTypes desugarConstraintType + + oldNameTypes = names env + desugaredNameTypes = (\(st,nk,nv) -> (f st,nk,nv)) <$> oldNameTypes + + oldTypes = types env + desugaredTypes = first f <$> oldTypes + + oldCtors = dataConstructors env + desugaredCtors = (\(a,b,c,d) -> (a,b,f c,d)) <$> oldCtors + + oldSynonyms = typeSynonyms env + desugaredSynonyms = second f <$> oldSynonyms + + newEnv = env { names = desugaredNameTypes + , types = desugaredTypes + , dataConstructors = desugaredCtors + , typeSynonyms = desugaredSynonyms } + + modify' $ \checkstate -> checkstate {checkEnv = newEnv} + +desugarConstraintsInDecl :: A.Declaration -> A.Declaration +desugarConstraintsInDecl = \case + A.BindingGroupDeclaration decls -> + A.BindingGroupDeclaration + $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType expr)) <$> decls + A.ValueDecl ann name nk bs [A.MkUnguarded e] -> + A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType e] + A.DataDeclaration ann declTy tName args ctorDecs -> + let fixCtor (A.DataConstructorDeclaration a nm fields) + = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType) <$> fields) + in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs) + other -> other -- Gives much more readable output (with colors for brackets/parens!) than plain old `show` pTrace :: (Monad m, Show a) => a -> m () @@ -185,6 +337,94 @@ wrapTrace msg act = do startMsg = pad $ "BEGIN " <> msg endMsg = pad $ "END " <> msg +{- + This is used to solve a problem that arises with re-exported instances. + + 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 @@ -200,8 +440,9 @@ showIdent' :: Ident -> String showIdent' = T.unpack . runIdent -- | Turns a `Type a` into a `Type ()`. We shouldn't need source position information for types. -purusTy :: Type a -> PurusType -purusTy = fmap (const ()) +-- NOTE: Deprecated (probably) +purusTy :: SourceType -> PurusType +purusTy = id -- fmap (const ()) -- | Given a class name, return the TypeClassData associated with the name. getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index f243761e1..9b9591808 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -11,10 +11,10 @@ import Language.PureScript.AST.Literals (Literal) import Language.PureScript.CoreFn.Binders (Binder) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (Type) +import Language.PureScript.Types (Type, SourceType) -type PurusType = Type () +type PurusType = SourceType -- Type () -- | -- Data type for expressions and terms diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 4ae83fecf..1f083f51a 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -30,6 +30,10 @@ import Language.PureScript.Types () import Text.ParserCombinators.ReadP (readP_to_S) +-- dunno how to work around the orphan +instance FromJSON (Module Ann) where + parseJSON = fmap snd . moduleFromJSON + parseVersion' :: String -> Maybe Version parseVersion' str = case filter (null . snd) $ readP_to_S parseVersion str of diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 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/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs index 60975d76b..bb2af5892 100644 --- a/src/Language/PureScript/CoreFn/Pretty.hs +++ b/src/Language/PureScript/CoreFn/Pretty.hs @@ -1,226 +1,73 @@ -module Language.PureScript.CoreFn.Pretty where +module Language.PureScript.CoreFn.Pretty ( + module PRETTY, + ppType, + smartRender, + writeModule, + prettyModuleTxt, + renderExpr, + renderExprStr, + prettyTypeStr +) where import Prelude hiding ((<>)) -import Control.Arrow (second) - import Data.Text (Text) -import Data.List.NonEmpty qualified as NEL -import Data.Monoid qualified as Monoid ((<>)) import Data.Text qualified as T -import Language.PureScript.Environment +import System.IO (Handle) + import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Module -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Binders -import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName) -import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) -import Language.PureScript.Pretty.Types ( typeAsBox, typeAtomAsBox, prettyPrintObjectKey) -import Language.PureScript.Types (Constraint(..), Type) -import Language.PureScript.PSString (PSString, prettyPrintString) - -import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, hcat, vsep, (//), (<>), render) -import Language.PureScript.Pretty.Types -import Data.Map qualified as M - --- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack -ppType :: Int -> Type a -> String -ppType i t = go [] $ prettyPrintType i t - where - go :: String -> String -> String - go acc [] = acc - go acc (' ':xs) = case dropWhile (== ' ') xs of - [] -> acc - more -> go (acc `mappend` [' ']) more - go acc (x:xs) = go (acc `mappend` [x]) xs - -textT :: Text -> Box -textT = text . T.unpack - -oneLine :: String -> String -oneLine = filter (/= '\n') - --- | Render an aligned list of items separated with commas -list :: Char -> Char -> (a -> Box) -> [a] -> Box -list open close _ [] = text [open, close] -list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) - where - toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a - - -hlist :: Char -> Char -> (a -> Box) -> [a] -> Box -hlist open close _ [] = text [open, close] -hlist open close f xs = hcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) - where - toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a - - -ellipsis :: Box -ellipsis = text "..." - -prettyPrintObject :: Int -> [(PSString, Maybe (Expr a))] -> Box -prettyPrintObject d = hlist '{' '}' prettyPrintObjectProperty - where - prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Box - prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value - -prettyPrintUpdateEntry :: Int -> PSString -> Expr a -> Box -prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val - --- | Pretty-print an expression -prettyPrintValue :: Int -> Expr a -> Box --- prettyPrintValue d _ | d < 0 = text "..." -prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps -prettyPrintValue d (App ann _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") // (prettyPrintValue (d-1) val) -prettyPrintValue d (Case ann ty values binders) = - (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // - moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) -prettyPrintValue d (Let _ _ ds val) = - text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // - (text "in " <> prettyPrintValue (d - 1) val) --- TODO: constraint kind args -prettyPrintValue d (Literal _ _ l) = prettyPrintLiteralValue d l -prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr - --- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Int -> Expr a -> Box -prettyPrintValueAtom d (Literal _ _ l) = prettyPrintLiteralValue d l -prettyPrintValueAtom _ (Constructor _ _ _ name _) = text $ T.unpack $ runProperName name -prettyPrintValueAtom d (Var ann ty ident) = text . oneLine $ "(" ++ T.unpack (showIdent (disqualify ident)) ++ ": " ++ ppType d ty ++ ")" -prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" - -prettyPrintLiteralValue :: Int -> Literal (Expr a) -> Box -prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n -prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s -prettyPrintLiteralValue _ (CharLiteral c) = text $ show c -prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" -prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" -prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs -prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps - -prettyPrintDeclaration :: Int -> Bind a -> Box --- prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration d b = case b of - NonRec _ ident expr -> - vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr, -- not sure about the d here - text "\n" - ] - Rec bindings -> vsep 1 left $ map (\((_,ident),expr) -> - vcat left [ - text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr) ), - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr, - text "\n" - ]) bindings - -prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box --- prettyPrintCaseAlternative d _ | d < 0 = ellipsis -prettyPrintCaseAlternative d (CaseAlternative binders result) = - text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result - where - prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Box - prettyPrintResult = \case - Left ges -> vcat left $ map (prettyPrintGuardedValueSep' (text " | ")) ges - Right exp -> text " -> " <> prettyPrintValue (d-1) exp - - prettyPrintGuardedValueSep' :: Box -> (Guard a, Expr a) -> Box - prettyPrintGuardedValueSep' sep (guardE, resultE) = - prettyPrintValue (d-1) guardE <> text " -> " <> prettyPrintValue (d-1) resultE - - -prettyPrintModule :: Module a -> Box -prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) = - vcat left $ - [text (show modName ++ " (" ++ modPath ++ ")")] - ++ ["Imported Modules: "] - ++ map (moveRight 2 . text . show . snd) modImports - ++ ["Exports: "] - ++ map (moveRight 2 . text . T.unpack . showIdent) modExports - ++ ["Re-Exports: "] - ++ map (moveRight 2 . goReExport) (M.toList modReExports) - ++ ["Foreign: "] - ++ map (moveRight 2. text . T.unpack . showIdent) modForeign - ++ ["Declarations: "] - ++ map (prettyPrintDeclaration 0) modDecls - where - goReExport :: (ModuleName,[Ident]) -> Box - goReExport (mn,idents) = vcat left $ flip map idents $ \i -> text (show mn ++ "." ++ T.unpack (showIdent i)) - -prettyPrintModule' :: Module a -> String -prettyPrintModule' = render . prettyPrintModule - -renderExpr :: Int -> Expr a -> String -renderExpr i e = render $ prettyPrintValue i e -{- - prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v - prettyPrintResult gs = - vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) - - prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box - prettyPrintGuardedValueSep _ (GuardedExpr [] val) = - text " -> " <> prettyPrintValue (d - 1) val - - prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = - foldl1 before [ sep - , prettyPrintGuard guard - , prettyPrintGuardedValueSep sep (GuardedExpr [] val) - ] - - prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = - vcat left [ foldl1 before - [ sep - , prettyPrintGuard guard - ] - , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) - ] - - prettyPrintGuard (ConditionGuard cond) = - prettyPrintValue (d - 1) cond - prettyPrintGuard (PatternGuard binder val) = - foldl1 before - [ text (T.unpack (prettyPrintBinder binder)) - , text " <- " - , prettyPrintValue (d - 1) val - ] + ( 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. -} -prettyPrintBinderAtom :: Binder a -> Text -prettyPrintBinderAtom (NullBinder _) = "_" -prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l -prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident -prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) -prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder - -prettyPrintLiteralBinder :: Literal (Binder a) -> Text -prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str -prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) -prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num -prettyPrintLiteralBinder (BooleanLiteral True) = "true" -prettyPrintLiteralBinder (BooleanLiteral False) = "false" -prettyPrintLiteralBinder (ObjectLiteral bs) = - "{ " - Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) - Monoid.<> " }" - where - prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Text - prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder -prettyPrintLiteralBinder (ArrayLiteral bs) = - "[ " - Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) - Monoid.<> " ]" - --- | --- Generate a pretty-printed string representing a Binder --- -prettyPrintBinder :: Binder a -> Text -prettyPrintBinder (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder _ _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) -prettyPrintBinder b = prettyPrintBinderAtom b + +-- 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 b7a1fc708..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 diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index b456ba8eb..561da8c75 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -379,13 +379,18 @@ 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 () -> Type () +getFunArgTy :: Type a -> Type a getFunArgTy = \case a :-> _ -> a ForAll _ _ _ _ t _ -> getFunArgTy t 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 a808e992a..145f76b1c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -50,13 +50,14 @@ import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn qualified as CFT import Language.PureScript.CoreFn.Pretty qualified as CFT -import Language.PureScript.CoreFn.Module qualified as CFT import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +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. -- @@ -97,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 @@ -118,15 +119,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps - traceM "PURUS START HERE" - ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env') - traceM $ prettyEnv (checkEnv chkSt) - --mapM_ (traceM . show) . CFT.moduleDecls $ coreFn - traceM $ CFT.prettyPrintModule' 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, @@ -173,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 6739b4bf0..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,13 +21,13 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply (SupplyT) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (Value(String), (.=), object) +import Data.Aeson (Value(String), (.=), object, decode, encode, Result (..), fromJSON) import Data.Bifunctor (bimap, first) import Data.Either (partitionEithers) import Data.Foldable (for_) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe, maybeToList, fromJust) import Data.Set qualified as S import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -39,6 +40,7 @@ import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.CodeGen.UPLC qualified as PC import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.ToJSON qualified as CFJ +import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Prim qualified as Docs.Prim @@ -56,8 +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,11 +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" - UPLC -> outputFilename mn "index.cfn" + CoreFn -> outputFilename mn "index.cfn" + CheckCoreFn -> outputFilename mn "index.cfn" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -251,39 +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 UPLC codegenTargets) $ do + {- -when (S.member UPLC codegenTargets) $ do let coreFnFile = targetFilename mn UPLC json = CFJ.moduleToJSON Paths.version m lift $ writeJSONFile coreFnFile json - {- - when (S.member JS codegenTargets) $ do - foreignInclude <- case mn `M.lookup` foreigns of - Just _ - | not $ requiresForeign m -> do - return Nothing - | otherwise -> do - return $ Just "./foreign.js" - Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn - | otherwise -> return Nothing - rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO "get the current directory" getCurrentDirectory - let sourceMaps = S.member JSSourceMap codegenTargets - (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - jsFile = targetFilename mn JS - mapFile = targetFilename mn JSSourceMap - prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] - js = T.unlines $ map ("// " <>) prefix ++ [pjs] - mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" - lift $ do - writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) - when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings -} when (S.member Docs codegenTargets) $ do lift $ writeJSONFile (outputFilename mn "docs.json") docs - when (S.member UPLC codegenTargets) $ do - lift $ writeJSONFile (targetFilename mn UPLC) (moduleToJSON (makeVersion [0,0,1]) m) - -- uplc <- PC.moduleToUPLC m - -- lift $ PC.printUPLC uplc + when (S.member CoreFn codegenTargets) $ do + 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 @@ -439,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 @@ -455,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 059b27fb8..ae4131559 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -18,16 +18,21 @@ data Options = Options -- Default make options defaultOptions :: Options -defaultOptions = Options False False (S.singleton JS) +defaultOptions = Options False False (S.singleton CoreFn) -data CodegenTarget = JS | JSSourceMap | Docs | UPLC +data CodegenTarget + = Docs + | CoreFn + {- N.B. We need a compilation mode that tests for changes from existing serialized CoreFn. + This is the easiest way to implement that (though maybe we should do something else for the final version) + -} + | CheckCoreFn deriving (Eq, Ord, Show) codegenTargets :: Map String CodegenTarget codegenTargets = Map.fromList - [ ("js", JS) - , ("uplc", UPLC) - , ("sourcemaps", JSSourceMap) + [ ("coreFn", CoreFn) + , ("checkCoreFn", CheckCoreFn) -- , ("corefn", CoreFn) , ("docs", Docs) ] 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 7c2fc0134..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]) @@ -303,7 +303,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati -- NOTE: changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified {- -ByNullSourcePos -} (BySourcePos $ spanStart ss) dictObjIdent)) visibility = second (const TypeVarVisible) <$> args - in ValueDecl sa ident Private [] + in ValueDecl sa ident Public [] [MkUnguarded ( TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) @@ -363,7 +363,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = constrainedTy = quantify (foldr srcConstrainedType dictTy deps) dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props mkTV = if unreachable then TypedValue False (Var nullSourceSpan C.I_undefined) else TypedValue True dict - result = ValueDecl sa name Private [] [MkUnguarded (mkTV constrainedTy)] + result = ValueDecl sa name Public [] [MkUnguarded (mkTV constrainedTy)] return result where diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 396769a05..46be3f3e1 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -110,6 +110,7 @@ data CheckState = CheckState emptyCheckState :: Environment -> CheckState emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty + -- | Unification variables type Unknown = Int diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ddc38a416..9faf7830d 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -608,12 +608,15 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + TypedValue' chk val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + -- NOTE (from Sean): Returning a TypedValue gives us access to monomorphized types for un-annotated let bindings. + -- I'm not sure why they don't do this, perhaps there is a reason to avoid doing so? + let val'' = TypedValue chk val' valTy' bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val'']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds diff --git a/tests/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)