diff --git a/.gitignore b/.gitignore index f45c27f..ae43ec4 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ result-* /output/ .vscode/settings.json .envrc.local +.hspec-failures diff --git a/cabal.project b/cabal.project index 6e9ebf8..1685e78 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,8 @@ packages: *.cabal tests: True + +source-repository-package + type: git + location: https://github.com/Unisay/purescript-corefn + tag: 60ddb194187eccf298584253ade401339301d8bf + --sha256: sha256-mAiNHeadQXmY8/6VsrFnvRvYfZNZ0jkRPesXuNuPhdQ= diff --git a/exe/Cli.hs b/exe/Cli.hs index 839f586..8a9bef0 100644 --- a/exe/Cli.hs +++ b/exe/Cli.hs @@ -7,8 +7,8 @@ import Data.List.NonEmpty qualified as NE import Data.Tagged (Tagged (..)) import Data.Text (splitOn) import Data.Text qualified as Text -import Language.PureScript.Backend.Types (AppOrModule (..)) -import Language.PureScript.Names qualified as PS +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) +import Language.PureScript.CoreFn import Options.Applicative ( Parser , eitherReader @@ -112,7 +112,10 @@ options = do [ metavar "ENTRY" , short 'e' , long "entry" - , value $ AsApplication (PS.ModuleName "Main") (PS.Ident "main") + , value $ + AsApplication + (unsafeModuleNameFromText "Main") + (Ident "main") , helpDoc . Just $ vsep [ "Where to start compilation." @@ -130,15 +133,17 @@ options = do parseAppOrModule ∷ String → Either String AppOrModule parseAppOrModule s = case splitOn "." (toText s) of [] → Left "Invalid entry point format" - [name] | isModule name → pure . AsModule $ PS.ModuleName name - segments → do - let name = last (NE.fromList segments) - pure - if isModule name - then AsModule . PS.ModuleName $ Text.intercalate "." segments - else - let modname = Text.intercalate "." (init (NE.fromList segments)) - in AsApplication (PS.ModuleName modname) (PS.Ident name) + [name] | isModule name → maybeToRight "Invalid module name" do + AsModule <$> moduleNameFromText name + (NE.fromList → segments) → + case moduleNameFromText (Text.intercalate "." (init segments)) of + Nothing → Left $ "Invalid module name: " <> s + Just mn → + let segment = last segments + in Right + if isModule segment + then AsModule mn + else AsApplication mn (Ident segment) where isModule = Char.isAsciiUpper . Text.head diff --git a/exe/Main.hs b/exe/Main.hs index 1c66926..13f7a25 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,8 +9,8 @@ import Language.PureScript.Backend qualified as Backend import Language.PureScript.Backend.IR qualified as IR import Language.PureScript.Backend.Lua qualified as Lua import Language.PureScript.Backend.Lua.Printer qualified as Printer +import Language.PureScript.CoreFn.ModuleName (moduleNameToText) import Language.PureScript.CoreFn.Reader qualified as CoreFn -import Language.PureScript.Names (runIdent, runModuleName) import Main.Utf8 qualified as Utf8 import Path (Abs, Dir, Path, SomeBase (..), replaceExtension, toFilePath) import Path.IO qualified as Path @@ -107,13 +107,13 @@ handleLuaError = [ "Unexpected bound reference:" , show expr , "in module" - , runModuleName modname + , moduleNameToText modname ] Lua.LinkerErrorForeign e → die $ "Linker error:\n" <> show e Lua.AppEntryPointNotFound modname ident → die . toString $ "App entry point not found: " - <> runModuleName modname + <> moduleNameToText modname <> "." - <> runIdent ident + <> show ident diff --git a/flake.lock b/flake.lock index 7e7d4f9..1352a2a 100644 --- a/flake.lock +++ b/flake.lock @@ -141,11 +141,11 @@ "systems": "systems_2" }, "locked": { - "lastModified": 1710146030, - "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -171,55 +171,35 @@ "type": "github" } }, - "ghc910X": { - "flake": false, - "locked": { - "lastModified": 1711543129, - "narHash": "sha256-MUI07CxYOng7ZwHnMCw0ugY3HmWo2p/f4r07CGV7OAM=", - "ref": "ghc-9.10", - "rev": "6ecd5f2ff97af53c7334f2d8581651203a2c6b7d", - "revCount": 62607, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "ref": "ghc-9.10", - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, - "ghc911": { + "hackage": { "flake": false, "locked": { - "lastModified": 1711538967, - "narHash": "sha256-KSdOJ8seP3g30FaC2du8QjU9vumMnmzPR5wfkVRXQMk=", - "ref": "refs/heads/master", - "rev": "0acfe391583d77a72051d505f05fab0ada056c49", - "revCount": 62632, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" + "lastModified": 1746059277, + "narHash": "sha256-qZFW7A5SWMvXfsazI7GY+Fi0C4GepSbay7OrGQu2rp0=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "e5dda063af4baccaef266204560ab992ffe996b6", + "type": "github" }, "original": { - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" } }, - "hackage": { + "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1713659097, - "narHash": "sha256-HLnaRb/Q6hOnNj/5Unz7xsmO5b2gcrFr3nKdUQgMchQ=", + "lastModified": 1746059267, + "narHash": "sha256-01hyBjuVS90MnUzMpJZdnvpBCCXxc3LjGC1XGSBbF3Y=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "515f09ec65043eee03970616f389c379258d2c53", + "rev": "4a16cf04fa3ee0360ec30001953daff807fbb2b4", "type": "github" }, "original": { "owner": "input-output-hk", + "ref": "for-stackage", "repo": "hackage.nix", "type": "github" } @@ -233,41 +213,40 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc910X": "ghc910X", - "ghc911": "ghc911", "hackage": "hackage", + "hackage-for-stackage": "hackage-for-stackage", + "hls": "hls", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", + "hls-2.10": "hls-2.10", "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", "hls-2.7": "hls-2.7", + "hls-2.8": "hls-2.8", + "hls-2.9": "hls-2.9", "hpc-coveralls": "hpc-coveralls", - "hydra": "hydra", "iserv-proxy": "iserv-proxy", "nixpkgs": [ "haskellNix", "nixpkgs-unstable" ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2105": "nixpkgs-2105", - "nixpkgs-2111": "nixpkgs-2111", - "nixpkgs-2205": "nixpkgs-2205", - "nixpkgs-2211": "nixpkgs-2211", "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-2405": "nixpkgs-2405", + "nixpkgs-2411": "nixpkgs-2411", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1713660611, - "narHash": "sha256-v1234hmQ4kdOkWf+STY1tdeZM8V8hgU7tHqhgmoC1Bw=", + "lastModified": 1746060740, + "narHash": "sha256-y4aMWmH6JiAQS8q3CXTIJLKnSiQynlS1QoQF7Epam1A=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "f5b0f70e987cba6944121856973cbd1507053a20", + "rev": "0e7c929c4d26cd11e3fd69021c96f5d8d7d46d24", "type": "github" }, "original": { @@ -276,6 +255,22 @@ "type": "github" } }, + "hls": { + "flake": false, + "locked": { + "lastModified": 1741604408, + "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "682d6894c94087da5e566771f25311c47e145359", + "type": "github" + }, + "original": { + "owner": "haskell", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-1.10": { "flake": false, "locked": { @@ -310,6 +305,23 @@ "type": "github" } }, + "hls-2.10": { + "flake": false, + "locked": { + "lastModified": 1743069404, + "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.2": { "flake": false, "locked": { @@ -412,256 +424,150 @@ "type": "github" } }, - "hpc-coveralls": { + "hls-2.8": { "flake": false, "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "lastModified": 1715153580, + "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", "type": "github" }, "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "type": "github" - } - }, - "hydra": { - "inputs": { - "nix": "nix", - "nixpkgs": [ - "haskellNix", - "hydra", - "nix", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1671755331, - "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", - "owner": "NixOS", - "repo": "hydra", - "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "owner": "haskell", + "ref": "2.8.0.0", + "repo": "haskell-language-server", "type": "github" - }, - "original": { - "id": "hydra", - "type": "indirect" } }, - "iserv-proxy": { + "hls-2.9": { "flake": false, "locked": { - "lastModified": 1708894040, - "narHash": "sha256-Rv+PajrnuJ6AeyhtqzMN+bcR8z9+aEnrUass+N951CQ=", - "owner": "stable-haskell", - "repo": "iserv-proxy", - "rev": "2f2a318fd8837f8063a0d91f329aeae29055fba9", + "lastModified": 1719993701, + "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", "type": "github" }, "original": { - "owner": "stable-haskell", - "ref": "iserv-syms", - "repo": "iserv-proxy", + "owner": "haskell", + "ref": "2.9.0.1", + "repo": "haskell-language-server", "type": "github" } }, - "lowdown-src": { + "hpc-coveralls": { "flake": false, "locked": { - "lastModified": 1633514407, - "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", - "owner": "kristapsdz", - "repo": "lowdown", - "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", - "type": "github" - }, - "original": { - "owner": "kristapsdz", - "repo": "lowdown", - "type": "github" - } - }, - "nix": { - "inputs": { - "lowdown-src": "lowdown-src", - "nixpkgs": "nixpkgs", - "nixpkgs-regression": "nixpkgs-regression" - }, - "locked": { - "lastModified": 1661606874, - "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", - "owner": "NixOS", - "repo": "nix", - "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "2.11.0", - "repo": "nix", - "type": "github" - } - }, - "nixpkgs": { - "locked": { - "lastModified": 1657693803, - "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-22.05-small", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2003": { - "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2105": { - "locked": { - "lastModified": 1659914493, - "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2111": { - "locked": { - "lastModified": 1659446231, - "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.11-darwin", - "repo": "nixpkgs", + "owner": "sevanspowell", + "repo": "hpc-coveralls", "type": "github" } }, - "nixpkgs-2205": { + "iserv-proxy": { + "flake": false, "locked": { - "lastModified": 1685573264, - "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "lastModified": 1742121966, + "narHash": "sha256-x4bg4OoKAPnayom0nWc0BmlxgRMMHk6lEPvbiyFBq1s=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "e9dc86ed6ad71f0368c16672081c8f26406c3a7e", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.05-darwin", - "repo": "nixpkgs", + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", "type": "github" } }, - "nixpkgs-2211": { + "nixpkgs-2305": { "locked": { - "lastModified": 1688392541, - "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "lastModified": 1705033721, + "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-22.11-darwin", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2305": { + "nixpkgs-2311": { "locked": { - "lastModified": 1701362232, - "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", + "lastModified": 1719957072, + "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", + "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-23.05-darwin", + "ref": "nixpkgs-23.11-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2311": { + "nixpkgs-2405": { "locked": { - "lastModified": 1701386440, - "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "lastModified": 1735564410, + "narHash": "sha256-HB/FA0+1gpSs8+/boEavrGJH+Eq08/R2wWNph1sM1Dg=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "rev": "1e7a8f391f1a490460760065fa0630b5520f9cf8", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-23.11-darwin", + "ref": "nixpkgs-24.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-regression": { + "nixpkgs-2411": { "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "lastModified": 1739151041, + "narHash": "sha256-uNszcul7y++oBiyYXjHEDw/AHeLNp8B6pyWOB+RLA/4=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "rev": "94792ab2a6beaec81424445bf917ca2556fbeade", "type": "github" }, "original": { "owner": "NixOS", + "ref": "nixpkgs-24.11-darwin", "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, "nixpkgs-unstable": { "locked": { - "lastModified": 1694822471, - "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", + "lastModified": 1737110817, + "narHash": "sha256-DSenga8XjPaUV5KUFW/i3rNkN7jm9XmguW+qQ1ZJTR4=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "rev": "041c867bad68dfe34b78b2813028a2e2ea70a23c", "type": "github" }, "original": { "owner": "NixOS", + "ref": "nixpkgs-unstable", "repo": "nixpkgs", - "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" } }, @@ -696,11 +602,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1713658249, - "narHash": "sha256-+fjl407ii7vN2GazvewniOmriimgV4uRJussDJB7Ssg=", + "lastModified": 1745539978, + "narHash": "sha256-0J+/+5ApD/rgxRKk7A+F0DKWo5j59ARGxEfKo3bNsR0=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "8387248af9b576dd2f4057690e79e533d42fa6ca", + "rev": "66b79101570fc437b81d3ae4b7b7948271943cfd", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 3ccb1da..29a38fb 100644 --- a/flake.nix +++ b/flake.nix @@ -84,7 +84,6 @@ } ); - # --- Flake Local Nix Configuration ---------------------------- nixConfig = { extra-substituters = [ "https://cache.iog.io" diff --git a/hie.yaml b/hie.yaml index 41f3c8e..2d66ed6 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,3 +6,5 @@ cradle: component: "lib:pslua" - path: "test" component: "pslua:test:spec" + +sessionLoading: multiComponent diff --git a/lib/Language/PureScript/Backend.hs b/lib/Language/PureScript/Backend.hs index bd020d5..53913f6 100644 --- a/lib/Language/PureScript/Backend.hs +++ b/lib/Language/PureScript/Backend.hs @@ -10,7 +10,7 @@ import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule) import Language.PureScript.Backend.Lua qualified as Lua import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk) import Language.PureScript.Backend.Lua.Types qualified as Lua -import Language.PureScript.Backend.Types (AppOrModule (..), entryPointModule) +import Language.PureScript.Backend.AppOrModule (AppOrModule (..), entryPointModule) import Language.PureScript.CoreFn.Reader qualified as CoreFn import Path (Abs, Dir, Path, SomeBase) import Prelude hiding (show) diff --git a/lib/Language/PureScript/Backend/AppOrModule.hs b/lib/Language/PureScript/Backend/AppOrModule.hs new file mode 100644 index 0000000..a6cf04e --- /dev/null +++ b/lib/Language/PureScript/Backend/AppOrModule.hs @@ -0,0 +1,13 @@ +module Language.PureScript.Backend.AppOrModule where + +import Language.PureScript.CoreFn qualified as Cfn + +data AppOrModule + = AsApplication Cfn.ModuleName Cfn.Ident + | AsModule Cfn.ModuleName + deriving stock (Show) + +entryPointModule ∷ AppOrModule → Cfn.ModuleName +entryPointModule = \case + AsApplication modname _ident → modname + AsModule modname → modname diff --git a/lib/Language/PureScript/Backend/IR.hs b/lib/Language/PureScript/Backend/IR.hs index 993e3c0..6bfb3d1 100644 --- a/lib/Language/PureScript/Backend/IR.hs +++ b/lib/Language/PureScript/Backend/IR.hs @@ -17,11 +17,10 @@ import Language.PureScript.Backend.IR.Inliner (Annotation) import Language.PureScript.Backend.IR.Inliner qualified as Inliner import Language.PureScript.Backend.IR.Names import Language.PureScript.Backend.IR.Types -import Language.PureScript.Comments (Comment (..)) +import Language.PureScript.Backend.Lua.Fixture (runtimeLazyName) +import Language.PureScript.Backend.Lua.Name qualified as Name import Language.PureScript.CoreFn qualified as Cfn import Language.PureScript.CoreFn.Laziness (applyLazinessTransform) -import Language.PureScript.Names qualified as Names -import Language.PureScript.Names qualified as PS import Language.PureScript.PSString ( PSString , decodeString @@ -111,8 +110,8 @@ parseAnnotations ∷ Cfn.Module Cfn.Ann → Either CoreFnError (Map Name Annotat parseAnnotations currentModule = Cfn.moduleComments currentModule & foldMapM \case - LineComment line → pure <$> parsePragmaLine line - BlockComment block → traverse parsePragmaLine (lines block) + Cfn.LineComment line → pure <$> parsePragmaLine line + Cfn.BlockComment block → traverse parsePragmaLine (lines block) & fmap (Map.fromList . catMaybes) where parsePragmaLine ∷ Text → Either CoreFnError (Maybe Inliner.Pragma) @@ -137,9 +136,10 @@ mkImports = do pure $ -- it's ok to always add prim as an explicit import: -- DCE removes it if it's not used. - ModuleName "Prim" : [i | (_ann, i) ← moduleImports, isIncluded moduleName i] + Cfn.unsafeModuleNameFromText "Prim" + : [i | (_ann, i) ← moduleImports, isIncluded moduleName i] where - isIncluded ∷ PS.ModuleName → ModuleName → Bool + isIncluded ∷ ModuleName → ModuleName → Bool isIncluded currentModule modname = modname /= currentModule mkExports ∷ RepM [Name] @@ -168,7 +168,7 @@ collectDataDeclarations cfnModules = Map.unions do | ctors ← List.groupBy ((==) `on` fst) - [ (mkTyName tyName, (mkCtorName ctorName, mkFieldName <$> fields)) + [ (mkTyName tyName, (mkCtorName ctorName, identToFieldName <$> fields)) | bind ← Cfn.moduleBindings cfnModule , Cfn.Constructor _ann tyName ctorName fields ← boundExp bind ] @@ -181,14 +181,25 @@ collectDataDeclarations cfnModules = Map.unions do Cfn.Rec bindingGroup → snd <$> bindingGroup Cfn.NonRec _ann _ident expr → [expr] -mkQualified ∷ (a → n) → PS.Qualified a → Qualified n -mkQualified f (PS.Qualified by a) = +mkQualified ∷ (a → n) → Cfn.Qualified a → Qualified n +mkQualified f (Cfn.Qualified by a) = case by of - PS.BySourcePos _sourcePos → Local (f a) - PS.ByModuleName mn → Imported mn (f a) + Cfn.BySourcePos _sourcePos → Local (f a) + Cfn.ByModuleName mn → Imported mn (f a) -identToName ∷ PS.Ident → Name -identToName = Name . PS.runIdent +identToName ∷ Cfn.Ident → Name +identToName = Name . identToText + +identToFieldName ∷ Cfn.Ident → FieldName +identToFieldName = FieldName . identToText + +identToText ∷ Cfn.Ident → Text +identToText = \case + Cfn.Ident ident → ident + Cfn.GenIdent name n → maybe "$" ("$" <>) name <> toText (show n) + Cfn.UnusedIdent → "$__unused" + Cfn.InternalIdent Cfn.RuntimeLazyFactory → Name.toText runtimeLazyName + Cfn.InternalIdent (Cfn.Lazy t) → "Lazy_" <> t mkBindings ∷ RepM [Binding] mkBindings = do @@ -258,9 +269,9 @@ mkLiteral ann = \case mkConstructor ∷ Cfn.Ann → Ann - → PS.ProperName 'PS.TypeName - → PS.ProperName 'PS.ConstructorName - → [PS.Ident] + → Cfn.ProperName 'Cfn.TypeName + → Cfn.ProperName 'Cfn.ConstructorName + → [Cfn.Ident] → RepM Exp mkConstructor cfnAnn ann properTyName properCtorName fields = do let tyName = mkTyName properTyName @@ -276,16 +287,13 @@ mkConstructor cfnAnn ann properTyName properCtorName fields = do contextModuleName tyName (mkCtorName properCtorName) - (mkFieldName <$> fields) - -mkTyName ∷ PS.ProperName 'PS.TypeName → TyName -mkTyName = TyName . PS.runProperName + (identToFieldName <$> fields) -mkCtorName ∷ PS.ProperName 'PS.ConstructorName → CtorName -mkCtorName = CtorName . PS.runProperName +mkTyName ∷ Cfn.ProperName 'Cfn.TypeName → TyName +mkTyName = TyName . Cfn.runProperName -mkFieldName ∷ PS.Ident → FieldName -mkFieldName = FieldName . PS.runIdent +mkCtorName ∷ Cfn.ProperName 'Cfn.ConstructorName → CtorName +mkCtorName = CtorName . Cfn.runProperName mkPropName ∷ PSString → RepM PropName mkPropName str = case decodeString str of @@ -305,11 +313,11 @@ mkObjectUpdate cfnExp props = do Nothing → throwContextualError EmptyObjectUpdate Just ps → pure $ ObjectUpdate noAnn expr ps -mkAbstraction ∷ Ann → PS.Ident → CfnExp → RepM Exp +mkAbstraction ∷ Ann → Cfn.Ident → CfnExp → RepM Exp mkAbstraction ann i e = Abs ann param <$> makeExpr e where param ∷ Parameter Ann = - case PS.runIdent i of + case identToText i of "$__unused" → paramUnused n → paramNamed (Name n) @@ -319,17 +327,17 @@ mkApplication e1 e2 = then makeExpr e2 else application <$> makeExpr e1 <*> makeExpr e2 -mkQualifiedIdent ∷ PS.Qualified PS.Ident → RepM (Qualified Name) -mkQualifiedIdent (PS.Qualified by ident) = +mkQualifiedIdent ∷ Cfn.Qualified Cfn.Ident → RepM (Qualified Name) +mkQualifiedIdent (Cfn.Qualified by ident) = gets (Cfn.moduleName . contextModule) <&> \contextModuleName → case by of - PS.BySourcePos _sourcePos → Local $ identToName ident - PS.ByModuleName modName → + Cfn.BySourcePos _sourcePos → Local $ identToName ident + Cfn.ByModuleName modName → if modName == contextModuleName then Local (identToName ident) else Imported modName (identToName ident) -mkRef ∷ PS.Qualified PS.Ident → RepM Exp +mkRef ∷ Cfn.Qualified Cfn.Ident → RepM Exp mkRef = (\n → Ref noAnn n 0) <<$>> mkQualifiedIdent mkLet ∷ Ann → [Cfn.Bind Cfn.Ann] → CfnExp → RepM Exp @@ -597,7 +605,7 @@ mkBinder matchExp = go mempty Local tyName → (contextModuleName,tyName,) <$> algebraicTy contextModuleName tyName - let ctrName = mkCtorName (Names.disqualify qCtorName) + let ctrName = mkCtorName (Cfn.disqualify qCtorName) pure Match { matchExp @@ -735,7 +743,7 @@ data CoreFnError = CoreFnError instance Show CoreFnError where show CoreFnError {currentModule, reason} = "in module " - <> toString (runModuleName currentModule) + <> toString (moduleNameToText currentModule) <> ": " <> show reason diff --git a/lib/Language/PureScript/Backend/IR/Linker.hs b/lib/Language/PureScript/Backend/IR/Linker.hs index c4d5210..b47c669 100644 --- a/lib/Language/PureScript/Backend/IR/Linker.hs +++ b/lib/Language/PureScript/Backend/IR/Linker.hs @@ -6,7 +6,7 @@ import Data.Graph (graphFromEdges', reverseTopSort) import Data.Map qualified as Map import Language.PureScript.Backend.IR.Inliner qualified as Inline import Language.PureScript.Backend.IR.Names - ( ModuleName (..) + ( ModuleName , Name (..) , PropName (PropName) , QName (QName) diff --git a/lib/Language/PureScript/Backend/IR/Names.hs b/lib/Language/PureScript/Backend/IR/Names.hs index 68672f3..a4d7503 100644 --- a/lib/Language/PureScript/Backend/IR/Names.hs +++ b/lib/Language/PureScript/Backend/IR/Names.hs @@ -13,10 +13,13 @@ module Language.PureScript.Backend.IR.Names ) where import Data.Char (isAlphaNum) -import Language.PureScript.Names as Reexport - ( ModuleName (..) - , moduleNameFromString - , runModuleName +import Language.PureScript.CoreFn qualified as Cfn +import Language.PureScript.CoreFn.ModuleName as Reexport + ( ModuleName + , isBuiltinModuleName + , moduleNameFromText + , moduleNameToText + , unsafeModuleNameFromText ) import Quiet (Quiet (..)) import Text.Megaparsec qualified as Megaparsec @@ -35,7 +38,7 @@ data QName = QName {qnameModuleName ∷ ModuleName, qnameName ∷ Name} printQName ∷ QName → Text printQName QName {..} = - runModuleName qnameModuleName <> "∷" <> nameToText qnameName + Cfn.moduleNameToText qnameModuleName <> "∷" <> nameToText qnameName newtype TyName = TyName {renderTyName ∷ Text} deriving newtype (Eq, Ord) diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs index 14891f0..e3de414 100644 --- a/lib/Language/PureScript/Backend/IR/Optimizer.hs +++ b/lib/Language/PureScript/Backend/IR/Optimizer.hs @@ -12,7 +12,11 @@ import Language.PureScript.Backend.IR.Names , Qualified (Local) , qualifiedQName ) -import Language.PureScript.Backend.IR.Query (collectBoundNames) +import Language.PureScript.Backend.IR.Query + ( collectBoundNames + , countFreeRef + , countFreeRefs + ) import Language.PureScript.Backend.IR.Types ( Ann , Exp @@ -23,8 +27,6 @@ import Language.PureScript.Backend.IR.Types , RewriteRule , Rewritten (..) , bindingExprs - , countFreeRef - , countFreeRefs , getAnn , isNonRecursiveLiteral , literalBool @@ -171,12 +173,12 @@ idempotently = fix $ \i f a → let a' = f a in if a' == a then a else i f a' --- if a' == a --- then tr "FIXPOINT" a a --- else tr "RETRYING" a' (i f a') +-- if a' == a +-- then tr "FIXPOINT" a a +-- else tr "RETRYING" a' (i f a') -- where -- tr ∷ Show x ⇒ String → x → y → y --- tr l x y = trace ("\n\n" <> l <> "\n" <> (toString . pShow) x <> "\n") y +-- tr l x = trace ("\n\n" <> l <> "\n" <> (toString . pShow) x <> "\n") optimizeModule ∷ UberModule → UberModule optimizeModule UberModule {..} = @@ -279,7 +281,7 @@ etaReduce ∷ RewriteRule Ann etaReduce = pure . \case Abs _ (ParamNamed _ param) (App _ m (Ref _ (Local param') 0)) - | param == param' → + | param == param' && countFreeRef (Local param) m == 0 → Rewritten Recurse m _ → NoChange diff --git a/lib/Language/PureScript/Backend/IR/Query.hs b/lib/Language/PureScript/Backend/IR/Query.hs index 08ff8c6..c1e0d58 100644 --- a/lib/Language/PureScript/Backend/IR/Query.hs +++ b/lib/Language/PureScript/Backend/IR/Query.hs @@ -3,23 +3,105 @@ module Language.PureScript.Backend.IR.Query where import Control.Lens.Plated (transformMOf) import Control.Monad.Trans.Accum (add, execAccum) import Data.Map qualified as Map +import Data.MonoidMap (MonoidMap) +import Data.MonoidMap qualified as MMap import Data.Set qualified as Set import Language.PureScript.Backend.IR.Linker (UberModule (..)) import Language.PureScript.Backend.IR.Names ( Name (Name) , Qualified (Imported, Local) - , runModuleName + , moduleNameToText ) import Language.PureScript.Backend.IR.Types ( Exp + , Grouping (..) + , Index + , Parameter (..) + , RawExp (..) , bindingNames - , countFreeRef - , countFreeRefs , listGrouping , subexpressions ) import Language.PureScript.Backend.IR.Types qualified as IR -import Language.PureScript.Names (runtimeLazyName) +import Language.PureScript.Backend.Lua.Fixture qualified as Fixture +import Language.PureScript.Backend.Lua.Name qualified as Name + +countFreeRefs ∷ RawExp ann → Map (Qualified Name) Natural +countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty + where + countFreeRefs' + ∷ Map (Qualified Name) Index + → RawExp ann + → MonoidMap (Qualified Name) (Sum Natural) + countFreeRefs' minIndexes = \case + Ref _ann qname index → + if Map.findWithDefault 0 qname minIndexes <= index + then MMap.singleton qname (Sum 1) + else mempty + Abs _ann param body → + case param of + ParamNamed _paramAnn name → countFreeRefs' minIndexes' body + where + minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes + ParamUnused _paramAnn → countFreeRefs' minIndexes body + Let _ann binds body → fold (countsInBody : countsInBinds) + where + countsInBody = countFreeRefs' minIndexes' body + where + minIndexes' = + foldr (\name → Map.insertWith (+) name 1) minIndexes $ + toList binds >>= fmap Local . bindingNames + countsInBinds = + toList binds >>= \case + Standalone (_nameAnn, boundName, expr) → + [countFreeRefs' minIndexes' expr] + where + minIndexes' = Map.insertWith (+) (Local boundName) 1 minIndexes + RecursiveGroup recBinds → + toList recBinds <&> \(_nameAnn, _boundName, expr) → + countFreeRefs' minIndexes' expr + where + minIndexes' = + foldr + (\(_nameAnn, qName, _expr) → Map.insertWith (+) (Local qName) 1) + minIndexes + recBinds + App _ann argument function → + go argument <> go function + LiteralArray _ann as → + foldMap go as + LiteralObject _ann props → + foldMap (go . snd) props + ReflectCtor _ann a → + go a + DataArgumentByIndex _ann _idx a → + go a + Eq _ann a b → + go a <> go b + ArrayLength _ann a → + go a + ArrayIndex _ann a _indx → + go a + ObjectProp _ann a _prop → + go a + ObjectUpdate _ann a patches → + go a <> foldMap (go . snd) patches + IfThenElse _ann p th el → + go p <> go th <> go el + -- Terminals: + LiteralInt {} → mempty + LiteralBool {} → mempty + LiteralFloat {} → mempty + LiteralString {} → mempty + LiteralChar {} → mempty + Ctor {} → mempty + Exception {} → mempty + ForeignImport {} → mempty + where + go = countFreeRefs' minIndexes + +countFreeRef ∷ Qualified Name → RawExp ann → Natural +countFreeRef name = Map.findWithDefault 0 name . countFreeRefs usesRuntimeLazy ∷ UberModule → Bool usesRuntimeLazy UberModule {uberModuleBindings, uberModuleExports} = @@ -31,7 +113,7 @@ usesRuntimeLazy UberModule {uberModuleBindings, uberModuleExports} = findRuntimeLazyInExpr ∷ Exp → Bool findRuntimeLazyInExpr expr = - countFreeRef (Local (Name runtimeLazyName)) expr > 0 + countFreeRef (Local (Name (Name.toText Fixture.runtimeLazyName))) expr > 0 usesPrimModule ∷ UberModule → Bool usesPrimModule UberModule {uberModuleBindings, uberModuleExports} = @@ -45,7 +127,7 @@ findPrimModuleInExpr ∷ Exp → Bool findPrimModuleInExpr expr = Map.keys (countFreeRefs expr) & any \case Local _name → False - Imported moduleName _name → runModuleName moduleName == "Prim" + Imported moduleName _name → moduleNameToText moduleName == "Prim" collectBoundNames ∷ Exp → Set Name collectBoundNames = diff --git a/lib/Language/PureScript/Backend/IR/Types.hs b/lib/Language/PureScript/Backend/IR/Types.hs index 7783e7c..6178430 100644 --- a/lib/Language/PureScript/Backend/IR/Types.hs +++ b/lib/Language/PureScript/Backend/IR/Types.hs @@ -5,8 +5,6 @@ module Language.PureScript.Backend.IR.Types where import Control.Lens (Prism', Traversal', makePrisms, prism') import Data.Deriving (deriveEq1, deriveOrd1) import Data.Map qualified as Map -import Data.MonoidMap (MonoidMap) -import Data.MonoidMap qualified as MMap import Language.PureScript.Backend.IR.Inliner qualified as Inliner import Language.PureScript.Backend.IR.Names ( CtorName (renderCtorName) @@ -16,7 +14,7 @@ import Language.PureScript.Backend.IR.Names , PropName , Qualified (..) , TyName (renderTyName) - , runModuleName + , moduleNameToText ) import Prelude hiding (show) @@ -147,7 +145,7 @@ isRecursiveLiteral = \case ctorId ∷ ModuleName → TyName → CtorName → Text ctorId modName tyName ctorName = - runModuleName modName + moduleNameToText modName <> "∷" <> renderTyName tyName <> "." @@ -489,82 +487,7 @@ rewriteExpTopDownM rewrite = visit IfThenElse ann <$> visit p <*> visit th <*> visit el _ → pure e -countFreeRefs ∷ RawExp ann → Map (Qualified Name) Natural -countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty - where - countFreeRefs' - ∷ Map (Qualified Name) Index - → RawExp ann - → MonoidMap (Qualified Name) (Sum Natural) - countFreeRefs' minIndexes = \case - Ref _ann qname index → - if Map.findWithDefault 0 qname minIndexes <= index - then MMap.singleton qname (Sum 1) - else mempty - Abs _ann param body → - case param of - ParamNamed _paramAnn name → countFreeRefs' minIndexes' body - where - minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes - ParamUnused _paramAnn → countFreeRefs' minIndexes body - Let _ann binds body → fold (countsInBody : countsInBinds) - where - countsInBody = countFreeRefs' minIndexes' body - where - minIndexes' = - foldr (\name → Map.insertWith (+) name 1) minIndexes $ - toList binds >>= fmap Local . bindingNames - countsInBinds = - toList binds >>= \case - Standalone (_nameAnn, boundName, expr) → - [countFreeRefs' minIndexes' expr] - where - minIndexes' = Map.insertWith (+) (Local boundName) 1 minIndexes - RecursiveGroup recBinds → - toList recBinds <&> \(_nameAnn, _boundName, expr) → - countFreeRefs' minIndexes' expr - where - minIndexes' = - foldr - (\(_nameAnn, qName, _expr) → Map.insertWith (+) (Local qName) 1) - minIndexes - recBinds - App _ann argument function → - go argument <> go function - LiteralArray _ann as → - foldMap go as - LiteralObject _ann props → - foldMap (go . snd) props - ReflectCtor _ann a → - go a - DataArgumentByIndex _ann _idx a → - go a - Eq _ann a b → - go a <> go b - ArrayLength _ann a → - go a - ArrayIndex _ann a _indx → - go a - ObjectProp _ann a _prop → - go a - ObjectUpdate _ann a patches → - go a <> foldMap (go . snd) patches - IfThenElse _ann p th el → - go p <> go th <> go el - -- Terminals: - LiteralInt {} → mempty - LiteralBool {} → mempty - LiteralFloat {} → mempty - LiteralString {} → mempty - LiteralChar {} → mempty - Ctor {} → mempty - Exception {} → mempty - ForeignImport {} → mempty - where - go = countFreeRefs' minIndexes -countFreeRef ∷ Qualified Name → RawExp ann → Natural -countFreeRef name = Map.findWithDefault 0 name . countFreeRefs -- | Substitute the given variable name and index with an expression substitute diff --git a/lib/Language/PureScript/Backend/Lua.hs b/lib/Language/PureScript/Backend/Lua.hs index fff3710..8f2cc12 100644 --- a/lib/Language/PureScript/Backend/Lua.hs +++ b/lib/Language/PureScript/Backend/Lua.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Language.PureScript.Backend.Lua ( fromUberModule , fromIR @@ -19,20 +17,20 @@ import Data.Set qualified as Set import Data.Tagged (Tagged (..), untag) import Data.Text qualified as Text import Data.Traversable (for) +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) +import Language.PureScript.Backend.IR (ModuleName) import Language.PureScript.Backend.IR qualified as IR import Language.PureScript.Backend.IR.Linker (UberModule (..)) import Language.PureScript.Backend.IR.Linker qualified as Linker +import Language.PureScript.Backend.IR.Names (moduleNameToText) import Language.PureScript.Backend.IR.Query (usesRuntimeLazy) import Language.PureScript.Backend.Lua.Fixture qualified as Fixture import Language.PureScript.Backend.Lua.Key qualified as Key import Language.PureScript.Backend.Lua.Linker.Foreign qualified as Foreign import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Name qualified as Name -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua -import Language.PureScript.Backend.Types (AppOrModule (..)) -import Language.PureScript.Names (ModuleName (..), runModuleName) -import Language.PureScript.Names qualified as PS +import Language.PureScript.CoreFn qualified as Cfn import Path (Abs, Dir, Path) import Prelude hiding (exp, local) @@ -53,7 +51,7 @@ instance Monoid UsesObjectUpdate where data Error = UnexpectedRefBound ModuleName IR.Exp | LinkerErrorForeign Foreign.Error - | AppEntryPointNotFound ModuleName PS.Ident + | AppEntryPointNotFound ModuleName Cfn.Ident deriving stock (Show) fromUberModule @@ -102,21 +100,30 @@ fromUberModule foreigns needsRuntimeLazy appOrModule uber = (`evalStateT` 0) do pure ( DList.fromList foreignBindings <> bindings - , Lua.Return (Lua.ann returnExp) + , Lua.return returnExp ) - pure . mconcat $ - [ [Fixture.runtimeLazy | untag needsRuntimeLazy && usesRuntimeLazy uber] - , [Fixture.objectUpdate | UsesObjectUpdate ← [usesObjectUpdate]] - , [Lua.local1 Fixture.moduleName (Lua.table []) | not (null bindings)] - , toList (DList.snoc bindings returnStat) - ] + pure $ + DList.fromList + [ Fixture.runtimeLazy + | untag needsRuntimeLazy && usesRuntimeLazy uber + ] + <> DList.fromList + [ Fixture.objectUpdate + | UsesObjectUpdate ← [usesObjectUpdate] + ] + <> DList.fromList + [ Lua.local1 Fixture.moduleName (Lua.table []) + | not (null bindings) + ] + <> DList.snoc bindings returnStat mkBinding ∷ ModuleName → Lua.Name → Lua.Exp → Lua.Statement mkBinding modname name = Lua.assign $ Lua.VarField - (Lua.ann (Lua.varName Fixture.moduleName)) + Lua.newAnn + (Lua.var (Lua.varName Fixture.moduleName)) (qualifyName modname name) asExpression ∷ Either Lua.Chunk Lua.Exp → Lua.Exp @@ -134,7 +141,7 @@ fromNameWithIndex name (IR.unIndex → index) = else Name.makeSafe $ IR.nameToText name <> show index fromModuleName ∷ ModuleName → Lua.Name -fromModuleName = Name.makeSafe . runModuleName +fromModuleName = Name.makeSafe . moduleNameToText fromPropName ∷ IR.PropName → Lua.Name fromPropName (IR.PropName name) = Name.makeSafe name @@ -149,42 +156,45 @@ fromIR → LuaM e (Either Lua.Chunk Lua.Exp) fromIR foreigns topLevelNames modname ir = case ir of IR.LiteralInt _ann i → - pure . Right $ Lua.Integer i + pure . Right $ Lua.integer i IR.LiteralFloat _ann d → - pure . Right $ Lua.Float d + pure . Right $ Lua.float d IR.LiteralString _ann s → - pure . Right $ Lua.String s + pure . Right $ Lua.string s IR.LiteralChar _ann c → - pure . Right $ Lua.String $ Text.singleton c + pure . Right $ Lua.string $ Text.singleton c IR.LiteralBool _ann b → - pure . Right $ Lua.Boolean b + pure . Right $ Lua.boolean b IR.LiteralArray _ann exprs → Right . Lua.table <$> forM (zip [1 ..] exprs) \(i, e) → - Lua.tableRowKV (Lua.Integer i) <$> goExp e + Lua.tableRowKV (Lua.integer i) <$> goExp e IR.LiteralObject _ann kvs → Right . Lua.table <$> for kvs \(prop, exp) → Lua.tableRowNV (fromPropName prop) <$> goExp exp IR.ReflectCtor _ann e → - Right . (`Lua.varIndex` keyCtor) <$> goExp e + Right . Lua.var . (`Lua.varIndex` keyCtor) <$> goExp e IR.DataArgumentByIndex _ann i e → - Right . (`Lua.varField` Lua.unsafeName ("value" <> show i)) <$> goExp e + Right . Lua.var . (`Lua.varField` Lua.unsafeName ("value" <> show i)) + <$> goExp e IR.Eq _ann l r → Right <$> liftA2 Lua.equalTo (goExp l) (goExp r) IR.Ctor _ann _algebraicTy ctorModName ctorTyName ctorName fieldNames → pure . Right $ foldr wrap value args where - wrap name expr = Lua.functionDef [ParamNamed name] [Lua.return expr] + wrap name expr = Lua.functionDef [Lua.paramNamed name] [Lua.return expr] value = Lua.table $ ctorRow : attributes ctorId = IR.ctorId ctorModName ctorTyName ctorName - ctorRow = Lua.tableRowKV keyCtor (Lua.String ctorId) + ctorRow = Lua.tableRowKV keyCtor (Lua.string ctorId) args = Name.unsafeName . IR.renderFieldName <$> fieldNames - attributes = args <&> ap Lua.tableRowNV Lua.varName + attributes = args <&> ap Lua.tableRowNV (Lua.var . Lua.varName) IR.ArrayLength _ann e → Right . Lua.hash <$> goExp e IR.ArrayIndex _ann expr index → - Right . flip Lua.varIndex (Lua.Integer (fromIntegral index)) <$> goExp expr + Right . Lua.var . (`Lua.varIndex` Lua.integer (fromIntegral index)) + <$> goExp expr IR.ObjectProp _ann expr propName → - Right . flip Lua.varField (fromPropName propName) <$> goExp expr + Right . Lua.var . (`Lua.varField` fromPropName propName) + <$> goExp expr IR.ObjectUpdate _ann expr propValues → do add UsesObjectUpdate obj ← goExp expr @@ -192,32 +202,41 @@ fromIR foreigns topLevelNames modname ir = case ir of Lua.table <$> for (toList propValues) \(propName, e) → Lua.tableRowNV (fromPropName propName) <$> goExp e pure . Right $ - Lua.functionCall (Lua.varName Fixture.objectUpdateName) [obj, vals] + Lua.functionCall + (Lua.var (Lua.varName Fixture.objectUpdateName)) + [obj, vals] IR.Abs _ann param expr → do e ← goExp expr let luaParams = case param of IR.ParamUnused _ann → [] - IR.ParamNamed _ann name → [ParamNamed (fromName name)] + IR.ParamNamed _ann name → [Lua.paramNamed (fromName name)] pure . Right $ Lua.functionDef luaParams [Lua.return e] IR.App _ann expr arg → do e ← goExp expr Right . Lua.functionCall e <$> case arg of -- PS sometimes inserts syntetic unused argument "Prim.undefined" - IR.Ref _ann (IR.Imported (IR.ModuleName "Prim") (IR.Name "undefined")) _ → - pure [] - _ → goExp arg <&> \a → [a] + IR.Ref + _ann + (IR.Imported (Cfn.moduleNameToText → "Prim") (IR.Name "undefined")) + _ → + pure [] + _ → goExp arg <&> (: []) IR.Ref _ann qualifiedName index → pure . Right $ case qualifiedName of IR.Local name | topLevelName ← qualifyName modname (fromName name) , Set.member topLevelName topLevelNames → - Lua.varField (Lua.varName Fixture.moduleName) topLevelName + Lua.var $ + Lua.varField + (Lua.var (Lua.varName Fixture.moduleName)) + topLevelName IR.Local name → - Lua.varName (fromNameWithIndex name index) + Lua.var (Lua.varName (fromNameWithIndex name index)) IR.Imported modname' name → - Lua.varField - (Lua.varName Fixture.moduleName) - (qualifyName modname' (fromName name)) + Lua.var $ + Lua.varField + (Lua.var (Lua.varName Fixture.moduleName)) + (qualifyName modname' (fromName name)) IR.Let _ann bindings bodyExp → do body ← go bodyExp recs ← @@ -227,7 +246,7 @@ fromIR foreigns topLevelNames modname ir = case ir of IR.RecursiveGroup grp → do let binds = toList grp <&> \(_ann, fromName → name, _) → - Lua.Local + Lua.local ( if Set.member (qualifyName modname name) topLevelNames then qualifyName modname name else name @@ -237,14 +256,15 @@ fromIR foreigns topLevelNames modname ir = case ir of goExp expr <&> Lua.assign ( Lua.VarName + Lua.newAnn ( if Set.member (qualifyName modname name) topLevelNames then qualifyName modname name else name ) ) pure $ DList.fromList binds <> DList.fromList assignments - pure . Left . DList.toList $ - recs <> either DList.fromList (DList.singleton . Lua.return) body + pure . Left $ + recs <> either id (DList.singleton . Lua.return) body IR.IfThenElse _ann cond th el → do thenExp ← go th elseExp ← go el @@ -252,7 +272,10 @@ fromIR foreigns topLevelNames modname ir = case ir of let thenBranch = either id (pure . Lua.return) thenExp elseBranch = either id (pure . Lua.return) elseExp - pure $ Left [Lua.ifThenElse condExp thenBranch elseBranch] + pure $ + Left $ + DList.singleton $ + Lua.ifThenElse condExp (toList thenBranch) (toList elseBranch) IR.Exception _ann msg → pure . Right $ Lua.error msg IR.ForeignImport _ann _moduleName path annotatedNames → do @@ -263,7 +286,7 @@ fromIR foreigns topLevelNames modname ir = case ir of <$> Foreign.parseForeignSource (untag foreigns) path let foreignExports ∷ Lua.Exp = Lua.table - [ Lua.tableRowNV name (Lua.ForeignSourceExp src) + [ Lua.tableRowNV name (Lua.foreignExpression src) | (key, src) ← toList exports , -- Export tables can contain Lua-reserved words as keys -- for example: `{ ["for"] = 42 }` @@ -272,7 +295,12 @@ fromIR foreigns topLevelNames modname ir = case ir of ] pure case header of Nothing → Right foreignExports - Just fh → Left $ Lua.ForeignSourceStat fh : [Lua.return foreignExports] + Just fh → + Left $ + DList.fromList + [ Lua.foreignStatement fh + , Lua.return foreignExports + ] where go ∷ IR.Exp → LuaM e (Either Lua.Chunk Lua.Exp) go = fromIR foreigns topLevelNames modname @@ -281,7 +309,7 @@ fromIR foreigns topLevelNames modname ir = case ir of goExp = asExpression <<$>> go keyCtor ∷ Lua.Exp -keyCtor = Lua.String "$ctor" +keyCtor = Lua.string "$ctor" -------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------- diff --git a/lib/Language/PureScript/Backend/Lua/DCE.hs b/lib/Language/PureScript/Backend/Lua/DCE.hs index 7cc8b88..275a15b 100644 --- a/lib/Language/PureScript/Backend/Lua/DCE.hs +++ b/lib/Language/PureScript/Backend/Lua/DCE.hs @@ -1,6 +1,7 @@ module Language.PureScript.Backend.Lua.DCE where -import Control.Monad.Trans.Accum (add, execAccum) +import Control.Lens ((%~)) +import Control.Lens.Plated qualified as Plated import Data.DList (DList) import Data.DList qualified as DList import Data.Graph (Graph, Vertex, graphFromEdges, reachable) @@ -11,279 +12,288 @@ import Language.PureScript.Backend.Lua.Name (Name) import Language.PureScript.Backend.Lua.Name qualified as Name import Language.PureScript.Backend.Lua.Traversal ( Annotator (..) - , Visitor (..) + , Rewrites (..) , annotateStatementInsideOutM - , makeVisitor - , unAnnotateStatement - , visitStatementM + , makeRewrites + , rewriteStatementM + ) +import Language.PureScript.Backend.Lua.Types + ( Ann + , HasAnn (..) + , annL + , annOf ) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prelude hiding (exp) data DceMode = PreserveTopLevel | PreserveReturned -type Label = Text type Key = Int +type NodeEdges = (Text, Key, [Key]) -eliminateDeadCode ∷ DceMode → Lua.Chunk → Lua.Chunk -eliminateDeadCode dceMode chunk = do - unNodesStatement <$> dceChunk statementWithNodes +eliminateDeadCode ∷ DceMode → [Lua.Statement] → [Lua.Statement] +eliminateDeadCode dceMode stats = dceChunk annotatedStatements where - statementWithNodes ∷ [ANode Lua.StatementF] - statementWithNodes = makeNodesStatement chunk + annotatedStatements = dceAnnotatedStatements stats ( graph ∷ Graph - , _nodeFromVertex ∷ Vertex → (Label, Key, [Key]) + , _nodeFromVertex ∷ Vertex → NodeEdges , keyToVertex ∷ Key → Maybe Vertex - ) = graphFromEdges (DList.toList (adjacencyList statementWithNodes)) + ) = graphFromEdges nodesEdges - dceChunk ∷ [ANode Lua.StatementF] → [ANode Lua.StatementF] - dceChunk = foldMap $ toList . dceStatement + nodesEdges ∷ [NodeEdges] + nodesEdges = DList.toList (adjacencyList annotatedStatements) - dceStatement ∷ ANode Lua.StatementF → Maybe (ANode Lua.StatementF) - dceStatement vstat@(Node key scopes, statement) = + dceChunk = foldMap $ toList . dceStatement + dceStatement statement = case statement of - Lua.Local name value → + Lua.Local dceAnn name value → ifKeyIsReachable $ - node (Lua.Local name (dceExpression <$> value)) - Lua.Assign variable value → + Lua.Local (unDceAnn dceAnn) name (dceExpression <$> value) + Lua.Assign dceAnn variable value → ifKeyIsReachable $ - node (Lua.Assign (dceVar variable) (dceExpression value)) - Lua.IfThenElse i t e → + Lua.Assign (unDceAnn dceAnn) (dceVar variable) (dceExpression value) + Lua.IfThenElse dceAnn i t e → ifKeyIsReachable $ - node (Lua.IfThenElse (dceExpression i) (dceChunk t) (dceChunk e)) - Lua.Return exp → - Just $ node (Lua.Return (dceExpression exp)) - Lua.ForeignSourceStat {} → - Just vstat + Lua.IfThenElse + (unDceAnn dceAnn) + (dceExpression i) + (dceChunk t) + (dceChunk e) + Lua.Return dceAnn exp → + Just $ Lua.Return (unDceAnn dceAnn) (dceExpression exp) + Lua.ForeignSourceStat dceAnn s → + Just $ Lua.ForeignSourceStat (unDceAnn dceAnn) s where - node = (Node key scopes,) + key = keyOf statement ifKeyIsReachable preserved = do vertex ← keyToVertex key guard (Set.member vertex reachableVertices) $> preserved - dceExpression ∷ ANode Lua.ExpF → ANode Lua.ExpF - dceExpression originalExpr@(Node key scope, expr) = - case expr of - Lua.Nil → originalExpr - Lua.Boolean _bool → originalExpr - Lua.Integer _int → originalExpr - Lua.Float _double → originalExpr - Lua.String _text → originalExpr - Lua.Function params body → - dce (Lua.Function (dceParams params) (dceChunk body)) - Lua.TableCtor rows → - dce (Lua.TableCtor (dceTableRow <$> rows)) - Lua.UnOp op e → - dce (Lua.UnOp op (dceExpression e)) - Lua.BinOp op e1 e2 → - dce (Lua.BinOp op (dceExpression e1) (dceExpression e2)) - Lua.Var v → - dce (Lua.Var (dceVar v)) - Lua.FunctionCall e es → - dce (Lua.FunctionCall (dceExpression e) (dceExpression <$> es)) - Lua.ForeignSourceExp _src → - originalExpr - where - dce = (Node key scope,) - - dceParams ∷ [ANode Lua.ParamF] → [ANode Lua.ParamF] - dceParams paramNodes = do - node@(Node key scopes, param) ← paramNodes - case param of - Lua.ParamUnused → [node] - Lua.ParamNamed _ → do - vertex ← maybeToList $ keyToVertex key + dceExpression ∷ Lua.ExpF DceAnn → Lua.Exp + dceExpression expr = case expr of + Lua.Nil dceAnn → + Lua.Nil (unDceAnn dceAnn) + Lua.Boolean dceAnn b → + Lua.Boolean (unDceAnn dceAnn) b + Lua.Integer dceAnn int → + Lua.Integer (unDceAnn dceAnn) int + Lua.Float dceAnn double → + Lua.Float (unDceAnn dceAnn) double + Lua.String dceAnn text → + Lua.String (unDceAnn dceAnn) text + Lua.Function dceAnn params body → + Lua.Function (unDceAnn dceAnn) (dceParams params) (dceChunk body) + Lua.TableCtor dceAnn rows → + Lua.TableCtor (unDceAnn dceAnn) (dceTableRow <$> rows) + Lua.UnOp dceAnn op e → + Lua.UnOp (unDceAnn dceAnn) op (dceExpression e) + Lua.BinOp dceAnn op e1 e2 → + Lua.BinOp (unDceAnn dceAnn) op (dceExpression e1) (dceExpression e2) + Lua.Var dceAnn v → + Lua.Var (unDceAnn dceAnn) (dceVar v) + Lua.FunctionCall dceAnn e es → + Lua.FunctionCall + (unDceAnn dceAnn) + (dceExpression e) + (dceExpression <$> es) + Lua.ForeignSourceExp dceAnn src → + Lua.ForeignSourceExp (unDceAnn dceAnn) src + + dceParams ∷ [Lua.ParamF DceAnn] → [Lua.Param] + dceParams paramNodes = + paramNodes >>= \case + Lua.ParamUnused dceAnn → [Lua.ParamUnused (unDceAnn dceAnn)] + p@(Lua.ParamNamed dceAnn name) → do + vertex ← maybeToList $ keyToVertex $ keyOf p if Set.member vertex reachableVertices - then [node] - else [(Node key scopes, Lua.ParamUnused)] - - dceTableRow ∷ ANode Lua.TableRowF → ANode Lua.TableRowF - dceTableRow (Node key scope, row) = - case row of - Lua.TableRowKV k v → - dce (Lua.TableRowKV (dceExpression k) (dceExpression v)) - Lua.TableRowNV n e → - dce (Lua.TableRowNV n (dceExpression e)) - where - dce = (Node key scope,) - - dceVar ∷ ANode Lua.VarF → ANode Lua.VarF - dceVar node@(Node key scope, variable) = - case variable of - Lua.VarName _qname → - node - Lua.VarIndex e1 e2 → - (Node key scope, Lua.VarIndex (dceExpression e1) (dceExpression e2)) - Lua.VarField e _name → - (Node key scope, Lua.VarField (dceExpression e) _name) + then [Lua.ParamNamed (unDceAnn dceAnn) name] + else [Lua.ParamUnused (unDceAnn dceAnn)] + + dceTableRow ∷ Lua.TableRowF DceAnn → Lua.TableRow + dceTableRow = \case + Lua.TableRowKV dceAnn k v → + Lua.TableRowKV (unDceAnn dceAnn) (dceExpression k) (dceExpression v) + Lua.TableRowNV dceAnn n e → + Lua.TableRowNV (unDceAnn dceAnn) n (dceExpression e) + + dceVar ∷ Lua.VarF DceAnn → Lua.Var + dceVar = \case + Lua.VarName dceAnn name → + Lua.VarName (unDceAnn dceAnn) name + Lua.VarIndex dceAnn e1 e2 → + Lua.VarIndex (unDceAnn dceAnn) (dceExpression e1) (dceExpression e2) + Lua.VarField dceAnn e name → + Lua.VarField (unDceAnn dceAnn) (dceExpression e) name reachableVertices ∷ Set Vertex - reachableVertices = Set.fromList $ reachable graph =<< dceEntryVertices + reachableVertices = + let reachables = reachable graph + in Set.fromList (dceEntryVertices >>= reachables) dceEntryVertices ∷ [Vertex] dceEntryVertices = case dceMode of - PreserveReturned → - case viaNonEmpty last statementWithNodes of - Just (Node k0 _scope0, Lua.Return (Node k1 _scope1, _stat)) → - mapMaybe keyToVertex [k0, k1] - _ → [] - PreserveTopLevel → - mapMaybe (keyToVertex . keyOf . nodeOf) statementWithNodes + PreserveTopLevel → mapMaybe (keyToVertex . keyOf) annotatedStatements + PreserveReturned → case viaNonEmpty last annotatedStatements of + Just (Lua.Return (DceAnn _ann k _scopes) exp) → + mapMaybe keyToVertex [k, keyOf exp] + _ → [] -------------------------------------------------------------------------------- -- Building graph from adjacency list ------------------------------------------ -adjacencyList ∷ [ANode Lua.StatementF] → DList (Label, Key, [Key]) +adjacencyList ∷ [Lua.StatementF DceAnn] → DList NodeEdges adjacencyList = (`go` mempty) where go - ∷ [ANode Lua.StatementF] - → DList (Label, Key, [Key]) - → DList (Label, Key, [Key]) + ∷ [Lua.StatementF DceAnn] + → DList NodeEdges + → DList NodeEdges go [] acc = acc - go ((Node key _scope, statement) : nextStatements) acc = go nextStatements do - acc <> case statement of - Lua.Local name value → - DList.cons - ( "Local(" <> Name.toText name <> ")" - , key - , case value of - Nothing → findAssignments name nextStatements - Just (n, _) → keyOf n : findAssignments name nextStatements - ) - (maybe mempty expressionAdjacencyList value) - Lua.Assign variable value → - DList.cons - ("Assign", key, [keyOf (nodeOf variable), keyOf (nodeOf value)]) - (varAdjacencyList variable <> expressionAdjacencyList value) - Lua.IfThenElse cond th el → - DList.cons - ( "IfThenElse" - , key - , keyOf (nodeOf cond) - : DList.toList (findReturns th <> findReturns el) - ) - (expressionAdjacencyList cond) - <> go th mempty - <> go el mempty - Lua.Return e → - DList.cons - ("Return", key, [keyOf (nodeOf e)]) - (expressionAdjacencyList e) - _ → mempty - -expressionAdjacencyList ∷ ANode Lua.ExpF → DList (Label, Key, [Key]) -expressionAdjacencyList (Node key _scope, expr) = + go (statement : nextStatements) acc = + go nextStatements $ + acc <> case statement of + Lua.Local _ann name value → + DList.cons + ( "Local(" <> Name.toText name <> ")" + , keyOf statement + , toList + let keys = findAssignments name nextStatements + in maybe keys (\expr → DList.cons (keyOf expr) keys) value + ) + (maybe mempty expressionAdjacencyList value) + Lua.Assign _ann variable value → + DList.cons + ("Assign", keyOf statement, [keyOf variable, keyOf value]) + (varAdjacencyList variable <> expressionAdjacencyList value) + Lua.IfThenElse _ann cond th el → + DList.cons + ( "IfThenElse" + , keyOf statement + , keyOf cond : DList.toList (findReturns th <> findReturns el) + ) + (expressionAdjacencyList cond) + <> go th DList.empty + <> go el DList.empty + Lua.Return _ann e → + DList.cons + ("Return", keyOf statement, [keyOf e]) + (expressionAdjacencyList e) + Lua.ForeignSourceStat {} → + pure ("ForeignSourceStat", keyOf statement, []) + +expressionAdjacencyList ∷ Lua.ExpF DceAnn → DList NodeEdges +expressionAdjacencyList expr = case expr of - Lua.Nil → pure ("Nil", key, []) - Lua.Boolean _bool → pure ("Boolean", key, []) - Lua.Integer _integer → pure ("Integer", key, []) - Lua.Float _double → pure ("Float", key, []) - Lua.String _text → pure ("String", key, []) - Lua.Function params body → + Lua.Nil _ann → pure ("Nil", keyOf expr, []) + Lua.Boolean _ann _bool → pure ("Boolean", keyOf expr, []) + Lua.Integer _ann _integer → pure ("Integer", keyOf expr, []) + Lua.Float _ann _double → pure ("Float", keyOf expr, []) + Lua.String _ann _text → pure ("String", keyOf expr, []) + Lua.Function _ann params body → DList.cons - ("Function", key, DList.toList (findReturns body)) - (foldMap (paramsAdjacencyList key) params <> adjacencyList body) - Lua.TableCtor rows → + ("Function", keyOf expr, DList.toList (findReturns body)) + (foldMap (paramsAdjacencyList (keyOf expr)) params <> adjacencyList body) + Lua.TableCtor _ann rows → DList.cons - ("TableCtor", key, keyOf . nodeOf <$> rows) + ("TableCtor", keyOf expr, keyOf <$> rows) (foldMap rowAdjacencyList rows) - Lua.UnOp _op e → - DList.cons ("UnOp", key, [keyOf (nodeOf e)]) (expressionAdjacencyList e) - Lua.BinOp _op e1 e2 → + Lua.UnOp _ann _op e → + DList.cons ("UnOp", keyOf expr, [keyOf e]) (expressionAdjacencyList e) + Lua.BinOp _ann _op e1 e2 → DList.cons - ("BinOp", key, [keyOf (nodeOf e1), keyOf (nodeOf e2)]) + ("BinOp", keyOf expr, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.Var variable → + Lua.Var _ann variable → DList.cons - ("Var", key, [keyOf (nodeOf variable)]) + ("Var", keyOf expr, [keyOf variable]) (varAdjacencyList variable) - Lua.FunctionCall e params → + Lua.FunctionCall _ann e params → DList.cons - ("FunctionCall", key, keyOf (nodeOf e) : map (keyOf . nodeOf) params) + ("FunctionCall", keyOf expr, keyOf e : map keyOf params) (expressionAdjacencyList e <> foldMap expressionAdjacencyList params) - Lua.ForeignSourceExp _src → - pure ("ForeignSourceExp", key, []) + Lua.ForeignSourceExp _ann _src → + pure ("ForeignSourceExp", keyOf expr, []) -paramsAdjacencyList ∷ Key → ANode Lua.ParamF → DList (Label, Key, [Key]) -paramsAdjacencyList fnKey (Node key _scopes, param) = +paramsAdjacencyList ∷ Key → Lua.ParamF DceAnn → DList NodeEdges +paramsAdjacencyList fnKey param = case param of - Lua.ParamUnused → + Lua.ParamUnused _ann → DList.empty - Lua.ParamNamed name → - DList.singleton ("ParamNamed(" <> Name.toText name <> ")", key, [fnKey]) + Lua.ParamNamed _ann name → + DList.singleton + ( "ParamNamed(" <> Name.toText name <> ")" + , keyOf param + , [fnKey] + ) -varAdjacencyList ∷ ANode Lua.VarF → DList (Label, Key, [Key]) -varAdjacencyList (Node key scopes, variable) = +varAdjacencyList ∷ Lua.VarF DceAnn → DList NodeEdges +varAdjacencyList variable = case variable of - Lua.VarName name → + Lua.VarName _ann name → DList.singleton ( "VarName(Local " <> Name.toText name <> ")" - , key - , toList (Map.lookup name (flatten scopes)) + , keyOf variable + , toList (Map.lookup name (flatten (scopesOf variable))) ) - Lua.VarIndex e1 e2 → + Lua.VarIndex _ann e1 e2 → DList.cons - ("VarIndex", key, [keyOf (nodeOf e1), keyOf (nodeOf e2)]) + ("VarIndex", keyOf variable, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.VarField e name → + Lua.VarField _ann e name → DList.cons - ("VarField(" <> Name.toText name <> ")", key, [keyOf (nodeOf e)]) + ( "VarField(" <> Name.toText name <> ")" + , keyOf variable + , [keyOf e] + ) (expressionAdjacencyList e) -rowAdjacencyList ∷ ANode Lua.TableRowF → DList (Label, Key, [Key]) -rowAdjacencyList (Node key _scope, row) = +rowAdjacencyList ∷ Lua.TableRowF DceAnn → DList NodeEdges +rowAdjacencyList row = case row of - Lua.TableRowKV e1@(n1, _) e2@(n2, _) → + Lua.TableRowKV _ann e1 e2 → DList.cons - ("Lua.TableRowKV", key, [keyOf n1, keyOf n2]) + ("Lua.TableRowKV", keyOf row, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.TableRowNV _name e@(n, _) → + Lua.TableRowNV _ann _name e → DList.cons - ("Lua.TableRowNV", key, [keyOf n]) + ("Lua.TableRowNV", keyOf row, [keyOf e]) (expressionAdjacencyList e) -------------------------------------------------------------------------------- -- Queries --------------------------------------------------------------------- -findReturns ∷ [ANode Lua.StatementF] → DList Key -findReturns = (keyOf . nodeOf <$>) . findReturnStatements +findReturns ∷ [Lua.StatementF DceAnn] → DList Key +findReturns = fmap keyOf . findReturnStatements -findReturnStatements ∷ [ANode Lua.StatementF] → DList (ANode Lua.StatementF) -findReturnStatements = foldMap \node@(_node, statement) → +findReturnStatements ∷ [Lua.StatementF DceAnn] → DList (Lua.StatementF DceAnn) +findReturnStatements = foldMap \statement → case statement of - Lua.Return _ → DList.singleton node - Lua.IfThenElse _cond th el → - DList.cons node (findReturnStatements th <> findReturnStatements el) + Lua.Return _ann _expr → DList.singleton statement + Lua.IfThenElse _ann _cond th el → + DList.cons statement (findReturnStatements th <> findReturnStatements el) _ → DList.empty -findAssignments ∷ Name → [ANode Lua.StatementF] → [Key] +findAssignments ∷ Name → [Lua.StatementF DceAnn] → DList Key findAssignments name = - toList . foldMap do - (`execAccum` DList.empty) - . visitStatementM - makeVisitor - { beforeStat = \node@(Node key _scope, statement) → - case statement of - Lua.Assign (Lua.Ann (Lua.VarName name')) _val - | name' == name → add (DList.singleton key) $> node - _ → pure node - } - -findVars ∷ Name → [ANode Lua.StatementF] → DList Key -findVars name = foldMap do (`execAccum` DList.empty) . visitStatementM visitor - where - visitor = - makeVisitor - { beforeExp = \node@(Node key _scope, expr) → - case expr of - Lua.Var (Lua.Ann (Lua.VarName name')) - | name' == name → - add (DList.singleton key) $> node - _ → pure node - } + foldMap $ + Lua.S >>> Plated.para \term rs → + case term of + Lua.S (Lua.Assign ann (Lua.VarName _ name') _val) + | name' == name → + DList.cons (annKey ann) (fold rs) + _ → fold rs + +findVars ∷ Name → [Lua.StatementF DceAnn] → DList Key +findVars name = + foldMap $ + Lua.S >>> Plated.para \term rs → + case term of + Lua.E (Lua.Var ann (Lua.VarName _ name')) + | name' == name → + DList.cons (annKey ann) (fold rs) + _ → fold rs -------------------------------------------------------------------------------- -- Annotating statements with graph keys --------------------------------------- @@ -298,85 +308,86 @@ flatten = ) Map.empty -data Node = Node Key [Scope] +data DceAnn = DceAnn Ann Key [Scope] deriving stock (Eq, Show) -type ANode f = Lua.Annotated Node f +unDceAnn ∷ DceAnn → Ann +unDceAnn (DceAnn a _key _scope) = a + +keyOf ∷ HasAnn f ⇒ f DceAnn → Key +keyOf = annKey . annOf -keyOf ∷ Node → Key -keyOf (Node key _scope) = key +annKey ∷ DceAnn → Key +annKey (DceAnn _ key _) = key -nodeOf ∷ ANode f → Node -nodeOf = fst +scopesOf ∷ HasAnn f ⇒ f DceAnn → [Scope] +scopesOf f = let DceAnn _ann _key scopes = annOf f in scopes -makeNodesStatement ∷ [Lua.Statement] → [ANode Lua.StatementF] -makeNodesStatement chunk = - evalState (forM chunk assignKeys) 0 & \keyedChunk → - evalState @[Scope] (assignScopes keyedChunk) [] +dceAnnotatedStatements ∷ [Lua.Statement] → [Lua.StatementF DceAnn] +dceAnnotatedStatements statements = + evalState (forM statements assignKeys) 0 & \keyedStatements → + evalState @[Scope] (assignScopes keyedStatements) [] -assignKeys ∷ Lua.Statement → State Key (ANode Lua.StatementF) +assignKeys ∷ Lua.Statement → State Key (Lua.StatementF DceAnn) assignKeys = annotateStatementInsideOutM Annotator - { unAnnotate = Lua.unAnn - , annotateStat = mkNodeWithKey - , annotateExp = mkNodeWithKey - , annotateRow = mkNodeWithKey - , annotateVar = mkNodeWithKey - , annotateParam = mkNodeWithKey + { withAnn = \a → state \key → (DceAnn a key mempty, key + 1) + , annotateStat = pure + , annotateExp = pure + , annotateVar = pure + , annotateParam = pure + , annotateRow = pure } - . Lua.ann - where - mkNodeWithKey ∷ f Node → State Key (ANode f) - mkNodeWithKey f = state \key → ((Node key mempty, f), key + 1) assignScopes - ∷ ∀ m. MonadScopes m ⇒ [ANode Lua.StatementF] → m [ANode Lua.StatementF] + ∷ ∀ m. MonadScopes m ⇒ [Lua.StatementF DceAnn] → m [Lua.StatementF DceAnn] assignScopes = traverse do - visitStatementM - makeVisitor + rewriteStatementM + makeRewrites { beforeStat = beforeStat + , beforeExpr = beforeExpr + , beforeVar = updateScopes + , beforeRow = updateScopes , afterStat = afterStat - , beforeExp = beforeExp - , beforeVar = mkNodeWithScopes - , beforeRow = mkNodeWithScopes } where - beforeStat ∷ ANode Lua.StatementF → m (ANode Lua.StatementF) - beforeStat node@(Node key _scopes, stat) = + beforeStat ∷ Lua.StatementF DceAnn → m (Lua.StatementF DceAnn) + beforeStat stat = case stat of - Lua.Local name _value → do + Lua.Local (DceAnn a key _scopes) name value → do scopes ← addName name key - pure (Node key (toList scopes), stat) - Lua.IfThenElse p t e → do + pure $ Lua.Local (DceAnn a key (toList scopes)) name value + Lua.IfThenElse (DceAnn a key _scopes) p t e → do t' ← addScope $> t e' ← addScope $> e scopes ← getScopes - pure (Node key (toList scopes), Lua.IfThenElse p t' e') - _ → pure node + pure $ Lua.IfThenElse (DceAnn a key (toList scopes)) p t' e' + _ → pure stat - afterStat ∷ Lua.StatementF Node → m (Lua.StatementF Node) - afterStat = \case - stat@Lua.Return {} → dropScope $> stat - other → pure other + afterStat ∷ Lua.StatementF DceAnn → m (Lua.StatementF DceAnn) + afterStat statement = + case statement of + Lua.Return {} → dropScope $> statement + _ → pure statement - beforeExp ∷ ANode Lua.ExpF → m (ANode Lua.ExpF) - beforeExp node@(Node key _scopes, expr) = + beforeExpr ∷ Lua.ExpF DceAnn → m (Lua.ExpF DceAnn) + beforeExpr expr = case expr of - Lua.Function argNodes _body → do + Lua.Function (DceAnn ann key _scopes) argNodes body → do _ ← addScope - for_ argNodes \(Node argKey _scopes, param) → + for_ argNodes \param → case param of - Lua.ParamUnused → pass - Lua.ParamNamed name → void $ addName name argKey - getScopes <&> \scopes → (Node key (toList scopes), expr) - _ → mkNodeWithScopes node - - mkNodeWithScopes ∷ (Node, t) → m (Node, t) - mkNodeWithScopes (Node key _scopes, t) = getScopes <&> ((,t) . Node key) - -unNodesStatement ∷ ANode Lua.StatementF → Lua.Statement -unNodesStatement = unAnnotateStatement Lua.unAnn + Lua.ParamUnused _ann → pass + Lua.ParamNamed _ann name → void $ addName name (keyOf param) + getScopes <&> \scopes → + Lua.Function (DceAnn ann key (toList scopes)) argNodes body + _ → pure expr + + updateScopes ∷ HasAnn f ⇒ f DceAnn → m (f DceAnn) + updateScopes f = do + scopes ← getScopes + pure $ f & annL %~ \(DceAnn a k _scopes) → DceAnn a k scopes class Monad m ⇒ MonadScopes m where addName ∷ Name → Key → m (NonEmpty Scope) diff --git a/lib/Language/PureScript/Backend/Lua/Fixture.hs b/lib/Language/PureScript/Backend/Lua/Fixture.hs index c341a20..0354626 100644 --- a/lib/Language/PureScript/Backend/Lua/Fixture.hs +++ b/lib/Language/PureScript/Backend/Lua/Fixture.hs @@ -27,7 +27,7 @@ runtimeLazyName = psluaName [name|runtime_lazy|] runtimeLazy ∷ Statement runtimeLazy = - ForeignSourceStat + foreignStatement [__i| local function #{Name.toText runtimeLazyName}(name) return function(init) @@ -56,7 +56,7 @@ objectUpdateName = psluaName [name|object_update|] objectUpdate ∷ Statement objectUpdate = - ForeignSourceStat + foreignStatement [__i| local function #{Name.toText objectUpdateName}(o, patches) local o_copy = {} diff --git a/lib/Language/PureScript/Backend/Lua/Name.hs b/lib/Language/PureScript/Backend/Lua/Name.hs index bf2e5cb..1330bf1 100644 --- a/lib/Language/PureScript/Backend/Lua/Name.hs +++ b/lib/Language/PureScript/Backend/Lua/Name.hs @@ -15,6 +15,7 @@ module Language.PureScript.Backend.Lua.Name ) where import Data.Char qualified as Char +import Data.Data (Data) import Data.Set qualified as Set import Data.Text qualified as Text import Language.Haskell.TH.Quote (QuasiQuoter (..)) @@ -24,7 +25,9 @@ import Text.Megaparsec.Char qualified as M import Prelude hiding (toText) newtype Name = Name {toText ∷ Text} + deriving stock (Data, Generic) deriving newtype (Eq, Ord, Show, Pretty) + deriving anyclass (NFData) name ∷ QuasiQuoter name = diff --git a/lib/Language/PureScript/Backend/Lua/Optimizer.hs b/lib/Language/PureScript/Backend/Lua/Optimizer.hs index bb815e9..7906b8a 100644 --- a/lib/Language/PureScript/Backend/Lua/Optimizer.hs +++ b/lib/Language/PureScript/Backend/Lua/Optimizer.hs @@ -1,55 +1,346 @@ +{-# LANGUAGE QuasiQuotes #-} + module Language.PureScript.Backend.Lua.Optimizer where +import Control.Lens ((^?)) +import Control.Lens.Plated (children) +import Control.Lens.Plated qualified as Plated import Control.Monad.Trans.Accum (Accum, add, execAccum) +import Data.DList (DList) +import Data.DList qualified as DL import Data.List qualified as List import Data.Map qualified as Map +import Data.Tree (Tree (..), foldTree) import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Traversal - ( everywhereExp - , everywhereInChunkM + ( everywhereInChunkM , everywhereStat , everywhereStatM ) -import Language.PureScript.Backend.Lua.Types - ( Chunk - , Exp - , ExpF (..) - , Statement - , StatementF (Local, Return) - , TableRowF (..) - , VarF (..) - , functionDef - , return - , unAnn - , pattern Ann - ) import Language.PureScript.Backend.Lua.Types qualified as Lua +import Text.Pretty.Simple import Prelude hiding (return) -optimizeChunk ∷ Chunk → Chunk -optimizeChunk = fmap optimizeStatement +optimizeChunk ∷ Lua.Chunk → Lua.Chunk +optimizeChunk = {- idempotently -} optimizeChunkOnce -substituteVarForValue ∷ Lua.Name → Exp → Chunk → Chunk -substituteVarForValue name inlinee = - runIdentity . everywhereInChunkM (pure . subst) pure +idempotently ∷ Eq a ⇒ (a → a) → a → a +idempotently = fix $ \i f a → + let a' = f a + in if a' == a then a else i f a' + +{- | Given a function @f@ and an initial value @t@, applies @f@ to @t@ once, +and in case of Nothing it terminates, otherwise repeatedly applies @f@ +to the result of the previous application until it no longer changes. +-} +everywhere ∷ (t → Maybe t) → t → Maybe t +everywhere f t = + case f t of + Nothing → Nothing + Just t' → everywhereUntilNothing f t' where - subst = \case - Lua.Var (Lua.unAnn → Lua.VarName varName) | varName == name → inlinee - expr → expr + everywhereUntilNothing ∷ (t → Maybe t) → t → Maybe t + everywhereUntilNothing g s = maybe (Just s) (everywhereUntilNothing g) (g s) -countRefs ∷ Statement → Map Lua.Name (Sum Natural) -countRefs = everywhereStatM pure countRefsInExpression >>> (`execAccum` mempty) +optimizeChunkOnce ∷ Lua.Chunk → Lua.Chunk +optimizeChunkOnce = go DL.empty . toList where - countRefsInExpression ∷ Exp → Accum (Map Lua.Name (Sum Natural)) Exp - countRefsInExpression = \case - expr@(Lua.Var (Lua.unAnn → Lua.VarName name)) → - add (Map.singleton name (Sum 1)) $> expr - expr → pure expr + go ∷ Lua.Chunk → [Lua.Statement] → Lua.Chunk + go optimizedStats remainingStats = + case remainingStats of + [] → optimizedStats + stat : stats → + let (optimizedStat, remainingStats') = optimizeStatement stat stats + in go (DL.snoc optimizedStats optimizedStat) remainingStats' + +optimizeStatement + ∷ Lua.Statement → [Lua.Statement] → (Lua.Statement, [Lua.Statement]) +optimizeStatement currentStat nextStats = + case currentStat of + Lua.Assign + ann + var + (Lua.Function _ args [Lua.Return _ (Lua.Function _ innerArgs innerBody)]) + | Just nextStats' {- everywhere -} ← (rewriteCurried var) nextStats → + ( go $ + Lua.Assign + ann + var + (Lua.functionDef (args ++ innerArgs) innerBody) + , go <$> nextStats' + ) + _stat → (go currentStat, go <$> nextStats) + where + go = everywhereStat identity optimizeExpression + +data AppliedHow = Unknown | NotApplied | AppliedOnce | AppliedAtLeastTwice + deriving stock (Eq, Show, Enum, Bounded) + +instance Semigroup AppliedHow where + Unknown <> b = b + a <> Unknown = a + a <> b = if fromEnum a < fromEnum b then a else b + +instance Monoid AppliedHow where + mempty = Unknown + +pattern NestedCall + ∷ Lua.VarF ann + -- ^ The var inside the inner function call + → ann + -- ^ The annotation of the outer function call + → [Lua.ExpF ann] + -- ^ The arguments of the outer function call + → [Lua.ExpF ann] + -- ^ The arguments of the inner function call + → Lua.ExpF ann + -- ^ The body of the inner function call + → Lua.TermF ann + -- ^ The outer function call +pattern NestedCall innerVar outerAnn outerArgs innerArgs innerCall ← + Lua.E + ( Lua.FunctionCall + outerAnn + innerCall@( Lua.FunctionCall + _innerAnn + (Lua.Var _varAnn innerVar) + innerArgs + ) + outerArgs + ) + +rewriteCurried ∷ Lua.Var → [Lua.Statement] → Maybe [Lua.Statement] +rewriteCurried var (map Lua.S → statTerms) = + case tr "appliedHow" (appliedHow var statTerms) of + Unknown → Nothing + NotApplied → Nothing + AppliedOnce → Nothing + AppliedAtLeastTwice → + Just $ + mapMaybe + ((^? Lua._S) . rewriteCurriedTerm var 2) + statTerms + +appliedHow ∷ Lua.Var → [Lua.Term] → AppliedHow +appliedHow var = foldMap appliedHowInTerm + where + appliedHowInTerm = + foldTree (\x xs → fold (x : xs)) . Plated.para \term subterms → + case term of + NestedCall var' _outerAnn _outerArgs _innerArgs _innerCall + | var == var' → Node AppliedAtLeastTwice (drop 1 subterms) + Lua.E (Lua.FunctionCall _ (Lua.Var _ var') _args) + | var == var' → Node AppliedOnce (drop 1 subterms) + Lua.V var' + | var == var' → Node NotApplied [] + _ → Node Unknown subterms + +rewriteCurriedTerm ∷ Lua.Var → Int → Lua.Term → Lua.Term +rewriteCurriedTerm var numApplications term0 = + case go term0 of Pass {resTerm} → resTerm + where + go ∷ Lua.Term → Res + go term = rewriteTerm term (go <$> children term) + where + passTerm = flip Pass Nothing -optimizeStatement ∷ Statement → Statement -optimizeStatement = everywhereStat identity optimizeExpression + rewriteTerm ∷ Lua.Term → [Res] → Res + rewriteTerm thisTerm resChildren = + force resChildren `seq` case thisTerm of + Lua.E (Lua.Function ann params _body) → + let body' = [s | Pass (Lua.S s) _ ← resChildren] + in passTerm (Lua.E (Lua.Function ann params body')) + Lua.E (Lua.FunctionCall ann appliedExpr _args) → + tr + "Lua.E (Lua.FunctionCall ann appliedExpr _args) →" + case resChildren of + Pass (Lua.E (Lua.Var _ var')) Nothing : passes + | var == var' → + tr "var == var'" $ + Pass + ( Lua.E + ( Lua.FunctionCall + ann + appliedExpr + [a | Pass (Lua.E a) _ ← passes] + ) + ) + (Just (1, numApplications)) + Pass (Lua.E subTerm) (Just (n, maxApplications)) : passes + | succ n == maxApplications → + tr "succ n == maxApplications" $ + Pass + ( collapseFunCalls + (succ n) + ( Lua.FunctionCall + ann + subTerm + [a | Pass (Lua.E a) _ ← passes] + ) + ) + Nothing + Pass _subTerm (Just (n, maxApplications)) : passes + | n < maxApplications → + tr "n < maxApplications" $ + Pass + ( Lua.E + ( Lua.FunctionCall + ann + appliedExpr + [a | Pass (Lua.E a) _ ← passes] + ) + ) + (Just (succ n, maxApplications)) + Pass (Lua.E fun) _ : passes → + tr "fun" $ + passTerm . Lua.E $ + Lua.functionCall fun [a | Pass (Lua.E a) _ ← passes] + _ → + tr "default" $ passTerm term + Lua.S (Lua.Assign ann name _expr) → + tr_ + "Lua.S (Lua.Assign ann name _expr) →" + case resChildren of + [Pass Lua.V {} _, Pass (Lua.E expr') _] → + passTerm (Lua.S (Lua.Assign ann name expr')) + _ → error "Impossible subexpressions: Assign" + Lua.S (Lua.Local ann name (Just _expr)) → + tr_ + "Lua.S (Lua.Local ann name (Just _expr)) →" + case resChildren of + [Pass (Lua.E expr') _info] → + passTerm (Lua.S (Lua.Local ann name (Just expr'))) + _ → error "Impossible subexpression: Local" + Lua.S (Lua.IfThenElse ann expr th el) → + tr_ "Lua.S (Lua.IfThenElse ann _expr th el) →" $ + case resChildren of + Pass (Lua.E expr') _info : _passes → + passTerm (Lua.S (Lua.IfThenElse ann expr' th el)) + res → + error $ + "Impossible subexpressions: IfThenElse, res =\n" + <> toText (pShow res) + Lua.S (Lua.Return ann _expr) → + tr_ + "Lua.S (Lua.Return ann _expr) →" + case resChildren of + [Pass (Lua.E expr') _info] → + passTerm (Lua.S (Lua.Return ann expr')) + _ → error "Impossible subexpressions: Return" + Lua.E (Lua.UnOp ann op _expr) → + tr_ + "Lua.E (Lua.UnOp ann op _expr) →" + case resChildren of + [Pass (Lua.E expr') _info] → + passTerm (Lua.E (Lua.UnOp ann op expr')) + _ → error "Impossible subexpressions: UnOp" + Lua.E (Lua.BinOp ann op _lhs _rhs) → + tr_ + "Lua.E (Lua.BinOp ann op _lhs _rhs) →" + case resChildren of + [Pass (Lua.E lhs') _, Pass (Lua.E rhs') _] → + passTerm (Lua.E (Lua.BinOp ann op lhs' rhs')) + _ → error "Impossible subexpressions: BinOp" + Lua.E (Lua.TableCtor ann _rows) → + tr_ "Lua.E (Lua.TableCtor ann _rows) →" $ + passTerm + (Lua.E (Lua.TableCtor ann [r | Pass (Lua.R r) _ ← resChildren])) + Lua.V (Lua.VarIndex ann _lhs _rhs) → + tr_ + "Lua.V (Lua.VarIndex ann _lhs _rhs) →" + case resChildren of + [Pass (Lua.E lhs') _, Pass (Lua.E rhs') _] → + passTerm (Lua.V (Lua.VarIndex ann lhs' rhs')) + _ → error "Impossible subexpressions: VarIndex" + Lua.V (Lua.VarField ann _expr field) → + tr_ + "Lua.V (Lua.VarField ann _expr field) →" + case resChildren of + [Pass (Lua.E expr') _] → + passTerm (Lua.V (Lua.VarField ann expr' field)) + _ → error "Impossible subexpressions: VarField" + Lua.R (Lua.TableRowKV ann _k _v) → + tr_ + "Lua.R (Lua.TableRowKV ann _k _v) →" + case resChildren of + [Pass (Lua.E k') _, Pass (Lua.E v') _] → + passTerm (Lua.R (Lua.TableRowKV ann k' v')) + _ → error "Impossible subexpressions: TableRowKV" + Lua.R (Lua.TableRowNV ann name _v) → + tr_ + "Lua.R (Lua.TableRowNV ann name _v) →" + case resChildren of + [Pass (Lua.E expr') _] → + passTerm (Lua.R (Lua.TableRowNV ann name expr')) + _ → error "Impossible subexpressions: TableRowNV" + _ → passTerm term -optimizeExpression ∷ Exp → Exp +data St = St + { appliedExpr ∷ Maybe Lua.Exp + , args ∷ DList Lua.Exp + , remainingApps ∷ Int + } + deriving stock (Show) + +collapseFunCalls ∷ Int → Lua.Exp → Lua.Term +collapseFunCalls n e + | n < 2 = Lua.E e + | otherwise = + go St {appliedExpr = Nothing, args = DL.empty, remainingApps = n} e + & \case + St {appliedExpr = Nothing} → error "collapseFunCalls: impossible" + St {appliedExpr = Just functionCall} → Lua.E functionCall + where + go ∷ St → Lua.Exp → St + go st = \case + Lua.FunctionCall ann expr args → + go st expr & \st' → + case st' of + St {appliedExpr, remainingApps, args = args'} + | remainingApps == 1 → + st' + { remainingApps = 0 + , appliedExpr = + Lua.FunctionCall ann + <$> appliedExpr + <*> pure (toList args' ++ normalizeArgs args) + , args = DL.empty + } + St {remainingApps, args = args'} + | remainingApps > 0 → + st' + { remainingApps = pred remainingApps + , args = args' <> normalizeArgs (DL.fromList args) + } + St {appliedExpr} → + st' + { appliedExpr = + Lua.FunctionCall ann + <$> appliedExpr + <*> pure args + } + expr → st {appliedExpr = Just expr} + + normalizeArgs ∷ (Foldable f, Applicative f) ⇒ f Lua.Exp → f Lua.Exp + normalizeArgs xs = if null xs then pure Lua.nil else xs + +data Res = Pass + { resTerm ∷ Lua.Term + , resInfo ∷ Maybe (Int, Int) + } + deriving stock (Show, Generic) + deriving anyclass (NFData) + +tr ∷ ∀ {a}. Show a ⇒ [Char] → a → a +tr x a = trace ("\n------------<" ++ x ++ ">----------\n" ++ toString (pShow a)) a + +trs ∷ Show a ⇒ [Char] → a → x → x +trs label a = trace ("\n------------<" ++ label ++ ">----------\n" ++ toString (pShow a)) + +tr_ ∷ ∀ {a}. [Char] → a → a +tr_ x = trace ("\n------------<" ++ x ++ ">----------\n") + +optimizeExpression ∷ Lua.Exp → Lua.Exp optimizeExpression = foldr (>>>) identity rewriteRulesInOrder rewriteRulesInOrder ∷ [RewriteRule] @@ -59,52 +350,64 @@ rewriteRulesInOrder = , reduceTableDefinitionAccessor ] -type RewriteRule = Exp → Exp - -rewriteExpWithRule ∷ RewriteRule → Exp → Exp -rewriteExpWithRule rule = everywhereExp rule identity +type RewriteRule = Lua.Exp → Lua.Exp -------------------------------------------------------------------------------- -- Rewrite rules for expressions ----------------------------------------------- pushDeclarationsDownTheInnerScope ∷ RewriteRule pushDeclarationsDownTheInnerScope = \case - Function outerArgs outerBody + Lua.Function _ outerArgs outerBody | Just lastStatement ← viaNonEmpty last outerBody - , Ann (Return (Ann (Function innerArgs innerBody))) ← lastStatement - , declarations ← unAnn <$> List.init outerBody + , Lua.Return _ (Lua.Function _ innerArgs innerBody) ← lastStatement + , declarations ← List.init outerBody , not (null declarations) , all isDeclaration declarations → - functionDef - (fmap unAnn outerArgs) - [ return $ - functionDef - (fmap unAnn innerArgs) - (declarations <> fmap unAnn innerBody) - ] + Lua.functionDef + outerArgs + [Lua.return $ Lua.functionDef innerArgs (declarations <> innerBody)] e → e where - isDeclaration ∷ Statement → Bool + isDeclaration ∷ Lua.Statement → Bool isDeclaration = \case - Local _ _ → True + Lua.Local {} → True + Lua.Assign {} → True _ → False removeScopeWhenInsideEmptyFunction ∷ RewriteRule removeScopeWhenInsideEmptyFunction = \case - Function + Lua.Function + _ outerArgs - [Ann (Return (Ann (FunctionCall (Ann (Function [] body)) [])))] → - Function outerArgs body + [Lua.Return _ (Lua.FunctionCall _ (Lua.Function _ [] body) [])] → + Lua.functionDef outerArgs body e → e -- | Rewrites '{ foo = 1, bar = 2 }.foo' to '1' reduceTableDefinitionAccessor ∷ RewriteRule reduceTableDefinitionAccessor = \case - Var (Ann (VarField (Ann (TableCtor rows)) accessedField)) → - fromMaybe Nil $ + Lua.Var _ (Lua.VarField _ (Lua.TableCtor _ rows) accessedField) → + fromMaybe Lua.nil $ listToMaybe [ fieldValue - | (_ann, TableRowNV tableField (Ann fieldValue)) ← rows + | Lua.TableRowNV _ tableField fieldValue ← rows , tableField == accessedField ] e → e + +substituteVarForValue ∷ Lua.Name → Lua.Exp → Lua.Chunk → Lua.Chunk +substituteVarForValue name inlinee = + runIdentity . everywhereInChunkM (pure . subst) pure + where + subst = \case + Lua.Var _ (Lua.VarName _ varName) | varName == name → inlinee + expr → expr + +countRefs ∷ Lua.Statement → Map Lua.Name (Sum Natural) +countRefs = everywhereStatM pure countRefsInExpression >>> (`execAccum` mempty) + where + countRefsInExpression ∷ Lua.Exp → Accum (Map Lua.Name (Sum Natural)) Lua.Exp + countRefsInExpression = \case + expr@(Lua.Var _ (Lua.VarName _ name)) → + add (Map.singleton name (Sum 1)) $> expr + expr → pure expr diff --git a/lib/Language/PureScript/Backend/Lua/Printer.hs b/lib/Language/PureScript/Backend/Lua/Printer.hs index 5e8b419..438e3d3 100644 --- a/lib/Language/PureScript/Backend/Lua/Printer.hs +++ b/lib/Language/PureScript/Backend/Lua/Printer.hs @@ -31,19 +31,19 @@ type ADoc = Doc () type PADoc = (Precedence, ADoc) printLuaChunk ∷ Lua.Chunk → ADoc -printLuaChunk = vsep . fmap printStatement +printLuaChunk = vsep . fmap printStatement . toList printStatement ∷ Lua.Statement → ADoc printStatement = \case - Lua.Assign (Ann variable) (Ann expr) → + Lua.Assign _ann variable expr → printAssign variable expr - Lua.Local name value → - printLocal name (printedExp . unAnn <$> value) - Lua.IfThenElse (Ann predicate) thenBlock elseBlock → - printIfThenElse predicate (unAnn <$> thenBlock) (unAnn <$> elseBlock) - Lua.Return (Ann expr) → + Lua.Local _ann name value → + printLocal name (printedExp <$> value) + Lua.IfThenElse _ann predicate thenBlock elseBlock → + printIfThenElse predicate thenBlock elseBlock + Lua.Return _ann expr → "return" <+> printedExp expr - Lua.ForeignSourceStat code → + Lua.ForeignSourceStat _ann code → pretty code printAssign ∷ Lua.Var → Lua.Exp → ADoc @@ -55,28 +55,34 @@ printedExp = snd . printExp printExp ∷ Lua.Exp → PADoc printExp = \case - Lua.Nil → (PrecAtom, "nil") - Lua.Boolean b → (PrecAtom, if b then "true" else "false") - Lua.Float f → (PrecAtom, pretty f) - Lua.Integer i → (PrecAtom, pretty i) - Lua.String t → (PrecAtom, dquotes (pretty t)) - Lua.Function args body → + Lua.Nil _ann → + (PrecAtom, "nil") + Lua.Boolean _ann b → + (PrecAtom, if b then "true" else "false") + Lua.Float _ann f → + (PrecAtom, pretty f) + Lua.Integer _ann i → + (PrecAtom, pretty i) + Lua.String _ann t → + (PrecAtom, dquotes (pretty t)) + Lua.Function _ann args body → let argNames = args >>= \case - Ann (ParamNamed n) → [n] - Ann ParamUnused → [] - in (PrecFunction, printFunction argNames (unAnn <$> body)) - Lua.TableCtor rows → (PrecTable, printTableCtor (unAnn <$> rows)) - Lua.UnOp op (Ann a) → printUnaryOp op (printExp a) - Lua.BinOp op (Ann l) (Ann r) → printBinaryOp op (printExp l) (printExp r) - Lua.Var (Ann v) → (PrecAtom, printVar v) - Lua.FunctionCall (Ann prefix) args → - ( PrecPrefix - , printFunctionCall - (printExp prefix) - (printExp . unAnn <$> args) - ) - Lua.ForeignSourceExp code → (PrecFunction, pretty code) + Lua.ParamNamed _ann n → [n] + Lua.ParamUnused _ann → [] + in (PrecFunction, printFunction argNames body) + Lua.TableCtor _ann rows → + (PrecTable, printTableCtor rows) + Lua.UnOp _ann op a → + printUnaryOp op (printExp a) + Lua.BinOp _ann op l r → + printBinaryOp op (printExp l) (printExp r) + Lua.Var _ann v → + (PrecAtom, printVar v) + Lua.FunctionCall _ann prefix args → + (PrecPrefix, printFunctionCall (printExp prefix) (printExp <$> args)) + Lua.ForeignSourceExp _ann code → + (PrecFunction, pretty code) printUnaryOp ∷ Lua.UnaryOp → PADoc → PADoc printUnaryOp op (_, a) = (prec op, pretty (sym op) <> parens a) @@ -100,16 +106,16 @@ printTableCtor tableRows = sep [lbrace, flex rows, rbrace] printRow ∷ Lua.TableRow → ADoc printRow = \case - Lua.TableRowKV (Ann kexp) (Ann vexp) → + Lua.TableRowKV _ann kexp vexp → brackets (printedExp kexp) <+> "=" <+> printedExp vexp - Lua.TableRowNV name (Ann vexp) → + Lua.TableRowNV _ann name vexp → printName name <+> "=" <+> printedExp vexp printVar ∷ Lua.Var → ADoc printVar = \case - Lua.VarName name → printName name - Lua.VarIndex (Ann e) (Ann i) → printedExp e <> brackets (printedExp i) - Lua.VarField (Ann e) n → wrapPrec PrecAtom (printExp e) <> "." <> printName n + Lua.VarName _ann name → printName name + Lua.VarIndex _ann e i → printedExp e <> brackets (printedExp i) + Lua.VarField _ann e n → wrapPrec PrecAtom (printExp e) <> "." <> printName n printFunctionCall ∷ PADoc → [PADoc] → ADoc printFunctionCall prefix args = diff --git a/lib/Language/PureScript/Backend/Lua/Traversal.hs b/lib/Language/PureScript/Backend/Lua/Traversal.hs index ff10980..5ef1638 100644 --- a/lib/Language/PureScript/Backend/Lua/Traversal.hs +++ b/lib/Language/PureScript/Backend/Lua/Traversal.hs @@ -14,10 +14,10 @@ everywhereStat everywhereStat f g = runIdentity . everywhereStatM (pure . f) (pure . g) everywhereInChunkM - ∷ Monad m + ∷ (Monad m, Traversable t) ⇒ (Exp → m Exp) → (Statement → m Statement) - → (Chunk → m Chunk) + → (t Statement → m (t Statement)) everywhereInChunkM f g = traverse (everywhereStatM g f) everywhereExpM @@ -29,23 +29,23 @@ everywhereExpM everywhereExpM f g = goe where goe = \case - Var (Ann v) → case v of - VarIndex (Ann e1) (Ann e2) → f =<< varIndex <$> goe e1 <*> goe e2 - VarField (Ann e) n → f . (`varField` n) =<< goe e - VarName n → f (varName n) - Function names statements → - f . functionDef (snd <$> names) - =<< forM statements (everywhereStatM g f . unAnn) - TableCtor (fmap unAnn → rows) → do + Var _ann v → case v of + VarIndex _ann e1 e2 → f . var =<< varIndex <$> goe e1 <*> goe e2 + VarField _ann e n → f . var . (`varField` n) =<< goe e + VarName _ann n → f (var (varName n)) + Function _ann names statements → + f . functionDef names + =<< forM statements (everywhereStatM g f) + TableCtor _ann rows → do tableRows ← forM rows \case - TableRowKV (Ann k) (Ann v) → tableRowKV <$> goe k <*> goe v - TableRowNV n (Ann e) → tableRowNV n <$> goe e + TableRowKV _ann k v → tableRowKV <$> goe k <*> goe v + TableRowNV _ann n e → tableRowNV n <$> goe e f $ table tableRows - UnOp op (Ann e) → + UnOp _ann op e → f . unOp op =<< goe e - BinOp op (Ann e1) (Ann e2) → + BinOp _ann op e1 e2 → f =<< binOp op <$> goe e1 <*> goe e2 - FunctionCall (Ann fn) (fmap unAnn → args) → + FunctionCall _ann fn args → f =<< functionCall <$> goe fn <*> forM args goe other → f other @@ -59,210 +59,255 @@ everywhereStatM f g = go where goe = everywhereExpM g f go = \case - Assign (Ann variable) (Ann value) → f . assign variable =<< goe value - Local name val → f . local name =<< forM val (goe . unAnn) - IfThenElse (Ann p) tb eb → do + Assign ann variable value → f . Assign ann variable =<< goe value + Local ann name val → f . Local ann name =<< forM val goe + IfThenElse ann p tb eb → do predicate ← goe p - thenBranch ← forM tb (go . unAnn) - elseBranch ← forM eb (go . unAnn) - f $ ifThenElse predicate thenBranch elseBranch - Return (Ann e) → f . Return . ann =<< goe e - ForeignSourceStat src → f $ ForeignSourceStat src + thenBranch ← forM tb go + elseBranch ← forM eb go + f $ IfThenElse ann predicate thenBranch elseBranch + Return ann e → f . Return ann =<< goe e + ForeignSourceStat ann src → f $ ForeignSourceStat ann src -------------------------------------------------------------------------------- -- Annotating ------------------------------------------------------------------ data Annotator m f f' = Annotator - { unAnnotate ∷ ∀ g. Annotated f g → g f - -- ^ How to remove an annotation - , annotateStat ∷ StatementF f' → m (Annotated f' StatementF) + { withAnn ∷ f → m f' + -- ^ How to update the annotation + , annotateStat ∷ StatementF f' → m (StatementF f') -- ^ How to annotate a statement - , annotateExp ∷ ExpF f' → m (Annotated f' ExpF) + , annotateExp ∷ ExpF f' → m (ExpF f') -- ^ How to annotate an expression - , annotateParam ∷ ParamF f' → m (Annotated f' ParamF) + , annotateParam ∷ ParamF f' → m (ParamF f') -- ^ How to annotate a function parameter - , annotateVar ∷ VarF f' → m (Annotated f' VarF) + , annotateVar ∷ VarF f' → m (VarF f') -- ^ How to annotate a variable - , annotateRow ∷ TableRowF f' → m (Annotated f' TableRowF) + , annotateRow ∷ TableRowF f' → m (TableRowF f') -- ^ How to annotate a table row } -unAnnotateStatement - ∷ (∀ g. Annotated f g → g f) → Annotated f StatementF → Statement -unAnnotateStatement unAnnotate = - unAnn - . runIdentity - . annotateStatementInsideOutM - Annotator - { unAnnotate - , annotateStat = pure . ann - , annotateExp = pure . ann - , annotateParam = pure . ann - , annotateVar = pure . ann - , annotateRow = pure . ann - } - -------------------------------------------------------------------------------- -- Inside-out ------------------------------------------------------------------ annotateStatementInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f StatementF → m (Annotated f' StatementF)) -annotateStatementInsideOutM annotator@Annotator {..} stat = - case unAnnotate stat of - Assign variable value → do - indexedVars ← goV variable - indexedVals ← goE value - annotateStat $ Assign indexedVars indexedVals - Local names vals → annotateStat . Local names =<< forM vals goE - IfThenElse p tb eb → do - iPred ← goE p - iThen ← traverse goS tb - iElse ← traverse goS eb - annotateStat $ IfThenElse iPred iThen iElse - Return e → annotateStat . Return =<< goE e - ForeignSourceStat src → annotateStat $ ForeignSourceStat src + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → StatementF f → m (StatementF f') +annotateStatementInsideOutM annotator@Annotator {..} = \case + Assign ann variable value → do + visitedVar ← goV variable + visitedVal ← goE value + ann' ← withAnn ann + annotateStat $ Assign ann' visitedVar visitedVal + Local ann names vals → do + ann' ← withAnn ann + annotateStat . Local ann' names =<< forM vals goE + IfThenElse ann p tb eb → do + ann' ← withAnn ann + iPred ← goE p + iThen ← traverse goS tb + iElse ← traverse goS eb + annotateStat $ IfThenElse ann' iPred iThen iElse + Return ann e → do + ann' ← withAnn ann + e' ← goE e + annotateStat $ Return ann' e' + ForeignSourceStat ann src → do + ann' ← withAnn ann + annotateStat $ ForeignSourceStat ann' src where goS = annotateStatementInsideOutM annotator goE = annotateExpInsideOutM annotator goV = annotateVarInsideOutM annotator annotateExpInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f ExpF → m (Annotated f' ExpF)) -annotateExpInsideOutM annotator@Annotator {..} expf = - case unAnnotate expf of - Var v → annotateExp . Var =<< goV v - Function params stats → do - paramNames ← forM params \case - (_, ParamNamed n) → annotateParam (ParamNamed n) - (_, ParamUnused) → annotateParam ParamUnused - aStats ← forM stats goS - annotateExp $ Function paramNames aStats - TableCtor rows → - annotateExp . TableCtor =<< forM rows \row → - case unAnnotate row of - TableRowKV k v → annotateRow =<< TableRowKV <$> goE k <*> goE v - TableRowNV n e → annotateRow . TableRowNV n =<< goE e - UnOp op e → annotateExp . UnOp op =<< goE e - BinOp op e1 e2 → annotateExp =<< BinOp op <$> goE e1 <*> goE e2 - FunctionCall fn args → - annotateExp =<< FunctionCall <$> goE fn <*> forM args goE - Nil → annotateExp Nil - Boolean b → annotateExp $ Boolean b - Integer i → annotateExp $ Integer i - Float f → annotateExp $ Float f - String s → annotateExp $ String s - ForeignSourceExp src → annotateExp $ ForeignSourceExp src + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → (ExpF f → m (ExpF f')) +annotateExpInsideOutM annotator@Annotator {..} = \case + Var ann v → do + ann' ← withAnn ann + v' ← goV v + annotateExp $ Var ann' v' + Function ann params stats → do + paramNames ← forM params \case + ParamNamed pann n → do + pann' ← withAnn pann + annotateParam (ParamNamed pann' n) + ParamUnused pann → do + pann' ← withAnn pann + annotateParam (ParamUnused pann') + ann' ← withAnn ann + stats' ← forM stats goS + annotateExp $ Function ann' paramNames stats' + TableCtor ann rows → do + ann' ← withAnn ann + rows' ← forM rows \case + TableRowKV tann k v → do + tann' ← withAnn tann + k' ← goE k + v' ← goE v + annotateRow $ TableRowKV tann' k' v' + TableRowNV tann n e → do + tann' ← withAnn tann + e' ← goE e + annotateRow $ TableRowNV tann' n e' + annotateExp $ TableCtor ann' rows' + UnOp ann op e → do + ann' ← withAnn ann + e' ← goE e + annotateExp $ UnOp ann' op e' + BinOp ann op e1 e2 → do + ann' ← withAnn ann + e1' ← goE e1 + e2' ← goE e2 + annotateExp $ BinOp ann' op e1' e2' + FunctionCall ann fn args → do + ann' ← withAnn ann + fn' ← goE fn + args' ← forM args goE + annotateExp $ FunctionCall ann' fn' args' + Nil ann → do + ann' ← withAnn ann + annotateExp (Nil ann') + Boolean ann b → do + ann' ← withAnn ann + annotateExp $ Boolean ann' b + Integer ann i → do + ann' ← withAnn ann + annotateExp $ Integer ann' i + Float ann f → do + ann' ← withAnn ann + annotateExp $ Float ann' f + String ann s → do + ann' ← withAnn ann + annotateExp $ String ann' s + ForeignSourceExp ann src → do + ann' ← withAnn ann + annotateExp $ ForeignSourceExp ann' src where goS = annotateStatementInsideOutM annotator goE = annotateExpInsideOutM annotator goV = annotateVarInsideOutM annotator annotateVarInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f VarF → m (Annotated f' VarF)) -annotateVarInsideOutM annotator@Annotator {..} = - unAnnotate >>> \case - VarName qualifiedName → annotateVar $ VarName qualifiedName - VarIndex e1 e2 → annotateVar =<< VarIndex <$> goE e1 <*> goE e2 - VarField e name → annotateVar . (`VarField` name) =<< goE e + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → (VarF f → m (VarF f')) +annotateVarInsideOutM annotator@Annotator {..} = \case + VarName ann qualifiedName → do + ann' ← withAnn ann + annotateVar $ VarName ann' qualifiedName + VarIndex ann e1 e2 → do + ann' ← withAnn ann + e1' ← goE e1 + e2' ← goE e2 + annotateVar $ VarIndex ann' e1' e2' + VarField ann e name → do + ann' ← withAnn ann + e' ← goE e + annotateVar $ VarField ann' e' name where goE = annotateExpInsideOutM annotator -------------------------------------------------------------------------------- --- Outside-in ------------------------------------------------------------------ +-- Visiting (for effect) outside-in -------------------------------------------- + +visitTermM + ∷ ∀ m ann + . Monad m + ⇒ TermF ann + -- ^ The term to visit + → (TermF ann → m [TermF ann]) + -- ^ How to get the subterms of a term + → m () +visitTermM term subterms = subterms term >>= traverse_ (`visitTermM` subterms) + +-------------------------------------------------------------------------------- +-- Rewriting ------------------------------------------------------------------- -data Visitor m a = Visitor - { aroundChunk ∷ [Annotated a StatementF] → m [Annotated a StatementF] - , beforeStat ∷ Annotated a StatementF → m (Annotated a StatementF) +data Rewrites m a = Rewrites + { beforeStat ∷ StatementF a → m (StatementF a) + , beforeExpr ∷ ExpF a → m (ExpF a) + , beforeVar ∷ VarF a → m (VarF a) + , beforeRow ∷ TableRowF a → m (TableRowF a) , afterStat ∷ StatementF a → m (StatementF a) - , beforeExp ∷ Annotated a ExpF → m (Annotated a ExpF) , afterExp ∷ ExpF a → m (ExpF a) - , beforeVar ∷ Annotated a VarF → m (Annotated a VarF) , afterVar ∷ VarF a → m (VarF a) - , beforeRow ∷ Annotated a TableRowF → m (Annotated a TableRowF) , afterRow ∷ TableRowF a → m (TableRowF a) } -makeVisitor ∷ Applicative m ⇒ Visitor m a -makeVisitor = - Visitor - { aroundChunk = pure - , beforeStat = pure +makeRewrites ∷ ∀ m a. Monad m ⇒ Rewrites m a +makeRewrites = + Rewrites + { beforeStat = pure + , beforeExpr = pure + , beforeVar = pure + , beforeRow = pure , afterStat = pure - , beforeExp = pure , afterExp = pure - , beforeVar = pure , afterVar = pure - , beforeRow = pure , afterRow = pure } -visitStatementM - ∷ Monad m - ⇒ Visitor m a - → (Annotated a StatementF → m (Annotated a StatementF)) -visitStatementM visitor@Visitor {..} stat = do - let goS = visitStatementM visitor - goE = visitExpM visitor - goV = visitVarM visitor - beforeStat stat >>= traverse \case - Assign variable value → do - indexedVars ← goV variable - indexedVals ← goE value - afterStat $ Assign indexedVars indexedVals - Local names vals → - afterStat . Local names =<< forM vals goE - IfThenElse p tb eb → do - iPred ← goE p - iThen ← traverse goS tb - iElse ← traverse goS eb - afterStat $ IfThenElse iPred iThen iElse - Return e → afterStat . Return =<< goE e - other → afterStat other +rewriteChunkM ∷ Monad m ⇒ Rewrites m a → [StatementF a] → m [StatementF a] +rewriteChunkM rewrites = traverse (rewriteStatementM rewrites) -visitExpM - ∷ ∀ m a - . Monad m - ⇒ Visitor m a - → (Annotated a ExpF → m (Annotated a ExpF)) -visitExpM visitor@Visitor {..} expf = do - let goS = visitStatementM visitor - goE = visitExpM visitor - goV = visitVarM visitor - beforeExp expf >>= traverse \case - Var v → - afterExp . Var =<< goV v - Function names stats → - afterExp . Function names =<< forM stats goS - TableCtor rows → - TableCtor <$> forM rows do - beforeRow >=> traverse \case - TableRowKV k v → afterRow =<< TableRowKV <$> goE k <*> goE v - TableRowNV n e → afterRow . TableRowNV n =<< goE e - UnOp op e → - afterExp . UnOp op =<< goE e - BinOp op e1 e2 → - afterExp =<< BinOp op <$> goE e1 <*> goE e2 - FunctionCall fn args → - afterExp =<< FunctionCall <$> goE fn <*> forM args goE - other → afterExp other +rewriteStatementM ∷ Monad m ⇒ Rewrites m a → (StatementF a → m (StatementF a)) +rewriteStatementM rewrites@Rewrites {..} = + beforeStat >=> \case + Assign ann variable value → do + rewriteedVar ← rewriteVarM rewrites variable + rewriteedVal ← rewriteExpM rewrites value + afterStat $ Assign ann rewriteedVar rewriteedVal + Local ann names vals → + afterStat . Local ann names =<< forM vals (rewriteExpM rewrites) + IfThenElse ann p tb eb → do + iPred ← rewriteExpM rewrites p + iThen ← traverse (rewriteStatementM rewrites) tb + iElse ← traverse (rewriteStatementM rewrites) eb + afterStat $ IfThenElse ann iPred iThen iElse + Return ann e → + afterStat . Return ann =<< rewriteExpM rewrites e + ForeignSourceStat ann src → + afterStat $ ForeignSourceStat ann src -visitVarM - ∷ ∀ m a - . Monad m - ⇒ Visitor m a - → (Annotated a VarF → m (Annotated a VarF)) -visitVarM visitor@Visitor {..} variable = do - let goE = visitExpM visitor - beforeVar variable >>= traverse \case - VarName qualifiedName → afterVar $ VarName qualifiedName - VarIndex e1 e2 → afterVar =<< VarIndex <$> goE e1 <*> goE e2 - VarField e name → afterVar . (`VarField` name) =<< goE e +rewriteExpM ∷ ∀ m a. Monad m ⇒ Rewrites m a → (ExpF a → m (ExpF a)) +rewriteExpM rewrites@Rewrites {..} expf = do + beforeExpr expf >>= \case + ex → case ex of + Var ann v → + afterExp . Var ann =<< rewriteVarM rewrites v + Function ann names stats → + afterExp . Function ann names =<< forM stats (rewriteStatementM rewrites) + TableCtor ann rows → + TableCtor ann <$> forM rows do + beforeRow >=> \case + TableRowKV ann' k v → + afterRow + =<< TableRowKV ann' + <$> rewriteExpM rewrites k + <*> rewriteExpM rewrites v + TableRowNV ann' n e → + afterRow . TableRowNV ann' n =<< rewriteExpM rewrites e + UnOp ann op e → + afterExp . UnOp ann op =<< rewriteExpM rewrites e + BinOp ann op e1 e2 → + afterExp + =<< BinOp ann op + <$> rewriteExpM rewrites e1 + <*> rewriteExpM rewrites e2 + FunctionCall ann fn args → + afterExp + =<< FunctionCall ann + <$> rewriteExpM rewrites fn + <*> forM args (rewriteExpM rewrites) + other → afterExp other + +rewriteVarM ∷ ∀ m a. Monad m ⇒ Rewrites m a → (VarF a → m (VarF a)) +rewriteVarM rewrites@Rewrites {..} = + beforeVar >=> \case + VarName ann qualifiedName → + afterVar $ VarName ann qualifiedName + VarIndex ann e1 e2 → + afterVar + =<< VarIndex ann + <$> rewriteExpM rewrites e1 + <*> rewriteExpM rewrites e2 + VarField ann e name → + afterVar . (\x → VarField ann x name) =<< rewriteExpM rewrites e diff --git a/lib/Language/PureScript/Backend/Lua/Types.hs b/lib/Language/PureScript/Backend/Lua/Types.hs index b3c6488..8cad9a6 100644 --- a/lib/Language/PureScript/Backend/Lua/Types.hs +++ b/lib/Language/PureScript/Backend/Lua/Types.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Backend.Lua.Types where +import Control.Lens (Lens', Plated (plate), lens) +import Control.Lens.TH (makePrisms) +import Data.DList (DList) import Language.PureScript.Backend.Lua.Name (Name) import Language.PureScript.Backend.Lua.Name qualified as Lua import Prettyprinter (Pretty) @@ -16,48 +20,48 @@ import Prelude hiding , return ) -type Chunk = [Statement] +type Chunk = DList Statement newtype ChunkName = ChunkName Text deriving stock (Show) deriving newtype (Pretty) -type Annotated (a ∷ Type) (f ∷ Type → Type) = (a, f a) +data ParamF ann + = ParamNamed ann Name + | ParamUnused ann -pattern Ann ∷ b → (a, b) -pattern Ann fa ← (_ann, fa) -{-# COMPLETE Ann #-} - -data ParamF a - = ParamNamed Name - | ParamUnused - -type Param = ParamF () +type Param = ParamF Ann deriving stock instance Eq a ⇒ Eq (ParamF a) deriving stock instance Ord a ⇒ Ord (ParamF a) deriving stock instance Show a ⇒ Show (ParamF a) +deriving stock instance Generic (ParamF a) +deriving anyclass instance NFData a => NFData (ParamF a) -data VarF a - = VarName Name - | VarIndex (Annotated a ExpF) (Annotated a ExpF) - | VarField (Annotated a ExpF) Name +data VarF ann + = VarName ann Name + | VarIndex ann (ExpF ann) (ExpF ann) + | VarField ann (ExpF ann) Name -type Var = VarF () +type Var = VarF Ann deriving stock instance Eq a ⇒ Eq (VarF a) deriving stock instance Ord a ⇒ Ord (VarF a) deriving stock instance Show a ⇒ Show (VarF a) +deriving stock instance Generic (VarF a) +deriving anyclass instance NFData a => NFData (VarF a) data TableRowF ann - = TableRowKV (Annotated ann ExpF) (Annotated ann ExpF) - | TableRowNV Name (Annotated ann ExpF) + = TableRowKV ann (ExpF ann) (ExpF ann) + | TableRowNV ann Name (ExpF ann) -type TableRow = TableRowF () +type TableRow = TableRowF Ann deriving stock instance Eq a ⇒ Eq (TableRowF a) deriving stock instance Ord a ⇒ Ord (TableRowF a) deriving stock instance Show a ⇒ Show (TableRowF a) +deriving stock instance Generic (TableRowF a) +deriving anyclass instance NFData a => NFData (TableRowF a) data Precedence = PrecFunction @@ -77,7 +81,8 @@ instance HasPrecedence Precedence where prec = id data UnaryOp = HashOp | Negate | LogicalNot | BitwiseNot - deriving stock (Show, Eq, Ord, Enum, Bounded) + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) instance HasPrecedence UnaryOp where prec = @@ -94,6 +99,88 @@ instance HasSymbol UnaryOp where LogicalNot → "not" BitwiseNot → "~" +newtype Ann = Ann () + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (NFData) + +newAnn ∷ Ann +newAnn = Ann () + +annL ∷ ∀ f a. HasAnn f ⇒ Lens' (f a) a +annL = lens annOf setAnn + +class HasAnn f where + annOf ∷ f a → a + setAnn ∷ f a → a → f a + +instance HasAnn VarF where + annOf = \case + VarName a _ → a + VarIndex a _ _ → a + VarField a _ _ → a + setAnn f a = case f of + VarName _ n → VarName a n + VarIndex _ e1 e2 → VarIndex a e1 e2 + VarField _ e n → VarField a e n + +instance HasAnn ParamF where + annOf = \case + ParamNamed a _ → a + ParamUnused a → a + setAnn f a = case f of + ParamNamed _ n → ParamNamed a n + ParamUnused _ → ParamUnused a + +instance HasAnn TableRowF where + annOf = \case + TableRowKV a _ _ → a + TableRowNV a _ _ → a + setAnn f a = case f of + TableRowKV _ k v → TableRowKV a k v + TableRowNV _ n e → TableRowNV a n e + +instance HasAnn ExpF where + annOf = \case + Nil a → a + Boolean a _ → a + Integer a _ → a + Float a _ → a + String a _ → a + Function a _ _ → a + TableCtor a _ → a + UnOp a _ _ → a + BinOp a _ _ _ → a + Var a _ → a + FunctionCall a _ _ → a + ForeignSourceExp a _ → a + setAnn expr a = case expr of + Nil _ → Nil a + Boolean _ b → Boolean a b + Integer _ i → Integer a i + Float _ f → Float a f + String _ s → String a s + Function _ p s → Function a p s + TableCtor _ r → TableCtor a r + UnOp _ o e → UnOp a o e + BinOp _ o e1 e2 → BinOp a o e1 e2 + Var _ v → Var a v + FunctionCall _ f args → FunctionCall a f args + ForeignSourceExp _ src → ForeignSourceExp a src + +instance HasAnn StatementF where + annOf = \case + Assign a _ _ → a + Local a _ _ → a + IfThenElse a _ _ _ → a + Return a _ → a + ForeignSourceStat a _ → a + setAnn f a = case f of + Assign _ v e → Assign a v e + Local _ n e → Local a n e + IfThenElse _ p t e → IfThenElse a p t e + Return _ e → Return a e + ForeignSourceStat _ src → ForeignSourceStat a src + data BinaryOp = Or | And @@ -116,7 +203,8 @@ data BinaryOp | FloorDiv | Mod | Exp - deriving stock (Show, Eq, Ord, Enum, Bounded) + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) {- 1 or 2 and @@ -182,201 +270,369 @@ instance HasSymbol BinaryOp where Exp → "^" data ExpF ann - = Nil - | Boolean Bool - | Integer Integer - | Float Double - | String Text - | Function [Annotated ann ParamF] [Annotated ann StatementF] - | TableCtor [Annotated ann TableRowF] - | UnOp UnaryOp (Annotated ann ExpF) - | BinOp BinaryOp (Annotated ann ExpF) (Annotated ann ExpF) - | Var (Annotated ann VarF) - | FunctionCall (Annotated ann ExpF) [Annotated ann ExpF] - | ForeignSourceExp Text - -type Exp = ExpF () + = Nil ann + | Boolean ann Bool + | Integer ann Integer + | Float ann Double + | String ann Text + | Function ann [ParamF ann] [StatementF ann] + | TableCtor ann [TableRowF ann] + | UnOp ann UnaryOp (ExpF ann) + | BinOp ann BinaryOp (ExpF ann) (ExpF ann) + | Var ann (VarF ann) + | FunctionCall ann (ExpF ann) [ExpF ann] + | ForeignSourceExp ann Text + +type Exp = ExpF Ann deriving stock instance Eq a ⇒ Eq (ExpF a) deriving stock instance Ord a ⇒ Ord (ExpF a) deriving stock instance Show a ⇒ Show (ExpF a) +deriving stock instance Generic (ExpF a) +deriving anyclass instance NFData a => NFData (ExpF a) data StatementF ann - = Assign (Annotated ann VarF) (Annotated ann ExpF) - | Local Name (Maybe (Annotated ann ExpF)) + = Assign ann (VarF ann) (ExpF ann) + | Local ann Name (Maybe (ExpF ann)) | IfThenElse - (Annotated ann ExpF) + ann + (ExpF ann) -- ^ predicate - [Annotated ann StatementF] + [StatementF ann] -- ^ then block - [Annotated ann StatementF] + [StatementF ann] -- ^ else block - | Return (Annotated ann ExpF) - | ForeignSourceStat Text + | Return ann (ExpF ann) + | ForeignSourceStat ann Text -type Statement = StatementF () +type Statement = StatementF Ann deriving stock instance Eq a ⇒ Eq (StatementF a) deriving stock instance Ord a ⇒ Ord (StatementF a) deriving stock instance Show a ⇒ Show (StatementF a) +deriving stock instance Generic (StatementF a) +deriving anyclass instance NFData a => NFData (StatementF a) + +-------------------------------------------------------------------------------- +-- Terms ----------------------------------------------------------------------- + +data TermF a + = E (ExpF a) + | S (StatementF a) + | V (VarF a) + | R (TableRowF a) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +$(makePrisms ''TermF) + +type Term = TermF Ann + +instance Plated (TermF a) where + plate f t = case t of + E e → + case e of + Nil {} → + pure t + Boolean {} → + pure t + Integer {} → + pure t + Float {} → + pure t + String {} → + pure t + ForeignSourceExp {} → + pure t + Var ann v → + E . Var ann <$> mapV f v + Function ann params body → + E . Function ann params <$> traverse (mapS f) body + TableCtor ann rows → + E . TableCtor ann <$> traverse (mapR f) rows + UnOp ann op e1 → + E . UnOp ann op <$> mapE f e1 + BinOp ann op e1 e2 → + E <$> liftA2 (BinOp ann op) (mapE f e1) (mapE f e2) + FunctionCall ann expr args → + E <$> liftA2 (FunctionCall ann) (mapE f expr) (traverse (mapE f) args) + S s → + case s of + Assign ann v e → + S <$> liftA2 (Assign ann) (mapV f v) (mapE f e) + Local ann name expr → + S . Local ann name <$> traverse (mapE f) expr + Return ann e → + S . Return ann <$> mapE f e + ForeignSourceStat {} → + pure t + IfThenElse ann p tb eb → + S + <$> liftA3 + (IfThenElse ann) + (mapE f p) + (traverse (mapS f) tb) + (traverse (mapS f) eb) + V v → + case v of + VarName {} → + pure t + VarIndex ann e1 e2 → + V <$> liftA2 (VarIndex ann) (mapE f e1) (mapE f e2) + VarField ann e name → + V <$> liftA2 (VarField ann) (mapE f e) (pure name) + R r → + case r of + TableRowKV ann k v → + R <$> liftA2 (TableRowKV ann) (mapE f k) (mapE f v) + TableRowNV ann name e → + R . TableRowNV ann name <$> mapE f e + +mapS ∷ Functor f ⇒ (TermF a → f (TermF a)) → StatementF a → f (StatementF a) +mapS tf s = tf (S s) <&> \case S s' → s'; _ → s + +mapE ∷ Functor f ⇒ (TermF a → f (TermF a)) → ExpF a → f (ExpF a) +mapE tf e = tf (E e) <&> \case E e' → e'; _ → e + +mapV ∷ Functor f ⇒ (TermF a → f (TermF a)) → VarF a → f (VarF a) +mapV tf v = tf (V v) <&> \case V v' → v'; _ → v + +mapR ∷ Functor f ⇒ (TermF a → f (TermF a)) → TableRowF a → f (TableRowF a) +mapR tf r = tf (R r) <&> \case R r' → r'; _ → r + +termSubterms ∷ TermF a → [TermF a] +termSubterms = \case + E e → exprSubterms e + S s → statementSubterms s + V v → varSubterms v + R r → rowSubterms r + +exprSubterms ∷ ExpF a → [TermF a] +exprSubterms = \case + Nil _ → [] + Boolean _ _ → [] + Integer _ _ → [] + Float _ _ → [] + String _ _ → [] + ForeignSourceExp _ _ → [] + Var _ v → [V v] + Function _ _params body → map S body + TableCtor _ rs → map R rs + UnOp _ _ e → [E e] + BinOp _ _ e1 e2 → [E e1, E e2] + FunctionCall _ f args → E f : map E args + +statementSubterms ∷ StatementF a → [TermF a] +statementSubterms = \case + Assign _ v e → [V v, E e] + Local _ _name es → map E (maybeToList es) + Return _ e → [E e] + ForeignSourceStat _ _ → [] + IfThenElse _ p tb eb → + E p : concatMap statementSubterms tb ++ concatMap statementSubterms eb + +varSubterms ∷ VarF a → [TermF a] +varSubterms = \case + VarName _ _ → [] + VarIndex _ e1 e2 → [E e1, E e2] + VarField _ e _ → [E e] + +rowSubterms ∷ TableRowF a → [TermF a] +rowSubterms = \case + TableRowKV _ k v → [E k, E v] + TableRowNV _ _ e → [E e] -------------------------------------------------------------------------------- -- Smarter constructors -------------------------------------------------------- -ann ∷ f () → Annotated () f -ann f = ((), f) +var ∷ Var → Exp +var = Var newAnn -unAnn ∷ Annotated a f → f a -unAnn = snd +varNameExp ∷ Name → Exp +varNameExp = var . varName -var ∷ Var → Exp -var = Var . ann +varFieldExp ∷ Exp → Name → Exp +varFieldExp n = var . varField n + +varIndexExp ∷ Exp → Exp → Exp +varIndexExp n = var . varIndex n assign ∷ Var → Exp → Statement -assign v e = Assign (ann v) (ann e) +assign = Assign newAnn -assignVar :: Name -> Exp -> Statement -assignVar name = assign (VarName name) +assignVar ∷ Name → Exp → Statement +assignVar name = assign (VarName newAnn name) local ∷ Name → Maybe Exp → Statement -local name expr = Local name (ann <$> expr) +local = Local newAnn local1 ∷ Name → Exp → Statement -local1 name expr = Local name (Just (ann expr)) +local1 name expr = Local newAnn name (Just expr) local0 ∷ Name → Statement -local0 name = Local name Nothing +local0 name = Local newAnn name Nothing -ifThenElse ∷ Exp → Chunk → Chunk → Statement -ifThenElse i t e = IfThenElse (ann i) (ann <$> t) (ann <$> e) +ifThenElse ∷ Exp → [Statement] → [Statement] → Statement +ifThenElse = IfThenElse newAnn return ∷ Exp → Statement -return = Return . ann +return = Return newAnn + +foreignStatement ∷ Text → Statement +foreignStatement = ForeignSourceStat newAnn chunkToExpression ∷ Chunk → Exp -chunkToExpression ss = functionCall (Function [] (ann <$> ss)) [] +chunkToExpression = scope . toList -- Expressions ----------------------------------------------------------------- -table ∷ [TableRow] → Exp -table = TableCtor . fmap ann +nil ∷ Exp +nil = Nil newAnn -varName ∷ Name → Exp -varName = Var . ann . VarName +boolean ∷ Bool → Exp +boolean = Boolean newAnn -varIndex ∷ Exp → Exp → Exp -varIndex e1 e2 = Var (ann (VarIndex (ann e1) (ann e2))) +integer ∷ Integer → Exp +integer = Integer newAnn -varField ∷ Exp → Name → Exp -varField e n = Var (ann (VarField (ann e) n)) +float ∷ Double → Exp +float = Float newAnn -functionDef ∷ [Param] → Chunk → Exp -functionDef params body = Function (ann <$> params) (ann <$> body) +string ∷ Text → Exp +string = String newAnn + +table ∷ [TableRow] → Exp +table = TableCtor newAnn + +functionDef ∷ [Param] → [Statement] → Exp +functionDef = Function newAnn functionCall ∷ Exp → [Exp] → Exp -functionCall f args = FunctionCall (ann f) (ann <$> args) +functionCall = FunctionCall newAnn + +foreignExpression ∷ Text → Exp +foreignExpression = ForeignSourceExp newAnn unOp ∷ UnaryOp → Exp → Exp -unOp op e = UnOp op (ann e) +unOp = UnOp newAnn binOp ∷ BinaryOp → Exp → Exp → Exp -binOp op e1 e2 = BinOp op (ann e1) (ann e2) +binOp = BinOp newAnn error ∷ Text → Exp -error msg = functionCall (varName [Lua.name|error|]) [String msg] +error msg = functionCall (var (varName [Lua.name|error|])) [String newAnn msg] pun ∷ Name → TableRow -pun n = TableRowNV n (ann (varName n)) +pun n = TableRowNV newAnn n (var (varName n)) thunk ∷ Exp → Exp -thunk e = scope [Return (ann e)] +thunk e = scope [return e] -scope ∷ Chunk → Exp -scope body = functionCall (Function [] (ann <$> body)) [] +scope ∷ [Statement] → Exp +scope body = functionCall (functionDef [] body) [] -- Unary operators ------------------------------------------------------------- hash ∷ Exp → Exp -hash = UnOp HashOp . ann +hash = UnOp newAnn HashOp negate ∷ Exp → Exp -negate = UnOp Negate . ann +negate = UnOp newAnn Negate logicalNot ∷ Exp → Exp -logicalNot = UnOp LogicalNot . ann +logicalNot = UnOp newAnn LogicalNot bitwiseNot ∷ Exp → Exp -bitwiseNot = UnOp BitwiseNot . ann +bitwiseNot = UnOp newAnn BitwiseNot -- Binary operators ------------------------------------------------------------ or ∷ Exp → Exp → Exp -or e1 e2 = BinOp Or (ann e1) (ann e2) +or = BinOp newAnn Or and ∷ Exp → Exp → Exp -and e1 e2 = BinOp And (ann e1) (ann e2) +and = BinOp newAnn And lessThan ∷ Exp → Exp → Exp -lessThan e1 e2 = BinOp LessThan (ann e1) (ann e2) +lessThan = BinOp newAnn LessThan greaterThan ∷ Exp → Exp → Exp -greaterThan e1 e2 = BinOp GreaterThan (ann e1) (ann e2) +greaterThan = BinOp newAnn GreaterThan lessThanOrEqualTo ∷ Exp → Exp → Exp -lessThanOrEqualTo e1 e2 = BinOp LessThanOrEqualTo (ann e1) (ann e2) +lessThanOrEqualTo = BinOp newAnn LessThanOrEqualTo greaterThanOrEqualTo ∷ Exp → Exp → Exp -greaterThanOrEqualTo e1 e2 = BinOp GreaterThanOrEqualTo (ann e1) (ann e2) +greaterThanOrEqualTo = BinOp newAnn GreaterThanOrEqualTo notEqualTo ∷ Exp → Exp → Exp -notEqualTo e1 e2 = BinOp NotEqualTo (ann e1) (ann e2) +notEqualTo = BinOp newAnn NotEqualTo equalTo ∷ Exp → Exp → Exp -equalTo e1 e2 = BinOp EqualTo (ann e1) (ann e2) +equalTo = BinOp newAnn EqualTo bitOr ∷ Exp → Exp → Exp -bitOr e1 e2 = BinOp BitOr (ann e1) (ann e2) +bitOr = BinOp newAnn BitOr bitXor ∷ Exp → Exp → Exp -bitXor e1 e2 = BinOp BitXor (ann e1) (ann e2) +bitXor = BinOp newAnn BitXor bitAnd ∷ Exp → Exp → Exp -bitAnd e1 e2 = BinOp BitAnd (ann e1) (ann e2) +bitAnd = BinOp newAnn BitAnd bitShiftRight ∷ Exp → Exp → Exp -bitShiftRight e1 e2 = BinOp BitShiftRight (ann e1) (ann e2) +bitShiftRight = BinOp newAnn BitShiftRight bitShiftLeft ∷ Exp → Exp → Exp -bitShiftLeft e1 e2 = BinOp BitShiftLeft (ann e1) (ann e2) +bitShiftLeft = BinOp newAnn BitShiftLeft concat ∷ Exp → Exp → Exp -concat e1 e2 = BinOp Concat (ann e1) (ann e2) +concat = BinOp newAnn Concat add ∷ Exp → Exp → Exp -add e1 e2 = BinOp Add (ann e1) (ann e2) +add = BinOp newAnn Add sub ∷ Exp → Exp → Exp -sub e1 e2 = BinOp Sub (ann e1) (ann e2) +sub = BinOp newAnn Sub mul ∷ Exp → Exp → Exp -mul e1 e2 = BinOp Mul (ann e1) (ann e2) +mul = BinOp newAnn Mul floatDiv ∷ Exp → Exp → Exp -floatDiv e1 e2 = BinOp FloatDiv (ann e1) (ann e2) +floatDiv = BinOp newAnn FloatDiv floorDiv ∷ Exp → Exp → Exp -floorDiv e1 e2 = BinOp FloorDiv (ann e1) (ann e2) +floorDiv = BinOp newAnn FloorDiv mod ∷ Exp → Exp → Exp -mod e1 e2 = BinOp Mod (ann e1) (ann e2) +mod = BinOp newAnn Mod exponent ∷ Exp → Exp → Exp -exponent e1 e2 = BinOp Exp (ann e1) (ann e2) +exponent = BinOp newAnn Exp -- Table Rows ------------------------------------------------------------------ tableRowKV ∷ Exp → Exp → TableRow -tableRowKV k v = TableRowKV (ann k) (ann v) +tableRowKV = TableRowKV newAnn tableRowNV ∷ Name → Exp → TableRow -tableRowNV n v = TableRowNV n (ann v) +tableRowNV = TableRowNV newAnn + +-- Params ---------------------------------------------------------------------- + +paramNamed ∷ Name → Param +paramNamed = ParamNamed newAnn + +paramUnused ∷ Param +paramUnused = ParamUnused newAnn + +-- Variables ------------------------------------------------------------------- + +varName ∷ Name → Var +varName = VarName newAnn + +varField ∷ Exp → Name → Var +varField = VarField newAnn + +varIndex ∷ Exp → Exp → Var +varIndex = VarIndex newAnn diff --git a/lib/Language/PureScript/Backend/Types.hs b/lib/Language/PureScript/Backend/Types.hs deleted file mode 100644 index 470896a..0000000 --- a/lib/Language/PureScript/Backend/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.PureScript.Backend.Types where - -import Language.PureScript.Names qualified as PS - -data AppOrModule - = AsApplication PS.ModuleName PS.Ident - | AsModule PS.ModuleName - deriving stock (Show) - -entryPointModule ∷ AppOrModule → PS.ModuleName -entryPointModule = \case - AsApplication modname _ident → modname - AsModule modname → modname diff --git a/lib/Language/PureScript/Comments.hs b/lib/Language/PureScript/Comments.hs deleted file mode 100644 index 3fa9509..0000000 --- a/lib/Language/PureScript/Comments.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Defines the types of source code comments -module Language.PureScript.Comments where - -import Data.Aeson.TH - ( Options (..) - , SumEncoding (..) - , defaultOptions - , deriveJSON - ) - -data Comment - = LineComment Text - | BlockComment Text - deriving stock (Show, Eq, Ord, Generic) - -$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Comment) diff --git a/lib/Language/PureScript/CoreFn.hs b/lib/Language/PureScript/CoreFn.hs deleted file mode 100644 index 8a56f16..0000000 --- a/lib/Language/PureScript/CoreFn.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Language.PureScript.CoreFn - ( module C - , Ann - ) where - -import Language.PureScript.CoreFn.Expr as C -import Language.PureScript.CoreFn.Meta as C -import Language.PureScript.CoreFn.Module as C - -type Ann = Maybe Meta diff --git a/lib/Language/PureScript/CoreFn/Expr.hs b/lib/Language/PureScript/CoreFn/Expr.hs deleted file mode 100644 index b6cd2e6..0000000 --- a/lib/Language/PureScript/CoreFn/Expr.hs +++ /dev/null @@ -1,151 +0,0 @@ -{- | -The core functional representation --} -module Language.PureScript.CoreFn.Expr where - -import Control.Arrow ((***)) -import Language.PureScript.Names -import Language.PureScript.PSString (PSString) - -{- | -Data type for expressions and terms --} -data Expr a - = -- A literal value - Literal a (Literal (Expr a)) - | -- A data constructor (type name, constructor name, field names) - Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] - | -- A record property accessor - Accessor a PSString (Expr a) - | -- Partial record update - ObjectUpdate a (Expr a) [(PSString, Expr a)] - | -- Function introduction - Abs a Ident (Expr a) - | -- Function application - App a (Expr a) (Expr a) - | -- Variable - Var a (Qualified Ident) - | -- A case expression - Case a [Expr a] [CaseAlternative a] - | -- A let binding - Let a [Bind a] (Expr a) - deriving stock (Eq, Ord, Show, Functor) - -data Binder a - = -- | - -- Wildcard binder - NullBinder a - | -- | - -- A binder which matches a literal value - LiteralBinder a (Literal (Binder a)) - | -- | - -- A binder which binds an identifier - VarBinder a Ident - | -- | - -- A binder which matches a data constructor - ConstructorBinder - a - (Qualified (ProperName 'TypeName)) - (Qualified (ProperName 'ConstructorName)) - [Binder a] - | -- | - -- A binder which binds its input to an identifier - NamedBinder a Ident (Binder a) - deriving stock (Eq, Ord, Show, Functor) - -extractBinderAnn ∷ Binder a → a -extractBinderAnn (NullBinder a) = a -extractBinderAnn (LiteralBinder a _) = a -extractBinderAnn (VarBinder a _) = a -extractBinderAnn (ConstructorBinder a _ _ _) = a -extractBinderAnn (NamedBinder a _ _) = a - -{- | -A let or module binding. --} -data Bind a - = -- | - -- Non-recursive binding for a single value - NonRec a Ident (Expr a) - | -- | - -- Mutually recursive binding group for several values - Rec [((a, Ident), Expr a)] - deriving stock (Eq, Ord, Show, Functor) - -{- | -A guard is just a literalBool-valued expression -that appears alongside a set of binders --} -type Guard a = Expr a - -{- | -An alternative in a case statement --} -data CaseAlternative a = CaseAlternative - { caseAlternativeBinders ∷ [Binder a] - -- ^ - -- A collection of binders with which to match the inputs - , caseAlternativeResult ∷ Either [(Guard a, Expr a)] (Expr a) - -- ^ - -- The result expression or a collect of guarded expressions - } - deriving stock (Eq, Ord, Show) - -instance Functor CaseAlternative where - fmap f (CaseAlternative cabs car) = - CaseAlternative - (fmap (fmap f) cabs) - (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car) - -{- | -Data type for literal values. Parameterised so it can be used for Exprs and -Binders. --} -data Literal a - = -- | - -- A numeric literal - NumericLiteral (Either Integer Double) - | -- | - -- A string literal - StringLiteral PSString - | -- | - -- A character literal - CharLiteral Char - | -- | - -- A literalBool literal - BooleanLiteral Bool - | -- | - -- An array literal - ArrayLiteral [a] - | -- | - -- An object literal - ObjectLiteral [(PSString, a)] - deriving stock (Eq, Ord, Show, Functor) - -{- | -Extract the annotation from a term --} -extractAnn ∷ Expr a → a -extractAnn (Literal a _) = a -extractAnn (Constructor a _ _ _) = a -extractAnn (Accessor a _ _) = a -extractAnn (ObjectUpdate a _ _) = a -extractAnn (Abs a _ _) = a -extractAnn (App a _ _) = a -extractAnn (Var a _) = a -extractAnn (Case a _ _) = a -extractAnn (Let a _ _) = a - -{- | -Modify the annotation on a term --} -modifyAnn ∷ (a → a) → Expr a → Expr a -modifyAnn f (Literal a b) = Literal (f a) b -modifyAnn f (Constructor a b c d) = Constructor (f a) b c d -modifyAnn f (Accessor a b c) = Accessor (f a) b c -modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c -modifyAnn f (Abs a b c) = Abs (f a) b c -modifyAnn f (App a b c) = App (f a) b c -modifyAnn f (Var a b) = Var (f a) b -modifyAnn f (Case a b c) = Case (f a) b c -modifyAnn f (Let a b c) = Let (f a) b c diff --git a/lib/Language/PureScript/CoreFn/FromJSON.hs b/lib/Language/PureScript/CoreFn/FromJSON.hs deleted file mode 100644 index 9da4d5e..0000000 --- a/lib/Language/PureScript/CoreFn/FromJSON.hs +++ /dev/null @@ -1,331 +0,0 @@ -{- | -Read the core functional representation from JSON format --} -module Language.PureScript.CoreFn.FromJSON - ( moduleFromJSON - , parseVersion' - , ModuleWithVersion (..) - , moduleWithoutVersion - ) where - -import Data.Aeson -import Data.Aeson.Types (Parser, listParser) -import Data.Map.Strict qualified as M -import Data.Text qualified as T -import Data.Vector qualified as V -import Data.Version (Version, parseVersion) -import Language.PureScript.CoreFn - ( Ann - , Bind (..) - , Binder (..) - , CaseAlternative (CaseAlternative) - , ConstructorType (..) - , Expr (..) - , Guard - , Literal (..) - , Meta (..) - , Module (..) - ) -import Language.PureScript.Names - ( Ident (Ident, UnusedIdent) - , ModuleName (..) - , ProperName (..) - , Qualified (..) - , QualifiedBy (ByModuleName, BySourcePos) - , unusedIdent - ) -import Language.PureScript.PSString (PSString) -import Text.ParserCombinators.ReadP (readP_to_S) - -data ModuleWithVersion = ModuleWithVersion Version (Module Ann) - deriving stock (Show) - -instance FromJSON ModuleWithVersion where - parseJSON = uncurry ModuleWithVersion <<$>> moduleFromJSON - -moduleWithoutVersion ∷ ModuleWithVersion → Module Ann -moduleWithoutVersion (ModuleWithVersion _version m) = m - -parseVersion' ∷ String → Maybe Version -parseVersion' str = - case filter (null . snd) $ readP_to_S parseVersion str of - [(vers, "")] → Just vers - _ → Nothing - -constructorTypeFromJSON ∷ Value → Parser ConstructorType -constructorTypeFromJSON v = do - t ← parseJSON v - case t of - "ProductType" → return ProductType - "SumType" → return SumType - _ → fail ("not recognized ConstructorType: " ++ T.unpack t) - -metaFromJSON ∷ Value → Parser (Maybe Meta) -metaFromJSON Null = return Nothing -metaFromJSON v = withObject "Meta" metaFromObj v - where - metaFromObj o = do - type_ ← o .: "metaType" - case type_ of - "IsConstructor" → isConstructorFromJSON o - "IsNewtype" → return $ Just IsNewtype - "IsTypeClassConstructor" → - return $ Just IsTypeClassConstructor - "IsForeign" → return $ Just IsForeign - "IsWhere" → return $ Just IsWhere - "IsSyntheticApp" → - return $ Just IsSyntheticApp - _ → fail ("not recognized Meta: " ++ T.unpack type_) - - isConstructorFromJSON o = do - ct ← o .: "constructorType" >>= constructorTypeFromJSON - is ← o .: "identifiers" >>= listParser identFromJSON - return $ Just (IsConstructor ct is) - -annFromJSON ∷ FilePath → Value → Parser Ann -annFromJSON _modulePath = withObject "Ann" annFromObj - where - annFromObj ∷ Object → Parser (Maybe Meta) - annFromObj o = o .: "meta" >>= metaFromJSON - -literalFromJSON ∷ (Value → Parser a) → Value → Parser (Literal a) -literalFromJSON t = withObject "Literal" literalFromObj - where - literalFromObj o = do - type_ ← o .: "literalType" ∷ Parser Text - case type_ of - "IntLiteral" → NumericLiteral . Left <$> o .: "value" - "NumberLiteral" → NumericLiteral . Right <$> o .: "value" - "StringLiteral" → StringLiteral <$> o .: "value" - "CharLiteral" → CharLiteral <$> o .: "value" - "BooleanLiteral" → BooleanLiteral <$> o .: "value" - "ArrayLiteral" → parseArrayLiteral o - "ObjectLiteral" → parseObjectLiteral o - _ → fail ("error parsing Literal: " ++ show o) - - parseArrayLiteral o = do - val ← o .: "value" - as ← mapM t (V.toList val) - return $ ArrayLiteral as - - parseObjectLiteral o = do - val ← o .: "value" - ObjectLiteral <$> recordFromJSON t val - -identFromJSON ∷ Value → Parser Ident -identFromJSON = withText "Ident" $ \case - ident - | ident == unusedIdent → pure UnusedIdent - | otherwise → pure $ Ident ident - -properNameFromJSON ∷ Value → Parser (ProperName a) -properNameFromJSON = fmap ProperName . parseJSON - -qualifiedFromJSON ∷ (Text → a) → Value → Parser (Qualified a) -qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj - where - qualifiedFromObj o = - qualifiedByModuleFromObj o <|> qualifiedBySourcePosFromObj o - qualifiedByModuleFromObj o = do - mn ← o .: "moduleName" >>= moduleNameFromJSON - i ← o .: "identifier" >>= withText "Ident" (return . f) - pure $ Qualified (ByModuleName mn) i - qualifiedBySourcePosFromObj o = do - ss ← o .: "sourcePos" - i ← o .: "identifier" >>= withText "Ident" (return . f) - pure $ Qualified (BySourcePos ss) i - -moduleNameFromJSON ∷ Value → Parser ModuleName -moduleNameFromJSON v = ModuleName . T.intercalate "." <$> listParser parseJSON v - -moduleFromJSON ∷ Value → Parser (Version, Module Ann) -moduleFromJSON = withObject "Module" moduleFromObj - where - moduleFromObj o = do - version ← o .: "builtWith" >>= versionFromJSON - moduleName ← o .: "moduleName" >>= moduleNameFromJSON - moduleComments ← o .: "comments" >>= listParser parseJSON - modulePath ← o .: "modulePath" - moduleImports ← o .: "imports" >>= listParser (importFromJSON modulePath) - moduleExports ← o .: "exports" >>= listParser identFromJSON - moduleReExports ← o .: "reExports" >>= reExportsFromJSON - moduleBindings ← o .: "decls" >>= listParser (bindFromJSON modulePath) - moduleForeign ← o .: "foreign" >>= listParser identFromJSON - pure (version, Module {..}) - - versionFromJSON ∷ String → Parser Version - versionFromJSON v = - case parseVersion' v of - Just r → return r - Nothing → fail "failed parsing purs version" - - importFromJSON ∷ FilePath → Value → Parser (Ann, ModuleName) - importFromJSON modulePath = - withObject - "Import" - ( \o → do - ann ← o .: "annotation" >>= annFromJSON modulePath - mn ← o .: "moduleName" >>= moduleNameFromJSON - return (ann, mn) - ) - - reExportsFromJSON ∷ Value → Parser (M.Map ModuleName [Ident]) - reExportsFromJSON = fmap (M.map (map Ident)) . parseJSON - -bindFromJSON ∷ FilePath → Value → Parser (Bind Ann) -bindFromJSON modulePath = withObject "Bind" bindFromObj - where - bindFromObj ∷ Object → Parser (Bind Ann) - bindFromObj o = do - type_ ← o .: "bindType" ∷ Parser Text - case type_ of - "NonRec" → (uncurry . uncurry) NonRec <$> bindFromObj' o - "Rec" → Rec <$> (o .: "binds" >>= listParser (withObject "Bind" bindFromObj')) - _ → fail ("not recognized bind type \"" ++ T.unpack type_ ++ "\"") - - bindFromObj' ∷ Object → Parser ((Ann, Ident), Expr Ann) - bindFromObj' o = do - a ← o .: "annotation" >>= annFromJSON modulePath - i ← o .: "identifier" >>= identFromJSON - e ← o .: "expression" >>= exprFromJSON modulePath - return ((a, i), e) - -recordFromJSON ∷ (Value → Parser a) → Value → Parser [(PSString, a)] -recordFromJSON p = listParser parsePair - where - parsePair v = do - (l, v') ← parseJSON v ∷ Parser (PSString, Value) - a ← p v' - return (l, a) - -exprFromJSON ∷ FilePath → Value → Parser (Expr Ann) -exprFromJSON modulePath = withObject "Expr" exprFromObj - where - exprFromObj o = do - type_ ← o .: "type" - case type_ of - "Var" → varFromObj o - "Literal" → literalExprFromObj o - "Constructor" → constructorFromObj o - "Accessor" → accessorFromObj o - "ObjectUpdate" → objectUpdateFromObj o - "Abs" → absFromObj o - "App" → appFromObj o - "Case" → caseFromObj o - "Let" → letFromObj o - _ → fail ("not recognized expression type: \"" ++ T.unpack type_ ++ "\"") - - varFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - qi ← o .: "value" >>= qualifiedFromJSON Ident - return $ Var ann qi - - literalExprFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - lit ← o .: "value" >>= literalFromJSON (exprFromJSON modulePath) - return $ Literal ann lit - - constructorFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - tyn ← o .: "typeName" >>= properNameFromJSON - con ← o .: "constructorName" >>= properNameFromJSON - is ← o .: "fieldNames" >>= listParser identFromJSON - return $ Constructor ann tyn con is - - accessorFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - f ← o .: "fieldName" - e ← o .: "expression" >>= exprFromJSON modulePath - return $ Accessor ann f e - - objectUpdateFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - e ← o .: "expression" >>= exprFromJSON modulePath - us ← o .: "updates" >>= recordFromJSON (exprFromJSON modulePath) - return $ ObjectUpdate ann e us - - absFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - idn ← o .: "argument" >>= identFromJSON - e ← o .: "body" >>= exprFromJSON modulePath - return $ Abs ann idn e - - appFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - e ← o .: "abstraction" >>= exprFromJSON modulePath - e' ← o .: "argument" >>= exprFromJSON modulePath - return $ App ann e e' - - caseFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - cs ← o .: "caseExpressions" >>= listParser (exprFromJSON modulePath) - cas ← - o .: "caseAlternatives" >>= listParser (caseAlternativeFromJSON modulePath) - return $ Case ann cs cas - - letFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - bs ← o .: "binds" >>= listParser (bindFromJSON modulePath) - e ← o .: "expression" >>= exprFromJSON modulePath - return $ Let ann bs e - -caseAlternativeFromJSON ∷ FilePath → Value → Parser (CaseAlternative Ann) -caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativeFromObj - where - caseAlternativeFromObj o = do - bs ← o .: "binders" >>= listParser (binderFromJSON modulePath) - isGuarded ← o .: "isGuarded" - if isGuarded - then do - es ← o .: "expressions" >>= listParser parseResultWithGuard - return $ CaseAlternative bs (Left es) - else do - e ← o .: "expression" >>= exprFromJSON modulePath - return $ CaseAlternative bs (Right e) - - parseResultWithGuard ∷ Value → Parser (Guard Ann, Expr Ann) - parseResultWithGuard = withObject "parseCaseWithGuards" $ - \o → do - g ← o .: "guard" >>= exprFromJSON modulePath - e ← o .: "expression" >>= exprFromJSON modulePath - return (g, e) - -binderFromJSON ∷ FilePath → Value → Parser (Binder Ann) -binderFromJSON modulePath = withObject "Binder" binderFromObj - where - binderFromObj o = do - type_ ← o .: "binderType" - case type_ of - "NullBinder" → nullBinderFromObj o - "VarBinder" → varBinderFromObj o - "LiteralBinder" → literalBinderFromObj o - "ConstructorBinder" → constructorBinderFromObj o - "NamedBinder" → namedBinderFromObj o - _ → fail ("not recognized binder: \"" ++ T.unpack type_ ++ "\"") - - nullBinderFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - return $ NullBinder ann - - varBinderFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - idn ← o .: "identifier" >>= identFromJSON - return $ VarBinder ann idn - - literalBinderFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - lit ← o .: "literal" >>= literalFromJSON (binderFromJSON modulePath) - return $ LiteralBinder ann lit - - constructorBinderFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - tyn ← o .: "typeName" >>= qualifiedFromJSON ProperName - con ← o .: "constructorName" >>= qualifiedFromJSON ProperName - bs ← o .: "binders" >>= listParser (binderFromJSON modulePath) - return $ ConstructorBinder ann tyn con bs - - namedBinderFromObj o = do - ann ← o .: "annotation" >>= annFromJSON modulePath - n ← o .: "identifier" >>= identFromJSON - b ← o .: "binder" >>= binderFromJSON modulePath - return $ NamedBinder ann n b diff --git a/lib/Language/PureScript/CoreFn/Laziness.hs b/lib/Language/PureScript/CoreFn/Laziness.hs deleted file mode 100644 index cbb08b4..0000000 --- a/lib/Language/PureScript/CoreFn/Laziness.hs +++ /dev/null @@ -1,686 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-local-signatures #-} - -module Language.PureScript.CoreFn.Laziness - ( applyLazinessTransform - ) where - -import Data.Array qualified as A -import Data.Graph (SCC (..), stronglyConnComp) -import Data.IntMap.Monoidal qualified as IM -import Data.IntSet qualified as IS -import Data.List (foldl, (!!)) -import Data.Map.Monoidal qualified as M -import Data.Semigroup (Max (..)) -import Data.Set qualified as S -import Language.PureScript.CoreFn - ( Ann - , Bind - , Expr (Abs, App, Case, Let, Literal, Var) - , Literal (NumericLiteral, StringLiteral) - , Meta (IsConstructor, IsNewtype) - ) -import Language.PureScript.CoreFn.Traversals (traverseCoreFn) -import Language.PureScript.Names - ( Ident (Ident, InternalIdent, UnusedIdent) - , InternalIdentData (Lazy, RuntimeLazyFactory) - , ModuleName (..) - , Qualified (..) - , runIdent - , toMaybeModuleName - , pattern ByNullSourcePos - ) -import Language.PureScript.PSString (mkString) -import Prelude hiding (force) -import qualified Data.List.NonEmpty as NE - --- This module is responsible for ensuring that the bindings in recursive --- binding groups are initialized in a valid order, introducing run-time --- laziness and initialization checks as necessary. --- --- PureScript is a call-by-value language with strict data constructors, this --- transformation notwithstanding. The only laziness introduced here is in the --- initialization of a binding. PureScript is uninterested in the order in --- which bindings are written by the user. The compiler has always attempted to --- emit the bindings in an order that makes sense for the backend, but without --- this transformation, recursive bindings are emitted in an arbitrary order, --- which can cause unexpected behavior at run time if a binding is dereferenced --- before it has initialized. --- --- To prevent unexpected errors, this transformation does a syntax-driven --- analysis of a single recursive binding group to attempt to statically order --- the bindings, and when that fails, falls back to lazy initializers that will --- succeed or fail deterministically with a clear error at run time. --- --- Example: --- --- x = f \_ -> --- x --- --- becomes (with some details of the $runtime_lazy function elided): --- --- -- the binding of x has been rewritten as a lazy initializer --- $lazy_x = $runtime_lazy \_ -> --- f \_ -> --- $lazy_x 2 -- the reference to x has been rewritten as a force call --- x = $lazy_x 1 --- --- Central to this analysis are the concepts of delay and force, which are --- attributes given to every subexpression in the binding group. Delay and --- force are defined by the following traversal. This traversal is used twice: --- once to collect all the references made by each binding in the group, and --- then again to rewrite some references to force calls. (The implications of --- delay and force on initialization order are specified later.) - -{- | -Visits every `Var` in an expression with the provided function, including -the amount of delay and force applied to that `Var`, and substitutes the -result back into the tree (propagating an `Applicative` effect). - -Delay is a non-negative integer that represents the number of lambdas that -enclose an expression. Force is a non-negative integer that represents the -number of values that are being applied to an expression. Delay is always -statically determinable, but force can be *unknown*, so it's represented -here with a Maybe. In a function application `f a b`, `f` has force 2, but -`a` and `b` have unknown force--it depends on what `f` does with them. - -The rules of assigning delay and force are simple: - * The expressions that are assigned to bindings in this group have - delay 0, force 0. - * In a function application, the function expression has force 1 higher - than the force of the application expression, and the argument - expression has unknown force. - * UNLESS this argument is being directly provided to a constructor (in - other words, the function expression is either a constructor itself or - a constructor that has already been partially applied), in which case - the force of both subexpressions is unchanged. We can assume that - constructors don't apply any additional force to their arguments. - * If the force of a lambda is zero, the delay of the body of the lambda is - incremented; otherwise, the force of the body of the lambda is - decremented. (Applying one argument to a lambda cancels out one unit of - delay.) - * In the argument of a Case and the bindings of a Let, force is unknown. - * Everywhere else, preserve the delay and force of the enclosing - expression. - -Here are some illustrative examples of the above rules. We will use a -pseudocode syntax to annotate a subexpression with delay and force: -`expr#d!f` means `expr` has delay d and force f. `!*` is used to denote -unknown force. - - x = y#0!0 - x = y#0!2 a#0!* b#0!* - x = (\_ -> y#1!0)#0!0 - x = \_ _ -> y#2!1 a#2!* - x = (\_ -> y#0!0)#0!1 z#0!* - x = Just { a: a#0!0, b: b#0!0 } - x = let foo = (y#1!* a b#1!*)#1!* in foo + 1 - -(Note that this analysis is quite ignorant of any actual control flow -choices made at run time. It doesn't even track what happens to a reference -after it has been locally bound by a Let or Case. Instead, it just assumes -the worst--once locally bound to a new name, it imagines that absolutely -anything could happen to that new name and thus to the underlying reference. -But the value-to-weight ratio of this approach is perhaps surprisingly -high.) - -Every subexpression gets a delay and a force, but we are only interested -in references to other bindings in the binding group, so the traversal only -exposes `Var`s to the provided function. --} -onVarsWithDelayAndForce - ∷ ∀ f - . Applicative f - ⇒ ( Int - → Maybe Int - → Ann - → Qualified Ident - → f (Expr Ann) - ) - → Expr Ann - → f (Expr Ann) -onVarsWithDelayAndForce f = snd . go 0 $ Just 0 - where - go ∷ Int → Maybe Int → (Bind Ann → f (Bind Ann), Expr Ann → f (Expr Ann)) - go delay force = (handleBind, handleExpr') - where - (handleBind, handleExpr, handleBinder, handleCaseAlternative) = - traverseCoreFn handleBind handleExpr' handleBinder handleCaseAlternative - handleExpr' = \case - Var a i → f delay force a i - Abs a i e → - Abs a i - <$> snd - ( if force == Just 0 - then go (succ delay) force - else go delay $ fmap pred force - ) - e - App a e1 e2 → - -- `handleApp` is just to handle the constructor application exception - -- somewhat gracefully (i.e., without requiring a deep inspection of - -- the function expression at every step). If we didn't care about - -- constructors, this could have been simply: - -- App a <$> snd (go delay (fmap succ force)) e1 - -- <*> snd (go delay Nothing) e2 - handleApp 1 [(a, e2)] e1 - Case a vs alts → - Case a - <$> traverse (snd $ go delay Nothing) vs - <*> traverse handleCaseAlternative alts - Let a ds e → - Let a <$> traverse (fst $ go delay Nothing) ds <*> handleExpr' e - other → handleExpr other - - handleApp len args = \case - App a e1 e2 → handleApp (len + 1) ((a, e2) : args) e1 - Var a@(Just meta) i - | isConstructorLike meta → - foldl - (\e1 (a2, e2) → App a2 <$> e1 <*> handleExpr' e2) - (f delay force a i) - args - e → - foldl - (\e1 (a2, e2) → App a2 <$> e1 <*> snd (go delay Nothing) e2) - (snd (go delay (fmap (+ len) force)) e) - args - isConstructorLike = \case - IsConstructor {} → True - IsNewtype → True - _ → False - --- Once we assign a delay and force value to every `Var` in the binding group, --- we can consider how to order the bindings to allow them all to successfully --- initialize. There is one principle here: each binding must be initialized --- before the identifier being bound is ready for use. If the preorder thus --- induced has cycles, those cycles need to be resolved with laziness. All of --- the details concern what "ready for use" means. --- --- The definition of delay and force suggests that "ready for use" depends on --- those attributes. If a lambda is bound to the name x, then the references in --- the lambda don't need to be initialized before x is initialized. This is --- represented by the fact that those references have non-zero delay. But if --- the expression bound to x is instead the application of a function y that is --- also bound in this binding group, then not only does y need to be --- initialized before x, so do some of the non-zero delay references in y. This --- is represented by the fact that the occurrence of y in the expression bound --- to x has non-zero force. --- --- An example, reusing the pseudocode annotations defined above: --- --- x _ = y#1!0 --- y = x#0!1 a --- --- y doesn't need to be initialized before x is, because the reference to y in --- x's initializer has delay 1. But y does need to be initialized before x is --- ready for use with force 1, because force 1 is enough to overcome the delay --- of that reference. And since y has a delay-0 reference to x with force 1, y --- will need to be ready for use before it is initialized; thus, y needs to be --- made lazy. --- --- So just as function applications "cancel out" lambdas, a known applied force --- cancels out an equal amount of delay, causing some references that may not --- have been needed earlier to enter play. (And to be safe, we must assume that --- unknown force cancels out *any* amount of delay.) There is another, subtler --- aspect of this: if there are not enough lambdas to absorb every argument --- applied to a function, those arguments will end up applied to the result of --- the function. Likewise, if there is excess force left over after some of it --- has been canceled by delay, that excess is carried to the references --- activated. (Again, an unknown amount of force must be assumed to lead to an --- unknown amount of excess force.) --- --- Another example: --- --- f = g#0!2 a b --- g x = h#1!2 c x --- h _ _ _ = f#3!0 --- --- Initializing f will lead to an infinite loop in this example. f invokes g --- with two arguments. g absorbs one argument, and the second ends up being --- applied to the result of h c x, resulting in h being invoked with three --- arguments. Invoking h with three arguments results in dereferencing f, which --- is not yet ready. To capture this loop in our analysis, we say that making --- f ready for use with force 0 requires making g ready for use with force 2, --- which requires making h ready for use with force 3 (two units of force from --- the lexical position of h, plus one unit of excess force carried forward), --- which cyclically requires f to be ready for use with force 0. --- --- These preceding observations are captured and generalized by the following --- rules: --- --- USE-INIT: Before a reference to x is ready for use with any force, x must --- be initialized. --- --- We will make x lazy iff this rule induces a cycle--i.e., initializing x --- requires x to be ready for use first. --- --- USE-USE: Before a reference to x is ready for use with force f: --- * if a reference in the initializer of x has delay d and force f', --- * and either d <= f or f is unknown, --- * then that reference must itself be ready for use with --- force f – d + f' (or with unknown force if f or f' is unknown). --- --- USE-IMMEDIATE: Initializing a binding x is equivalent to requiring a --- reference to x to be ready for use with force 0, per USE-USE. --- --- Equivalently: before x is initialized, any reference in the initializer --- of x with delay 0 and force f must be ready for use with force f. --- --- Examples: --- --- Assume x is bound in a recursive binding group with the below bindings. --- --- All of the following initializers require x to be ready for use with some --- amount of force, and therefore require x to be initialized first. --- --- a = x#0!0 --- b = (\_ -> x#0!0) 1 --- c = foo x#0!* --- d = (\_ -> foo x#0!*) 1 --- --- In the following initializers, before p can be initialized, x must be --- ready for use with force f – d + f'. (And both x and q must be --- initialized, of course; but x being ready for use with that force may --- induce additional constraints.) --- --- p = ... q#0!f ... --- q = ... x#d!f' ... (where d <= f) --- --- Excess force stacks, of course: in the following initializers, before r --- can be initialized, x must be ready for use with force --- f — d + f' — d' + f'': --- --- r = ... s#0!f ... --- s = ... t#d!f' ... (where d <= f) --- t = ... x#d'!f'' ... (where d' <= f – d + f') --- --- --- To satisfy these rules, we will construct a graph between (identifier, --- delay) pairs, with edges induced by the USE-USE rule, and effectively run a --- topsort to get the initialization preorder. For this part, it's simplest to --- think of delay as an element of the naturals extended with a positive --- infinity, corresponding to an unknown amount of force. (We'll do arithmetic --- on these extended naturals as you would naively expect; we won't do anything --- suspect like subtracting infinity from infinity.) With that in mind, we can --- construct the graph as follows: for each reference from i1 to i2 with delay --- d and force f, draw an infinite family of edges from (i1, d + n) to (i2, f + --- n) for all 0 <= n <= ∞, where n represents the excess force carried over --- from a previous edge. Unfortunately, as an infinite graph, we can't expect --- the tools in Data.Graph to help us traverse it; we will have to be a little --- bit clever. --- --- The following data types and functions are for searching this infinite graph --- and carving from it a finite amount of data to work with. Specifically, we --- want to know for each identifier i, which other identifiers are --- irreflexively reachable from (i, 0) (and thus must be initialized before i --- is), and with what maximum force (in the event of a loop, not every --- reference to i in the reachable identifier needs to be rewritten to a force --- call; only the ones with delay up to the maximum force used during i's --- initialization). We also want the option of aborting a given reachability --- search, for one of two reasons. --- --- * If we encounter a reference with unknown force, abort. --- * If we encounter a cycle where force on a single identifier is --- increasing, abort. (Because of USE-USE, as soon as an identifier is --- revisited with greater force than its first visit, the difference is --- carried forward as excess, so it is possible to retrace that path to get --- an arbitrarily high amount of force.) --- --- Both reasons mean that it is theoretically possible for the identifier in --- question to need every other identifier in the binding group to be --- initialized before it is. (Every identifier in a recursive binding group is --- necessarily reachable from every other, ignoring delay and force, which is --- what arbitrarily high force lets you do.) --- --- In order to reuse parts of this reachability computation across identifiers, --- we are going to represent it with a rose tree data structure interleaved with --- a monad capturing the abort semantics. (The monad is Maybe, but we don't --- need to know that here!) - -type MaxRoseTree m a = m (IM.MonoidalIntMap (MaxRoseNode m a)) - -data MaxRoseNode m a = MaxRoseNode a (MaxRoseTree m a) --- Dissecting this data structure: --- --- m (...) - -{- ^ represents whether to abort or continue the search - - IM.MonoidalIntMap (...) - ^ the keys of this map are other identifiers reachable from the current - one (we'll map the identifiers in this binding group to Ints for ease of - computation) - - the values of this map are: - - MaxRoseNode a (...) - ^ this will store the force applied to the next identifier - (MaxRoseTree m a) - ^ and this, the tree of identifiers reachable from there - -We're only interested in continuing down the search path that applies the -most force to a given identifier! So when we combine two MaxRoseTrees, -we want to resolve any key collisions in their MonoidalIntMaps with this -semigroup: --} - -instance Ord a ⇒ Semigroup (MaxRoseNode m a) where - l@(MaxRoseNode l1 _) <> r@(MaxRoseNode r1 _) = if r1 > l1 then r else l - --- And that's why this is called a MaxRoseTree. --- --- Traversing this tree to get a single MonoidalIntMap with the entire closure --- plus force information is fairly straightforward: -mrtFlatten - ∷ (Monad m, Ord a) - ⇒ MaxRoseTree m a - → m (IM.MonoidalIntMap (Max a)) -mrtFlatten = - ( getAp - . IM.foldMapWithKey - ( \i (MaxRoseNode a inner) → - Ap $ (IM.singleton i (Max a) <>) <$> mrtFlatten inner - ) - =<< - ) - --- The use of the `Ap` monoid ensures that if any child of this tree aborts, --- the entire tree aborts. --- --- One might ask, why interleave the abort monad with the tree at all if we're --- just going to flatten it out at the end? The point is to flatten it out at --- the end, but *not* during the generation of the tree. Attempting to flatten --- the tree as we generate it can result in an infinite loop, because a subtree --- needs to be exhaustively searched for abort conditions before it can be used --- in another tree. With this approach, we can use lazy trees as building --- blocks and, as long as they get rewritten to be finite or have aborts before --- they're flattened, the analysis still terminates. - -{- | -Given a maximum index and a function that returns a map of edges to next -indices, returns an array for each index up to maxIndex of maps from the -indices reachable from the current index, to the maximum force applied to -those indices. --} -searchReachable - ∷ ∀ m force - . (Alternative m, Monad m, Enum force, Ord force) - ⇒ Int - → ((Int, force) → m (IM.MonoidalIntMap (Max force))) - → A.Array Int (m (IM.MonoidalIntMap (Max force))) -searchReachable maxIdx lookupEdges = mrtFlatten . head <$> mem - where - -- This is a finite array of infinite lists, used to memoize all the search - -- trees. `unsafeHead` is used above to pull the first tree out of each list - -- in the array--the one corresponding to zero force, which is what's needed - -- to initialize the corresponding identifier. (`unsafeHead` is safe here, of - -- course: infinite lists.) - mem ∷ A.Array Int (NonEmpty (MaxRoseTree m force)) - mem = - A.listArray - (0, maxIdx) - [ NE.fromList - [ cutLoops <*> fmap (IM.mapWithKey memoizedNode) . lookupEdges $ (i, f) - | f ← [toEnum 0 ..] - ] - | i ← [0 .. maxIdx] - ] - - memoizedNode ∷ Int → Max force → MaxRoseNode m force - memoizedNode i (Max force) = - MaxRoseNode force $ toList (mem A.! i) !! fromEnum force - - -- And this is the function that prevents the search from actually being - -- infinite. It applies a filter to a `MaxRoseTree` at every level, looking for - -- indices anywhere in the tree that match the current vertex. If a match is - -- found with greater force than the current force, that part of the tree is - -- rewritten to abort; otherwise, that part of the tree is rewritten to be - -- empty (there's nothing new in that part of the search). - -- - -- A new version of `cutLoops` is applied for each node in the search, so - -- each edge in a search path will add another filter on a new index. Since - -- there are a finite number of indices in our universe, this guarantees that - -- the analysis terminates, because no single search path can have length - -- greater than `maxIdx`. - cutLoops ∷ (Int, force) → MaxRoseTree m force → MaxRoseTree m force - cutLoops (i, force) = go - where - go = (=<<) . IM.traverseWithKey $ \i' (MaxRoseNode force' inner) → - MaxRoseNode force' - <$> if i == i' - then - guard (force >= force') - $> pure IM.empty - else pure $ go inner - --- One last data structure to define and then it's on to the main event. --- --- The laziness transform effectively takes a list of eager bindings (x = ...) --- and splits some of them into lazy definitions ($lazy_x = ...) and lazy --- bindings (x = $lazy_x ...). It's convenient to work with these three --- declarations as the following sum type: - -data RecursiveGroupItem e - = EagerBinding Ann e - | LazyDefinition e - | LazyBinding Ann - deriving stock (Functor) - -{- | -Transform a recursive binding group, reordering the bindings within when a -correct initialization order can be statically determined, and rewriting -bindings and references to be lazy otherwise. --} -applyLazinessTransform - ∷ ModuleName - → [((Ann, Ident), Expr Ann)] - → ([((Ann, Ident), Expr Ann)], Any) -applyLazinessTransform mn rawItems = - let - -- Establish the mapping from names to ints. - rawItemsByName ∷ M.MonoidalMap Ident (Ann, Expr Ann) - rawItemsByName = M.fromList $ (snd . fst &&& first fst) <$> rawItems - - maxIdx = M.size rawItemsByName - 1 - - rawItemsByIndex ∷ A.Array Int (Ann, Expr Ann) - rawItemsByIndex = A.listArray (0, maxIdx) $ M.elems rawItemsByName - - names ∷ S.Set Ident - names = M.keysSet rawItemsByName - - -- Now do the first delay/force traversal of all the bindings to find - -- references to other names in this binding group. - -- - -- The parts of this type mean: - -- D is the maximum force (or Nothing if unknown) with which the identifier C - -- is referenced in any delay-B position inside the expression A. - -- - -- where A, B, C, and D are as below: - -- A B (keys) C (keys) D - findReferences - ∷ Expr Ann - → IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) - findReferences = (getConst .) . onVarsWithDelayAndForce $ - \delay force _ → \case - Qualified qb ident - | all (== mn) (toMaybeModuleName qb) - , Just i ← ident `S.lookupIndex` names → - Const . IM.singleton delay . IM.singleton i $ coerceForce force - _ → Const IM.empty - - -- The parts of this type mean: - -- D is the maximum force (or Nothing if unknown) with which the identifier C - -- is referenced in any delay-B position inside the binding of identifier A. - -- - -- where A, B, C, and D are as below: - -- A B (keys) C (keys) D - refsByIndex - ∷ A.Array - Int - (IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int)))) - refsByIndex = findReferences . snd <$> rawItemsByIndex - - -- Using the approach explained above, traverse the reference graph generated - -- by `refsByIndex` and find all reachable names. - -- - -- The parts of this type mean: - -- D is the maximum force with which the identifier C is referenced, - -- directly or indirectly, during the initialization of identifier A. B is - -- Nothing if the analysis of A was inconclusive and A might need the entire - -- binding group. - -- - -- where A, B, C, and D are as below: - -- A B C (keys) D - reachablesByIndex ∷ A.Array Int (Maybe (IM.MonoidalIntMap (Max Int))) - reachablesByIndex = searchReachable maxIdx $ \(i, force) → - getAp . flip IM.foldMapWithKey (dropKeysAbove force $ refsByIndex A.! i) $ \delay → - IM.foldMapWithKey $ \i' force' → - Ap $ IM.singleton i' . Max . (force - delay +) <$> uncoerceForce force' - - -- If `reachablesByIndex` is a sort of labeled relation, this function - -- produces part of the reverse relation, but only for the edges from the - -- given vertex. - -- - -- The parts of this type mean: - -- The identifier A is reachable from the identifier B with maximum force C - -- (B is also the index provided to the function). - -- - -- where A, B, and C are as below: - -- (B) A B (singleton key) C - reverseReachablesFor - ∷ Int - → IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) - reverseReachablesFor i = case reachablesByIndex A.! i of - Nothing → - IM.fromAscList $ (,IM.singleton i $ Ap Nothing) <$> [0 .. maxIdx] - Just im → IM.singleton i . Ap . Just <$> im - - -- We can use `reachablesByIndex` to build a finite graph and topsort it; - -- in the process, we'll pack the nodes of the graph with data we'll want - -- next. Remember that if our reachability computation aborted, we have to - -- assume that every other identifier is reachable from that one--hence the - -- `maybe [0..maxIdx]`. - sccs = stronglyConnComp $ do - (i, mbReachable) ← A.assocs reachablesByIndex - pure - ( (reverseReachablesFor i, (S.elemAt i names, rawItemsByIndex A.! i)) - , i - , maybe [0 .. maxIdx] (IS.toList . IM.keysSet) mbReachable - ) - - (replacements, items) = flip foldMap sccs $ \case - -- The easy case: this binding doesn't need to be made lazy after all! - AcyclicSCC (_, (ident, (a, e))) → pure [(ident, EagerBinding a e)] - -- The tough case: we have a loop. - -- We need to do two things here: - -- * Collect the reversed reachables relation for each vertex in this - -- loop; we'll use this to replace references with force calls - -- * Copy the vertex list into two lists: a list of lazy definitions and - -- a list of lazy bindings - -- Both of these results are monoidal, so the outer `foldMap` will - -- concatenate them pairwise. - CyclicSCC vertices → - ( foldMap fst vertices - , map (fmap (LazyDefinition . snd) . snd) vertices - <> map (fmap (LazyBinding . fst) . snd) vertices - ) - - -- We have `replacements` expressed in terms of indices; we want to map it - -- back to names before traversing the bindings again. - replacementsByName - ∷ M.MonoidalMap - Ident - (M.MonoidalMap Ident (Ap Maybe (Max Int))) - replacementsByName = - M.fromAscList - . map - ( bimap - (`S.elemAt` names) - (M.fromAscList . map (first (`S.elemAt` names)) . IM.toAscList) - ) - . IM.toAscList - $ replacements - - -- And finally, this is the second delay/force traversal where we take - -- `replacementsByName` and use it to rewrite references with force calls, - -- but only if the delay of those references is at most the maximum amount - -- of force used by the initialization of the referenced binding to - -- reference the outer binding. A reference made with a higher delay than - -- that can safely continue to use the original reference, since it won't be - -- needed until after the referenced binding is done initializing. - replaceReferencesWithForceCall - ∷ (Ident, RecursiveGroupItem (Expr Ann)) - → (Ident, RecursiveGroupItem (Expr Ann)) - replaceReferencesWithForceCall pair@(ident, item) = - case ident `M.lookup` replacementsByName of - Nothing → pair - Just m → - let - rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ - \delay _ ann → - pure . \case - Qualified qb ident' - | all (== mn) (toMaybeModuleName qb) - , any (all (>= Max delay) . getAp) $ ident' `M.lookup` m → - makeForceCall ann ident' - q → Var ann q - in - (ident, rewriteExpr <$> item) - in - -- All that's left to do is run the above replacement on every item, - -- translate items from our `RecursiveGroupItem` representation back into the - -- form CoreFn expects, and inform the caller whether we made any laziness - -- transformations after all. (That last bit of information is used to - -- determine if the runtime factory function needs to be injected.) - ( uncurry fromRGI . replaceReferencesWithForceCall <$> items - , Any . not $ IM.null replacements - ) - where - nullAnn = Nothing - lazifyIdent = \case - Ident txt → InternalIdent $ Lazy txt - _ → internalError "Unexpected argument to lazifyIdent" - - makeForceCall ∷ Ann → Ident → Expr Ann - makeForceCall _ ident = - -- We expect the functions produced by `runtimeLazy` to accept one - -- argument: the line number on which this reference is made. The runtime - -- code uses this number to generate a message that identifies where the - -- evaluation looped. - App nullAnn (Var nullAnn . Qualified ByNullSourcePos $ lazifyIdent ident) - . Literal nullAnn - . NumericLiteral - $ Left 0 - - fromRGI ∷ Ident → RecursiveGroupItem (Expr Ann) → ((Ann, Ident), Expr Ann) - fromRGI i = \case - EagerBinding a e → ((a, i), e) - LazyBinding a → ((a, i), makeForceCall a i) - -- We expect the `runtimeLazy` factory to accept three arguments: the - -- identifier being initialized, the name of the module, and of course a - -- thunk that actually contains the initialization code. - LazyDefinition e → - ( (nullAnn, lazifyIdent i) - , app (app runtimeLazy (strLit (runIdent i))) (thunk e) - ) - where - app = App nullAnn - thunk = Abs nullAnn UnusedIdent - strLit = Literal nullAnn . StringLiteral . mkString - runtimeLazy = - Var nullAnn . Qualified ByNullSourcePos $ - InternalIdent RuntimeLazyFactory - - dropKeysAbove ∷ Int → IM.MonoidalIntMap a → IM.MonoidalIntMap a - dropKeysAbove n = fst . IM.split (n + 1) - - coerceForce ∷ Maybe Int → Ap Maybe (Max Int) - coerceForce = coerce - - uncoerceForce ∷ Ap Maybe (Max Int) → Maybe Int - uncoerceForce = coerce - --- | Exit with an error message and a crash report link. -internalError ∷ HasCallStack ⇒ Text → a -internalError = error . ("An internal error occurred during compilation: " <>) diff --git a/lib/Language/PureScript/CoreFn/Meta.hs b/lib/Language/PureScript/CoreFn/Meta.hs deleted file mode 100644 index c21e794..0000000 --- a/lib/Language/PureScript/CoreFn/Meta.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | Metadata annotations for core functional representation -module Language.PureScript.CoreFn.Meta where - -import Language.PureScript.Names (Ident) - --- | Metadata annotations -data Meta - = -- | The contained value is a data constructor - IsConstructor ConstructorType [Ident] - | -- | The contained value is a newtype - IsNewtype - | -- | The contained value is a typeclass dictionary constructor - IsTypeClassConstructor - | -- | The contained reference is for a foreign member - IsForeign - | -- | The contained value is a where clause - IsWhere - | -- | The contained function application was synthesized by the compiler - IsSyntheticApp - deriving stock (Show, Eq, Ord) - --- | Data constructor metadata -data ConstructorType = ProductType | SumType - deriving stock (Show, Eq, Ord) diff --git a/lib/Language/PureScript/CoreFn/Module.hs b/lib/Language/PureScript/CoreFn/Module.hs deleted file mode 100644 index 27bcfb9..0000000 --- a/lib/Language/PureScript/CoreFn/Module.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Language.PureScript.CoreFn.Module where - -import Language.PureScript.Comments (Comment) -import Language.PureScript.CoreFn.Expr (Bind) -import Language.PureScript.Names (Ident, ModuleName) - -{- | -The CoreFn module representation --} -data Module a = Module - { moduleName ∷ ModuleName - , moduleComments ∷ [Comment] - , modulePath ∷ FilePath - , moduleImports ∷ [(a, ModuleName)] - , moduleExports ∷ [Ident] - , moduleReExports ∷ Map ModuleName [Ident] - , moduleForeign ∷ [Ident] - , moduleBindings ∷ [Bind a] - } - deriving stock (Functor, Show) diff --git a/lib/Language/PureScript/CoreFn/Reader.hs b/lib/Language/PureScript/CoreFn/Reader.hs deleted file mode 100644 index 6d0f1be..0000000 --- a/lib/Language/PureScript/CoreFn/Reader.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Language.PureScript.CoreFn.Reader where - -import Control.Monad.Oops (CouldBe, CouldBeAnyOf, Variant, throw) -import Control.Monad.Oops qualified as Oops -import Data.Aeson qualified as Json -import Data.Map.Lazy qualified as Map -import Data.Tagged (Tagged (unTagged)) -import Data.Text qualified as Text -import Language.PureScript.CoreFn qualified as Cfn -import Language.PureScript.CoreFn.FromJSON - ( ModuleWithVersion - , moduleWithoutVersion - ) -import Language.PureScript.Names qualified as PS -import Path - ( Abs - , Dir - , File - , Path - , SomeBase (..) - , mkRelFile - , parseRelDir - , toFilePath - , () - ) -import Path.IO (doesFileExist, makeAbsolute) - -readModuleRecursively - ∷ ∀ e - . e `CouldBeAnyOf` '[ModuleNotFound, ModuleDecodingErr] - ⇒ Tagged "output" (SomeBase Dir) - → PS.ModuleName - → ExceptT (Oops.Variant e) IO (Map PS.ModuleName (Cfn.Module Cfn.Ann)) -readModuleRecursively output moduleName = recurse mempty [moduleName] - where - recurse - ∷ Map PS.ModuleName (Cfn.Module Cfn.Ann) - → [PS.ModuleName] - → ExceptT (Oops.Variant e) IO (Map PS.ModuleName (Cfn.Module Cfn.Ann)) - recurse loaded = \case - [] → pure loaded - modName : otherNames - | "Prim" `Text.isPrefixOf` PS.runModuleName modName → - recurse loaded otherNames - modName : otherNames - | Map.member modName loaded → - recurse loaded otherNames - modName : otherNames → - readModule output modName >>= \m → - recurse - (Map.insert modName m loaded) - (otherNames <> (fmap snd . Cfn.moduleImports) m) - -readModule - ∷ e `CouldBeAnyOf` '[ModuleNotFound, ModuleDecodingErr] - ⇒ Tagged "output" (SomeBase Dir) - → PS.ModuleName - → ExceptT (Variant e) IO (Cfn.Module Cfn.Ann) -readModule output modName = do - path ← modulePath output modName - lift (Json.eitherDecodeFileStrict @ModuleWithVersion (toFilePath path)) - >>= either (throw . ModuleDecodingErr path) (pure . moduleWithoutVersion) - -modulePath - ∷ e `CouldBe` ModuleNotFound - ⇒ Tagged "output" (SomeBase Dir) - → PS.ModuleName - → ExceptT (Variant e) IO (Path Abs File) -modulePath psOutPath modName = do - psOutput ← - case unTagged psOutPath of - Abs a → pure a - Rel r → makeAbsolute r - prd ← parseRelDir (toString (PS.runModuleName modName)) - let path = psOutput prd $(mkRelFile "corefn.json") - unlessM (doesFileExist path) $ throw $ ModuleNotFound path - pure path - --------------------------------------------------------------------------------- --- Errors ---------------------------------------------------------------------- - -newtype ModuleNotFound = ModuleNotFound (Path Abs File) -data ModuleDecodingErr = ModuleDecodingErr (Path Abs File) String diff --git a/lib/Language/PureScript/CoreFn/Traversals.hs b/lib/Language/PureScript/CoreFn/Traversals.hs deleted file mode 100644 index f5ec9a9..0000000 --- a/lib/Language/PureScript/CoreFn/Traversals.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-local-signatures #-} - -{- | -CoreFn traversal helpers --} -module Language.PureScript.CoreFn.Traversals where - -import Control.Arrow ((***), (+++)) -import Language.PureScript.CoreFn.Expr - ( Bind (..) - , Binder (ConstructorBinder, LiteralBinder, NamedBinder) - , CaseAlternative (..) - , Expr (Abs, Accessor, App, Case, Let, Literal, ObjectUpdate) - , Literal (ArrayLiteral, ObjectLiteral) - ) - -everywhereOnValues - ∷ (Bind a → Bind a) - → (Expr a → Expr a) - → (Binder a → Binder a) - → (Bind a → Bind a, Expr a → Expr a, Binder a → Binder a) -everywhereOnValues f g h = (f', g', h') - where - f' (NonRec a name e) = f (NonRec a name (g' e)) - f' (Rec es) = f (Rec (map (second g') es)) - - g' (Literal ann e) = g (Literal ann (handleLiteral g' e)) - g' (Accessor ann prop e) = g (Accessor ann prop (g' e)) - g' (ObjectUpdate ann obj vs) = - g (ObjectUpdate ann (g' obj) (map (fmap g') vs)) - g' (Abs ann name e) = g (Abs ann name (g' e)) - g' (App ann v1 v2) = g (App ann (g' v1) (g' v2)) - g' (Case ann vs alts) = - g (Case ann (map g' vs) (map handleCaseAlternative alts)) - g' (Let ann ds e) = g (Let ann (map f' ds) (g' e)) - g' e = g e - - h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b)) - h' (NamedBinder a name b) = h (NamedBinder a name (h' b)) - h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs)) - h' b = h b - - handleCaseAlternative ca = - ca - { caseAlternativeBinders = map h' (caseAlternativeBinders ca) - , caseAlternativeResult = - (map (g' *** g') +++ g') (caseAlternativeResult ca) - } - - handleLiteral ∷ (a → a) → Literal a → Literal a - handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls) - handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls) - handleLiteral _ other = other - -{- | -Apply the provided functions to the top level of AST nodes. - -This function is useful as a building block for recursive functions, but -doesn't actually recurse itself. --} -traverseCoreFn - ∷ ∀ f a - . Applicative f - ⇒ (Bind a → f (Bind a)) - → (Expr a → f (Expr a)) - → (Binder a → f (Binder a)) - → (CaseAlternative a → f (CaseAlternative a)) - → ( Bind a → f (Bind a) - , Expr a → f (Expr a) - , Binder a - → f (Binder a) - , CaseAlternative a → f (CaseAlternative a) - ) -traverseCoreFn f g h i = (f', g', h', i') - where - f' (NonRec a name e) = NonRec a name <$> g e - f' (Rec es) = Rec <$> traverse (traverse g) es - - g' (Literal ann e) = Literal ann <$> handleLiteral g e - g' (Accessor ann prop e) = Accessor ann prop <$> g e - g' (ObjectUpdate ann obj vs) = - ObjectUpdate ann - <$> g obj - <*> traverse (traverse g) vs - g' (Abs ann name e) = Abs ann name <$> g e - g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 - g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts - g' (Let ann ds e) = Let ann <$> traverse f ds <*> g' e - g' e = pure e - - h' (LiteralBinder a b) = LiteralBinder a <$> handleLiteral h b - h' (NamedBinder a name b) = NamedBinder a name <$> h b - h' (ConstructorBinder a q1 q2 bs) = - ConstructorBinder a q1 q2 <$> traverse h bs - h' b = pure b - - i' ca = - CaseAlternative - <$> traverse h (caseAlternativeBinders ca) - <*> bitraverse (traverse $ bitraverse g g) g (caseAlternativeResult ca) - - handleLiteral withItem = \case - ArrayLiteral ls → ArrayLiteral <$> traverse withItem ls - ObjectLiteral ls → ObjectLiteral <$> traverse (traverse withItem) ls - other → pure other diff --git a/lib/Language/PureScript/Names.hs b/lib/Language/PureScript/Names.hs deleted file mode 100644 index df8290a..0000000 --- a/lib/Language/PureScript/Names.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Data types for names -module Language.PureScript.Names where - -import Data.Aeson - ( FromJSON (parseJSON) - , FromJSONKey (fromJSONKey) - , Options (sumEncoding) - , SumEncoding (ObjectWithSingleField) - , ToJSON (toJSON) - , ToJSONKey (toJSONKey) - , defaultOptions - , parseJSON2 - , toJSON2 - , withArray - ) -import Data.Aeson.TH (deriveJSON) -import Data.Text qualified as T -import Data.Vector qualified as V - --- | A sum of the possible name types, useful for error and lint messages. -data Name - = IdentName Ident - | TyName (ProperName 'TypeName) - | DctorName (ProperName 'ConstructorName) - | TyClassName (ProperName 'ClassName) - | ModName ModuleName - deriving stock (Eq, Ord, Show, Generic) - -getIdentName ∷ Name → Maybe Ident -getIdentName (IdentName name) = Just name -getIdentName _ = Nothing - -getTypeName ∷ Name → Maybe (ProperName 'TypeName) -getTypeName (TyName name) = Just name -getTypeName _ = Nothing - -getDctorName ∷ Name → Maybe (ProperName 'ConstructorName) -getDctorName (DctorName name) = Just name -getDctorName _ = Nothing - -getClassName ∷ Name → Maybe (ProperName 'ClassName) -getClassName (TyClassName name) = Just name -getClassName _ = Nothing - -{- | -This type is meant to be extended with any new uses for idents that come -along. Adding constructors to this type is cheaper than adding them to -`Ident` because functions that match on `Ident` can ignore all -`InternalIdent`s with a single pattern, and thus don't have to change if -a new `InternalIdentData` constructor is created. --} -data InternalIdentData - = -- Used by CoreFn.Laziness - RuntimeLazyFactory - | Lazy !Text - deriving stock (Show, Eq, Ord, Generic) - --- | Names for value identifiers -data Ident - = -- | - -- An alphanumeric identifier - Ident Text - | -- | - -- A generated name for an identifier - GenIdent (Maybe Text) Integer - | -- | - -- A generated name used only for type-checking - UnusedIdent - | -- | - -- A generated name used only for internal transformations - InternalIdent !InternalIdentData - deriving stock (Show, Eq, Ord, Generic) - -runIdent ∷ Ident → Text -runIdent = \case - Ident i → i - GenIdent Nothing n → "$" <> show n - GenIdent (Just name) n → "$" <> name <> show n - UnusedIdent → unusedIdent - InternalIdent internalIdentData → - case internalIdentData of - RuntimeLazyFactory → runtimeLazyName - Lazy t → "Lazy_" <> t - -runtimeLazyName :: Text -runtimeLazyName = "PSLUA_runtime_lazy" - -unusedIdent ∷ Text -unusedIdent = "$__unused" - -{- | Proper names, i.e. capitalized names for e.g. module names, -type/data constructors. --} -newtype ProperName (a ∷ ProperNameType) = ProperName {runProperName ∷ Text} - deriving stock (Show, Eq, Ord, Generic) - -instance ToJSON (ProperName a) where - toJSON = toJSON . runProperName - -instance FromJSON (ProperName a) where - parseJSON = fmap ProperName . parseJSON - --- | The closed set of proper name types. -data ProperNameType - = TypeName - | ConstructorName - | ClassName - | Namespace - -{- | -Coerces a ProperName from one ProperNameType to another. This should be used -with care, and is primarily used to convert ClassNames into TypeNames after -classes have been desugared. --} -coerceProperName ∷ ProperName a → ProperName b -coerceProperName = ProperName . runProperName - --- | Module names -newtype ModuleName = ModuleName Text - deriving stock (Show, Eq, Ord, Generic) - -runModuleName ∷ ModuleName → Text -runModuleName (ModuleName name) = name - -moduleNameFromString ∷ Text → ModuleName -moduleNameFromString = ModuleName - -isBuiltinModuleName ∷ ModuleName → Bool -isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn - --- | Source position information -data SourcePos = SourcePos - { sourcePosLine ∷ Int - , sourcePosColumn ∷ Int - } - deriving stock (Show, Eq, Ord, Generic) - -displaySourcePos ∷ SourcePos → Text -displaySourcePos sp = - "line " <> show (sourcePosLine sp) <> ", column " <> show (sourcePosColumn sp) - -displaySourcePosShort ∷ SourcePos → Text -displaySourcePosShort sp = - show (sourcePosLine sp) <> ":" <> show (sourcePosColumn sp) - -instance ToJSON SourcePos where - toJSON SourcePos {..} = - toJSON [sourcePosLine, sourcePosColumn] - -instance FromJSON SourcePos where - parseJSON arr = do - [line, col] ← parseJSON arr - return $ SourcePos line col - -data QualifiedBy - = BySourcePos SourcePos - | ByModuleName ModuleName - deriving stock (Show, Eq, Ord, Generic) - -pattern ByNullSourcePos ∷ QualifiedBy -pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) - -isBySourcePos ∷ QualifiedBy → Bool -isBySourcePos (BySourcePos _) = True -isBySourcePos _ = False - -byMaybeModuleName ∷ Maybe ModuleName → QualifiedBy -byMaybeModuleName (Just mn) = ByModuleName mn -byMaybeModuleName Nothing = ByNullSourcePos - -toMaybeModuleName ∷ QualifiedBy → Maybe ModuleName -toMaybeModuleName (ByModuleName mn) = Just mn -toMaybeModuleName (BySourcePos _) = Nothing - -{- | -A qualified name, i.e. a name with an optional module name --} -data Qualified a = Qualified QualifiedBy a - deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - -showQualified ∷ (a → Text) → Qualified a → Text -showQualified f = \case - Qualified (BySourcePos _) a → f a - Qualified (ByModuleName name) a → runModuleName name <> "." <> f a - -getQual ∷ Qualified a → Maybe ModuleName -getQual (Qualified qb _) = toMaybeModuleName qb - -{- | -Provide a default module name, if a name is unqualified --} -qualify ∷ ModuleName → Qualified a → (ModuleName, a) -qualify m (Qualified (BySourcePos _) a) = (m, a) -qualify _ (Qualified (ByModuleName m) a) = (m, a) - -{- | -Makes a qualified value from a name and module name. --} -mkQualified ∷ a → ModuleName → Qualified a -mkQualified name mn = Qualified (ByModuleName mn) name - --- | Remove the module name from a qualified name -disqualify ∷ Qualified a → a -disqualify (Qualified _ a) = a - -{- | -Remove the qualification from a value when it is qualified with a particular -module name. --} -disqualifyFor ∷ Maybe ModuleName → Qualified a → Maybe a -disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a -disqualifyFor _ _ = Nothing - -{- | -Checks whether a qualified value is actually qualified with a module reference --} -isQualified ∷ Qualified a → Bool -isQualified (Qualified (BySourcePos _) _) = False -isQualified _ = True - -{- | -Checks whether a qualified value is not actually qualified with a module reference --} -isUnqualified ∷ Qualified a → Bool -isUnqualified = not . isQualified - -{- | -Checks whether a qualified value is qualified with a particular module --} -isQualifiedWith ∷ ModuleName → Qualified a → Bool -isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' -isQualifiedWith _ _ = False - -instance ToJSON a ⇒ ToJSON (Qualified a) where - toJSON (Qualified qb a) = case qb of - ByModuleName mn → toJSON2 (mn, a) - BySourcePos ss → toJSON2 (ss, a) - -instance FromJSON a ⇒ FromJSON (Qualified a) where - parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' - where - byModule = do - (mn, a) ← parseJSON2 v - pure $ Qualified (ByModuleName mn) a - bySourcePos = do - (ss, a) ← parseJSON2 v - pure $ Qualified (BySourcePos ss) a - byMaybeModuleName' = do - (mn, a) ← parseJSON2 v - pure $ Qualified (byMaybeModuleName mn) a - -instance ToJSON ModuleName where - toJSON (ModuleName name) = toJSON (T.splitOn "." name) - -instance FromJSON ModuleName where - parseJSON = withArray "ModuleName" $ \names → do - names' ← traverse parseJSON names - pure (ModuleName (T.intercalate "." (V.toList names'))) - -instance ToJSONKey ModuleName where - toJSONKey = contramap runModuleName toJSONKey - -instance FromJSONKey ModuleName where - fromJSONKey = fmap moduleNameFromString fromJSONKey - -$( deriveJSON - (defaultOptions {sumEncoding = ObjectWithSingleField}) - ''InternalIdentData - ) -$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Ident) diff --git a/lib/Language/PureScript/PSString.hs b/lib/Language/PureScript/PSString.hs deleted file mode 100644 index d1d5186..0000000 --- a/lib/Language/PureScript/PSString.hs +++ /dev/null @@ -1,241 +0,0 @@ -module Language.PureScript.PSString - ( PSString - , toUTF16CodeUnits - , decodeString - , decodeStringEither - , decodeStringWithReplacement - , decodeStringEscaping - , prettyPrintStringJS - , mkString - ) where - -import Control.Exception (evaluate, try) -import Data.Aeson qualified as A -import Data.Aeson.Types qualified as A -import Data.Bits (shiftR) -import Data.ByteString qualified as BS -import Data.Char qualified as Char -import Data.Scientific (toBoundedInteger) -import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf16BE) -import Data.Vector qualified as V -import Numeric (showHex) -import System.IO.Unsafe (unsafePerformIO) -import Text.Show (Show (..)) -import Prelude hiding (show) - -{- | -Strings in PureScript are sequences of UTF-16 code units, which do not -necessarily represent UTF-16 encoded text. For example, it is permissible -for a string to contain *lone surrogates,* i.e. characters in the range -U+D800 to U+DFFF which do not appear as a part of a surrogate pair. - -The Show instance for PSString produces a string literal which would -represent the same data were it inserted into a PureScript source file. - -Because JSON parsers vary wildly in terms of how they deal with lone -surrogates in JSON strings, the ToJSON instance for PSString produces JSON -strings where that would be safe (i.e. when there are no lone surrogates), -and arrays of UTF-16 code units (integers) otherwise. --} -newtype PSString = PSString {toUTF16CodeUnits ∷ [Word16]} - deriving stock (Eq, Ord, Generic) - deriving newtype (Semigroup, Monoid) - -instance Show PSString where - show = show . codePoints - -{- | -Decode a PSString to a String, representing any lone surrogates as the -reserved code point with that index. Warning: if there are any lone -surrogates, converting the result to Text via Data.Text.pack will result in -loss of information as those lone surrogates will be replaced with U+FFFD -REPLACEMENT CHARACTER. Because this function requires care to use correctly, -we do not export it. --} -codePoints ∷ PSString → String -codePoints = map (either (Char.chr . fromIntegral) id) . decodeStringEither - -{- | -Decode a PSString as UTF-16 text. Lone surrogates will be replaced with -U+FFFD REPLACEMENT CHARACTER --} -decodeStringWithReplacement ∷ PSString → String -decodeStringWithReplacement = map (fromRight '\xFFFD') . decodeStringEither - -{- | -Decode a PSString as UTF-16. Lone surrogates in the input are represented in -the output with the Left constructor; characters which were successfully -decoded are represented with the Right constructor. --} -decodeStringEither ∷ PSString → [Either Word16 Char] -decodeStringEither = unfoldr decode . toUTF16CodeUnits - where - decode ∷ [Word16] → Maybe (Either Word16 Char, [Word16]) - decode (h : l : rest) - | isLead h && isTrail l = - Just (Right (unsurrogate h l), rest) - decode (c : rest) | isSurrogate c = Just (Left c, rest) - decode (c : rest) = Just (Right (toChar c), rest) - decode [] = Nothing - - unsurrogate ∷ Word16 → Word16 → Char - unsurrogate h l = - toEnum $ - (toInt h - 0xD800) * 0x400 - + (toInt l - 0xDC00) - + 0x10000 - -{- | -Attempt to decode a PSString as UTF-16 text. This will fail (returning -Nothing) if the argument contains lone surrogates. --} -decodeString ∷ PSString → Either UnicodeException Text -decodeString = - decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits - where - unpair w = [highByte w, lowByte w] - - lowByte ∷ Word16 → Word8 - lowByte = fromIntegral - - highByte ∷ Word16 → Word8 - highByte = fromIntegral . (`shiftR` 8) - - -- Based on a similar function from Data.Text.Encoding for utf8. This is a - -- safe usage of unsafePerformIO because there are no side effects after - -- handling any thrown UnicodeExceptions. - decodeEither ∷ ByteString → Either UnicodeException Text - decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE - -instance IsString PSString where - fromString a = PSString $ concatMap encodeUTF16 a - where - surrogates ∷ Char → (Word16, Word16) - surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00)) - where - (h, l) = divMod (fromEnum c - 0x10000) 0x400 - - encodeUTF16 ∷ Char → [Word16] - encodeUTF16 c | fromEnum c > 0xFFFF = [high, low] - where - (high, low) = surrogates c - encodeUTF16 c = [toWord $ fromEnum c] - -instance A.ToJSON PSString where - toJSON str = - case rightToMaybe (decodeString str) of - Just t → A.toJSON t - Nothing → A.toJSON (toUTF16CodeUnits str) - -instance A.FromJSON PSString where - parseJSON a = jsonString <|> arrayOfCodeUnits - where - jsonString = fromString <$> A.parseJSON a - - arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a - - parseArrayOfCodeUnits ∷ A.Value → A.Parser [Word16] - parseArrayOfCodeUnits = - A.withArray - "array of UTF-16 code units" - (traverse parseCodeUnit . V.toList) - - parseCodeUnit ∷ A.Value → A.Parser Word16 - parseCodeUnit b = - A.withScientific - "two-byte non-negative integer" - (maybe (A.typeMismatch "" b) return . toBoundedInteger) - b - -{- | -Decode a PSString as UTF-16, using PureScript escape sequences. --} -decodeStringEscaping ∷ PSString → Text -decodeStringEscaping s = foldMap encodeChar (decodeStringEither s) - where - encodeChar ∷ Either Word16 Char → Text - encodeChar (Left c) = "\\x" <> showHex' 6 c - encodeChar (Right c) - | c == '\t' = "\\t" - | c == '\r' = "\\r" - | c == '\n' = "\\n" - | c == '"' = "\\\"" - | c == '\'' = "\\\'" - | c == '\\' = "\\\\" - | shouldPrint c = T.singleton c - | otherwise = "\\x" <> showHex' 6 (Char.ord c) - - -- Note we do not use Data.Char.isPrint here because that includes things - -- like zero-width spaces and combining punctuation marks, which could be - -- confusing to print unescaped. - shouldPrint ∷ Char → Bool - -- The standard space character, U+20 SPACE, is the only space char we should - -- print without escaping - shouldPrint ' ' = True - shouldPrint c = - Char.generalCategory c - `elem` [ Char.UppercaseLetter - , Char.LowercaseLetter - , Char.TitlecaseLetter - , Char.OtherLetter - , Char.DecimalNumber - , Char.LetterNumber - , Char.OtherNumber - , Char.ConnectorPunctuation - , Char.DashPunctuation - , Char.OpenPunctuation - , Char.ClosePunctuation - , Char.InitialQuote - , Char.FinalQuote - , Char.OtherPunctuation - , Char.MathSymbol - , Char.CurrencySymbol - , Char.ModifierSymbol - , Char.OtherSymbol - ] -{- | -Pretty print a PSString, using JavaScript escape sequences. Intended for -use in compiled JS output. --} -prettyPrintStringJS ∷ PSString → Text -prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" - where - encodeChar ∷ Word16 → Text - encodeChar c | c > 0xFF = "\\u" <> showHex' 4 c - encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> showHex' 2 c - encodeChar c | toChar c == '\b' = "\\b" - encodeChar c | toChar c == '\t' = "\\t" - encodeChar c | toChar c == '\n' = "\\n" - encodeChar c | toChar c == '\v' = "\\v" - encodeChar c | toChar c == '\f' = "\\f" - encodeChar c | toChar c == '\r' = "\\r" - encodeChar c | toChar c == '"' = "\\\"" - encodeChar c | toChar c == '\\' = "\\\\" - encodeChar c = T.singleton $ toChar c - -showHex' ∷ Enum a ⇒ Int → a → Text -showHex' width c = - let hs = showHex (fromEnum c) "" - in T.pack (replicate (width - length hs) '0' <> hs) - -isLead ∷ Word16 → Bool -isLead h = h >= 0xD800 && h <= 0xDBFF - -isTrail ∷ Word16 → Bool -isTrail l = l >= 0xDC00 && l <= 0xDFFF - -isSurrogate ∷ Word16 → Bool -isSurrogate c = isLead c || isTrail c - -toChar ∷ Word16 → Char -toChar = toEnum . fromIntegral - -toWord ∷ Int → Word16 -toWord = fromIntegral - -toInt ∷ Word16 → Int -toInt = fromIntegral - -mkString ∷ Text → PSString -mkString = fromString . T.unpack diff --git a/pslua.cabal b/pslua.cabal index 70f957e..896ec66 100644 --- a/pslua.cabal +++ b/pslua.cabal @@ -74,7 +74,7 @@ common shared ViewPatterns build-depends: - , aeson ^>=2.2 + , aeson ^>=2.2.2 , array ^>=0.5.4.0 , base ^>=4.19.1 , containers ^>=0.6.5.1 @@ -94,6 +94,7 @@ common shared , pretty-simple ^>=4.1.2.0 , prettyprinter ^>=1.7.1 , prettyprinter-ansi-terminal ^>=1.1.3 + , purescript-corefn ^>=0.1 , quiet ^>=0.2 , relude ^>=1.2.1 , scientific ^>=0.3.7.0 @@ -140,18 +141,7 @@ library Language.PureScript.Backend.Lua.Printer Language.PureScript.Backend.Lua.Traversal Language.PureScript.Backend.Lua.Types - Language.PureScript.Backend.Types - Language.PureScript.Comments - Language.PureScript.CoreFn - Language.PureScript.CoreFn.Expr - Language.PureScript.CoreFn.FromJSON - Language.PureScript.CoreFn.Laziness - Language.PureScript.CoreFn.Meta - Language.PureScript.CoreFn.Module - Language.PureScript.CoreFn.Reader - Language.PureScript.CoreFn.Traversals - Language.PureScript.Names - Language.PureScript.PSString + Language.PureScript.Backend.AppOrModule test-suite spec import: shared @@ -171,6 +161,7 @@ test-suite spec Language.PureScript.Backend.Lua.Linker.Foreign.Spec Language.PureScript.Backend.Lua.Optimizer.Spec Language.PureScript.Backend.Lua.Printer.Spec + Language.PureScript.Backend.Lua.Traversal.Spec Test.Hspec.Expectations.Pretty Test.Hspec.Extra Test.Hspec.Golden diff --git a/scripts/watch_test b/scripts/watch_test new file mode 100755 index 0000000..4b8aabb --- /dev/null +++ b/scripts/watch_test @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +set -euo pipefail + + +args='' +for arg in "$@" +do + args="$args '$arg'" +done + +watchman-make -p '**/*.hs' -r "clear && cabal test $args" diff --git a/test/Language/PureScript/Backend/IR/DCE/Spec.hs b/test/Language/PureScript/Backend/IR/DCE/Spec.hs index e6e9af0..ca7fad3 100644 --- a/test/Language/PureScript/Backend/IR/DCE/Spec.hs +++ b/test/Language/PureScript/Backend/IR/DCE/Spec.hs @@ -12,15 +12,14 @@ import Language.PureScript.Backend.IR.Names , Name (Name) , QName (QName) , Qualified (Local) - , moduleNameFromString ) +import Language.PureScript.Backend.IR.Query (countFreeRefs) import Language.PureScript.Backend.IR.Types ( Ann , Exp , Grouping (..) , abstraction , application - , countFreeRefs , exception , lets , noAnn @@ -32,6 +31,7 @@ import Language.PureScript.Backend.IR.Types import Test.Hspec (Spec, describe, it) import Test.Hspec.Hedgehog.Extended (hedgehog, test) import Text.Pretty.Simple (pShow) +import qualified Language.PureScript.CoreFn as Cfn spec ∷ Spec spec = describe "IR Dead Code Elimination" do @@ -142,7 +142,7 @@ dceExpression e = -- Fixture --------------------------------------------------------------------- mainModuleName ∷ ModuleName -mainModuleName = moduleNameFromString "Main" +mainModuleName = Cfn.unsafeModuleNameFromText "Main" mainEntryPoint ∷ EntryPoint mainEntryPoint = EntryPoint mainModuleName [Name "main"] diff --git a/test/Language/PureScript/Backend/IR/Gen.hs b/test/Language/PureScript/Backend/IR/Gen.hs index 2f8bf82..b55a507 100644 --- a/test/Language/PureScript/Backend/IR/Gen.hs +++ b/test/Language/PureScript/Backend/IR/Gen.hs @@ -5,10 +5,11 @@ import Hedgehog (MonadGen) import Hedgehog.Corpus qualified as Corpus import Hedgehog.Gen.Extended qualified as Gen import Hedgehog.Range qualified as Range +import Language.PureScript.Backend.IR (ModuleName) import Language.PureScript.Backend.IR.Names qualified as IR import Language.PureScript.Backend.IR.Types (noAnn) import Language.PureScript.Backend.IR.Types qualified as IR -import Language.PureScript.Names (ModuleName, moduleNameFromString) +import Language.PureScript.CoreFn qualified as Cfn import Prelude hiding (exp) exp ∷ ∀ m. MonadGen m ⇒ m IR.Exp @@ -38,7 +39,10 @@ exp = ) , ( 2 - , IR.literalObject <$> Gen.list (Range.linear 1 10) ((,) <$> genPropName <*> exp) + , IR.literalObject + <$> Gen.list + (Range.linear 1 10) + ((,) <$> genPropName <*> exp) ) , ( 1 @@ -129,7 +133,7 @@ refLocal ∷ MonadGen m ⇒ m IR.Exp refLocal = flip IR.refLocal 0 <$> name moduleName ∷ MonadGen m ⇒ m ModuleName -moduleName = moduleNameFromString <$> Gen.element Corpus.colours +moduleName = Cfn.unsafeModuleNameFromText <$> Gen.element Corpus.colours name ∷ MonadGen m ⇒ m IR.Name name = IR.Name <$> Gen.element ["x", "y", "z", "i", "j", "k", "l"] diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index 56d119c..ad5bce6 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -6,12 +6,10 @@ import Hedgehog.Gen qualified as Gen import Language.PureScript.Backend.IR.Gen qualified as Gen import Language.PureScript.Backend.IR.Linker (LinkMode (..)) import Language.PureScript.Backend.IR.Linker qualified as Linker -import Language.PureScript.Backend.IR.Names - ( Name (..) - , moduleNameFromString - ) +import Language.PureScript.Backend.IR.Names (Name (..)) import Language.PureScript.Backend.IR.Optimizer - ( optimizedExpression + ( etaReduce + , optimizedExpression , optimizedUberModule , renameShadowedNamesInExpr ) @@ -33,7 +31,9 @@ import Language.PureScript.Backend.IR.Types , paramUnused , refLocal , refLocal0 + , rewriteExpTopDown ) +import Language.PureScript.CoreFn qualified as Cfn import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -60,6 +60,23 @@ spec = describe "IR Optimizer" do let f = abstraction paramUnused body body === optimizedExpression (application f arg) + test "does eta reduction" do + n ← forAll Gen.name + e ← forAll Gen.exp + let p = paramNamed n + r = refLocal n 0 + a = abstraction p (application e r) + rewriteExpTopDown etaReduce a === e + + test "does not do eta reduction when r is free in e" do + n ← forAll Gen.name + let p = paramNamed n + r = refLocal n 0 + a = + abstraction p $ + application (ifThenElse (literalBool True) r (literalInt 2)) r + rewriteExpTopDown etaReduce a === a + describe "inlines expressions" do test "inlines literals" do name ← forAll Gen.name @@ -97,7 +114,7 @@ spec = describe "IR Optimizer" do describe "inliner unlocks more optimizations" do test "constant folding after inlining" do name ← forAll Gen.name - let uberName = moduleNameFromString "Main" + let uberName = Cfn.unsafeModuleNameFromText "Main" linkMode = LinkAsModule uberName mkUber = Linker.makeUberModule linkMode . pure . wrapInModule let original = @@ -209,7 +226,7 @@ spec = describe "IR Optimizer" do wrapInModule ∷ Exp → Module wrapInModule e = Module - { moduleName = moduleNameFromString "Main" + { moduleName = Cfn.unsafeModuleNameFromText "Main" , moduleBindings = [Standalone (noAnn, Name "main", e)] , moduleImports = [] , moduleExports = [Name "main"] diff --git a/test/Language/PureScript/Backend/IR/Spec.hs b/test/Language/PureScript/Backend/IR/Spec.hs index 91e1270..e783d98 100644 --- a/test/Language/PureScript/Backend/IR/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Spec.hs @@ -7,7 +7,6 @@ import Language.PureScript.Backend.IR (Context (..), RepM, mkCase, runRepM) import Language.PureScript.Backend.IR.Names (Name (..), PropName (..)) import Language.PureScript.Backend.IR.Types import Language.PureScript.CoreFn qualified as Cfn -import Language.PureScript.Names qualified as PS import Language.PureScript.PSString qualified as PS import Test.Hspec (Spec, describe, it, shouldBe) @@ -360,7 +359,7 @@ spec = describe "IR representation" do [cfnCharE 't', cfnCharE 'z'] [ Cfn.CaseAlternative { caseAlternativeBinders = - [ cfnVarB (PS.Ident "x") + [ cfnVarB (Cfn.Ident "x") , cfnLitB (cfnCharL 'a') ] , caseAlternativeResult = Right $ cfnRef "x" @@ -368,7 +367,7 @@ spec = describe "IR representation" do , Cfn.CaseAlternative { caseAlternativeBinders = [ cfnLitB (cfnCharL 'b') - , cfnVarB (PS.Ident "y") + , cfnVarB (Cfn.Ident "y") ] , caseAlternativeResult = Right $ cfnRef "y" } @@ -396,8 +395,8 @@ spec = describe "IR representation" do [cfnCharE 'x', cfnCharE 'y'] [ Cfn.CaseAlternative { caseAlternativeBinders = - [ cfnNamB (PS.Ident "v") cfnNullB - , cfnNamB (PS.Ident "z") cfnNullB + [ cfnNamB (Cfn.Ident "v") cfnNullB + , cfnNamB (Cfn.Ident "z") cfnNullB ] , caseAlternativeResult = Right $ cfnRef "z" } @@ -415,16 +414,16 @@ spec = describe "IR representation" do [cfnCharE 'x', cfnCharE 'y'] [ Cfn.CaseAlternative { caseAlternativeBinders = - [ cfnNamB (PS.Ident "a") (cfnLitB (cfnCharL 'a')) - , cfnNamB (PS.Ident "b") (cfnLitB (cfnCharL 'b')) + [ cfnNamB (Cfn.Ident "a") (cfnLitB (cfnCharL 'a')) + , cfnNamB (Cfn.Ident "b") (cfnLitB (cfnCharL 'b')) ] , caseAlternativeResult = Right $ cfnApp (cfnRef "a") (cfnRef "b") } , Cfn.CaseAlternative { caseAlternativeBinders = - [ cfnNamB (PS.Ident "o1") cfnNullB - , cfnNamB (PS.Ident "o2") cfnNullB + [ cfnNamB (Cfn.Ident "o1") cfnNullB + , cfnNamB (Cfn.Ident "o2") cfnNullB ] , caseAlternativeResult = Right $ cfnApp (cfnRef "o2") (cfnRef "o1") @@ -500,7 +499,7 @@ ann = Nothing cfnModule ∷ ∀ {a}. Cfn.Module a cfnModule = Cfn.Module - { moduleName = PS.ModuleName "M" + { moduleName = Cfn.unsafeModuleNameFromText "M" , moduleComments = mempty , modulePath = "M.purs" , moduleImports = mempty @@ -510,11 +509,11 @@ cfnModule = , moduleBindings = mempty } -cfnQualifyModule ∷ a → PS.Qualified a -cfnQualifyModule = PS.Qualified (PS.ByModuleName (PS.ModuleName "ModuleName")) +cfnQualifyModule ∷ a → Cfn.Qualified a +cfnQualifyModule = Cfn.Qualified (Cfn.ByModuleName (Cfn.unsafeModuleNameFromText "ModuleName")) -cfnLocalIdent ∷ Text → PS.Qualified PS.Ident -cfnLocalIdent = PS.Qualified (PS.BySourcePos (PS.SourcePos 0 0)) . PS.Ident +cfnLocalIdent ∷ Text → Cfn.Qualified Cfn.Ident +cfnLocalIdent = Cfn.Qualified (Cfn.BySourcePos (Cfn.SourcePos 0 0)) . Cfn.Ident cfnRef ∷ Text → Cfn.Expr Cfn.Ann cfnRef = Cfn.Var ann . cfnLocalIdent @@ -543,10 +542,10 @@ cfnObject o = Cfn.Literal ann $ Cfn.ObjectLiteral (first PS.mkString <$> o) cfnLitB ∷ Cfn.Literal (Cfn.Binder Cfn.Ann) → Cfn.Binder Cfn.Ann cfnLitB = Cfn.LiteralBinder ann -cfnVarB ∷ PS.Ident → Cfn.Binder Cfn.Ann +cfnVarB ∷ Cfn.Ident → Cfn.Binder Cfn.Ann cfnVarB = Cfn.VarBinder ann -cfnNamB ∷ PS.Ident → Cfn.Binder Cfn.Ann → Cfn.Binder Cfn.Ann +cfnNamB ∷ Cfn.Ident → Cfn.Binder Cfn.Ann → Cfn.Binder Cfn.Ann cfnNamB = Cfn.NamedBinder ann cfnNullB ∷ Cfn.Binder Cfn.Ann diff --git a/test/Language/PureScript/Backend/IR/Types/Spec.hs b/test/Language/PureScript/Backend/IR/Types/Spec.hs index 88d7393..b9f27bd 100644 --- a/test/Language/PureScript/Backend/IR/Types/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Types/Spec.hs @@ -2,17 +2,13 @@ module Language.PureScript.Backend.IR.Types.Spec where import Data.Map qualified as Map import Hedgehog ((===)) -import Language.PureScript.Backend.IR.Names - ( ModuleName (..) - , Name (..) - , Qualified (Imported) - ) +import Language.PureScript.Backend.IR.Names (Name (..), Qualified (Imported)) +import Language.PureScript.Backend.IR.Query (countFreeRefs) import Language.PureScript.Backend.IR.Types ( Exp , Grouping (..) , abstraction , application - , countFreeRefs , lets , literalInt , noAnn @@ -21,6 +17,7 @@ import Language.PureScript.Backend.IR.Types , refImported , refLocal ) +import Language.PureScript.CoreFn qualified as Cfn import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -29,14 +26,17 @@ spec = describe "Types" do test "countFreeRefs" do countFreeRefs expr === Map.fromList - [ (Imported (ModuleName "Data.Array") (Name "add"), 1) - , (Imported (ModuleName "Data.Array") (Name "eq1"), 1) - , (Imported (ModuleName "Data.Array") (Name "findLastIndex"), 1) - , (Imported (ModuleName "Data.Array") (Name "fromJust"), 1) - , (Imported (ModuleName "Data.Array") (Name "insertAt"), 1) - , (Imported (ModuleName "Data.Maybe") (Name "maybe"), 1) - , (Imported (ModuleName "Data.Ordering") (Name "GT"), 1) - , (Imported (ModuleName "Partial.Unsafe") (Name "unsafePartial"), 1) + [ (Imported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "add"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "eq1"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "findLastIndex"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "fromJust"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "insertAt"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Maybe") (Name "maybe"), 1) + , (Imported (Cfn.unsafeModuleNameFromText "Data.Ordering") (Name "GT"), 1) + , + ( Imported (Cfn.unsafeModuleNameFromText "Partial.Unsafe") (Name "unsafePartial") + , 1 + ) ] expr ∷ Exp @@ -54,14 +54,14 @@ expr = , application ( application ( application - (refImported (ModuleName "Data.Maybe") (Name "maybe") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Maybe") (Name "maybe") 0) (literalInt 0) ) ( abstraction (paramNamed (Name "v")) ( application ( application - (refImported (ModuleName "Data.Array") (Name "add") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "add") 0) (refLocal (Name "v") 0) ) (literalInt 1) @@ -70,12 +70,13 @@ expr = ) ( application ( application - (refImported (ModuleName "Data.Array") (Name "findLastIndex") 0) + ( refImported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "findLastIndex") 0 + ) ( abstraction (paramNamed (Name "y")) ( application ( application - (refImported (ModuleName "Data.Array") (Name "eq1") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "eq1") 0) ( application ( application (refLocal (Name "cmp") 0) @@ -84,7 +85,7 @@ expr = (refLocal (Name "y") 0) ) ) - (refImported (ModuleName "Data.Ordering") (Name "GT") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Ordering") (Name "GT") 0) ) ) ) @@ -94,15 +95,19 @@ expr = :| [] ) ( application - (refImported (ModuleName "Partial.Unsafe") (Name "unsafePartial") 0) + ( refImported + (Cfn.unsafeModuleNameFromText "Partial.Unsafe") + (Name "unsafePartial") + 0 + ) ( abstraction paramUnused ( application - (refImported (ModuleName "Data.Array") (Name "fromJust") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "fromJust") 0) ( application ( application ( application - (refImported (ModuleName "Data.Array") (Name "insertAt") 0) + (refImported (Cfn.unsafeModuleNameFromText "Data.Array") (Name "insertAt") 0) (refLocal (Name "i") 0) ) (refLocal (Name "x") 0) diff --git a/test/Language/PureScript/Backend/Lua/DCE/Spec.hs b/test/Language/PureScript/Backend/Lua/DCE/Spec.hs index e6e68e6..7410738 100644 --- a/test/Language/PureScript/Backend/Lua/DCE/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/DCE/Spec.hs @@ -8,14 +8,14 @@ import Hedgehog (annotateShow, forAll, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Language.PureScript.Backend.Lua.DCE - ( DceMode (PreserveReturned) + ( DceAnn (..) + , DceMode (PreserveReturned) , MonadScopes (..) ) import Language.PureScript.Backend.Lua.DCE qualified as DCE import Language.PureScript.Backend.Lua.Fixture qualified as Fixture import Language.PureScript.Backend.Lua.Gen qualified as Gen import Language.PureScript.Backend.Lua.Name qualified as Lua -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -30,58 +30,58 @@ spec = describe "Lua Dead Code Elimination" do let chunk = [ Lua.local name1 . Just $ - Lua.functionDef [ParamNamed name2] [Lua.return expr1] - , Lua.return $ Lua.functionCall (Lua.varName name1) [expr2] + Lua.functionDef [Lua.paramNamed name2] [Lua.return expr1] + , Lua.return $ Lua.functionCall (Lua.varNameExp name1) [expr2] ] let chunk' = [ Lua.local name1 . Just $ - Lua.functionDef [ParamUnused] [Lua.return expr1] - , Lua.return $ Lua.functionCall (Lua.varName name1) [expr2] + Lua.functionDef [Lua.paramUnused] [Lua.return expr1] + , Lua.return $ Lua.functionCall (Lua.varNameExp name1) [expr2] ] DCE.eliminateDeadCode PreserveReturned chunk === chunk' test "Eliminates unused local binding" do - [usedLocal@(Lua.Local name _val), unusedLocal1, unusedLocal2] ← + [usedLocal@(Lua.Local _ann name _val), unusedLocal1, unusedLocal2] ← forAll . fmap toList $ Gen.set (Range.singleton 3) Gen.local - let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varName name) [] + let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varNameExp name) [] let chunk = [unusedLocal1, usedLocal, unusedLocal2, Lua.return fnCall] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === [usedLocal, Lua.return fnCall] test "Eliminates unused local binding inside a function" do - [usedLocal@(Lua.Local name _val), unusedLocal1, unusedLocal2] ← + [usedLocal@(Lua.Local _ann name _val), unusedLocal1, unusedLocal2] ← forAll . fmap toList $ Gen.set (Range.singleton 3) Gen.local - let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varName name) [] + let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varNameExp name) [] let body = [unusedLocal1, usedLocal, unusedLocal2, Lua.return fnCall] body' = [usedLocal, Lua.return fnCall] let chunk = - [Lua.return $ Lua.functionDef [ParamNamed [Lua.name|unusedArg|]] body] - chunk' = [Lua.return $ Lua.functionDef [ParamUnused] body'] + [Lua.return $ Lua.functionDef [Lua.paramNamed [Lua.name|unusedArg|]] body] + chunk' = [Lua.return $ Lua.functionDef [Lua.paramUnused] body'] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk' test "Doesn't eliminate local binding used transitively" do name0 ← forAll Gen.name - localDef@(Lua.Local name1 _val) ← forAll Gen.local - let retCall = Lua.return (Lua.functionCall (Lua.varName name0) []) + localDef@(Lua.Local _ann name1 _val) ← forAll Gen.local + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name0) []) chunk = [ localDef - , Lua.local name0 (Just (Lua.varName name1)) + , Lua.local name0 (Just (Lua.varNameExp name1)) , retCall ] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk test "Eliminates unused assign statement" do - localDef@(Lua.Local name _val) ← forAll Gen.local + localDef@(Lua.Local _ann name _val) ← forAll Gen.local name_ ← forAll $ mfilter (/= name) Gen.name value_ ← forAll Gen.expression - let retCall = Lua.return (Lua.functionCall (Lua.varName name) []) + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name) []) let chunk = [ localDef , Lua.local name_ Nothing - , Lua.assign (Lua.VarName name_) value_ + , Lua.assignVar name_ value_ , retCall ] annotateShow chunk @@ -90,10 +90,10 @@ spec = describe "Lua Dead Code Elimination" do test "Doesn't eliminate used assign statement" do name ← forAll Gen.name value_ ← forAll Gen.expression - let retCall = Lua.return (Lua.functionCall (Lua.varName name) []) + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name) []) let chunk = - [ Lua.Local name Nothing - , Lua.assign (Lua.VarName name) value_ + [ Lua.local name Nothing + , Lua.assignVar name value_ , retCall ] annotateShow chunk @@ -103,50 +103,70 @@ spec = describe "Lua Dead Code Elimination" do let name = Fixture.runtimeLazyName let chunk = [ Fixture.runtimeLazy - , Lua.return (Lua.functionCall (Lua.varName name) []) + , Lua.return (Lua.functionCall (Lua.varNameExp name) []) ] DCE.eliminateDeadCode PreserveReturned chunk === chunk + test "findAssignments" do + let name = [Lua.name|a|] + let chunk = + [ Lua.Local + (DceAnn Lua.newAnn 1 []) + name + (Just (Lua.Integer (DceAnn Lua.newAnn 11 []) 11)) + , Lua.Assign + (DceAnn Lua.newAnn 2 []) + (Lua.VarName (DceAnn Lua.newAnn 20 []) name) + (Lua.Integer (DceAnn Lua.newAnn 21 []) 2) + , Lua.Return (DceAnn Lua.newAnn 3 []) $ + Lua.FunctionCall + (DceAnn Lua.newAnn 3 []) + ( Lua.Var + (DceAnn Lua.newAnn 31 []) + (Lua.VarName (DceAnn Lua.newAnn 32 []) name) + ) + [] + ] + DCE.findAssignments name chunk === pure 2 + test "scopes" do - let name = Fixture.runtimeLazyName + name ← forAll Gen.name let chunk = [ Lua.local1 name $ - Lua.Function + Lua.functionDef [] - [ Lua.ann $ - Lua.ifThenElse - (Lua.Integer 100 `Lua.equalTo` Lua.Integer 0) - [Lua.Return ((), Lua.Integer 1)] - [Lua.Return ((), Lua.Integer 2)] + [ Lua.ifThenElse + (Lua.integer 100 `Lua.equalTo` Lua.integer 0) + [Lua.return (Lua.integer 1)] + [Lua.return (Lua.integer 2)] ] - , Lua.return (Lua.functionCall (Lua.varName name) []) + , Lua.return (Lua.functionCall (Lua.varNameExp name) []) ] + annotateShow $ scopeAssignmentTraces chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk test "Adds/removes scopes correctly" do let n1 = [Lua.name|a|] - chunk ∷ [Lua.Statement] - chunk = + chunk ∷ [Lua.Statement] = [ Lua.local1 n1 $ - Lua.Function + Lua.functionDef [] - [ Lua.ann $ - Lua.ifThenElse - (Lua.Integer 100 `Lua.equalTo` Lua.Integer 0) - [Lua.Return ((), Lua.Integer 1)] - [Lua.Return ((), Lua.Integer 2)] + [ Lua.ifThenElse + (Lua.integer 100 `Lua.equalTo` Lua.integer 0) + [Lua.return (Lua.integer 1)] + [Lua.return (Lua.integer 2)] ] - , Lua.return (Lua.functionCall (Lua.varName n1) []) + , Lua.return (Lua.functionCall (Lua.varNameExp n1) []) ] scopeAssignmentTraces chunk - === [ AddName n1 9 (fromList [(n1, 9)] :| []) - , AddScope (mempty :| [fromList [(n1, 9)]]) - , AddScope (mempty :| [mempty, fromList [(n1, 9)]]) - , AddScope (mempty :| [mempty, mempty, fromList [(n1, 9)]]) - , DropScope [mempty, mempty, fromList [(n1, 9)]] - , DropScope [mempty, fromList [(n1, 9)]] - , DropScope [fromList [(n1, 9)]] + === [ AddName n1 0 (fromList [(n1, 0)] :| []) + , AddScope (mempty :| [fromList [(n1, 0)]]) + , AddScope (mempty :| [mempty, fromList [(n1, 0)]]) + , AddScope (mempty :| [mempty, mempty, fromList [(n1, 0)]]) + , DropScope [mempty, mempty, fromList [(n1, 0)]] + , DropScope [mempty, fromList [(n1, 0)]] + , DropScope [fromList [(n1, 0)]] ] scopeAssignmentTraces ∷ [Lua.Statement] → [Trace] diff --git a/test/Language/PureScript/Backend/Lua/Gen.hs b/test/Language/PureScript/Backend/Lua/Gen.hs index 6a41fa7..65a7fce 100644 --- a/test/Language/PureScript/Backend/Lua/Gen.hs +++ b/test/Language/PureScript/Backend/Lua/Gen.hs @@ -5,16 +5,25 @@ import Hedgehog (Gen, Range) import Hedgehog.Gen.Extended qualified as Gen import Hedgehog.Range qualified as Range import Language.PureScript.Backend.Lua.Name (Name, unsafeName) +import Language.PureScript.Backend.Lua.Optimizer (AppliedHow (..)) import Language.PureScript.Backend.Lua.Printer (printStatement) -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prettyprinter (defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict) import Prelude hiding (local, return) -chunk ∷ Gen Lua.Chunk +chunk ∷ Gen [Lua.Statement] chunk = Gen.list (Range.linear 1 16) statement +term ∷ Gen Lua.Term +term = + Gen.frequency + [ (6, Lua.S <$> statement) + , (7, Lua.E <$> expression) + , (1, Lua.V <$> nonRecursiveVar) + , (1, Lua.R <$> tableRow) + ] + statement ∷ Gen Lua.Statement statement = Gen.recursiveFrequency nonRecursiveStatements recursiveStatements @@ -47,7 +56,7 @@ recursiveStatements = [(2, ifThenElse)] foreignSourceCode ∷ Gen Lua.Statement foreignSourceCode = - Lua.ForeignSourceStat + Lua.foreignStatement . renderStrict . layoutPretty defaultLayoutOptions . printStatement @@ -85,27 +94,27 @@ nonRecursiveExpressions = ] nil ∷ Gen Lua.Exp -nil = Gen.constant Lua.Nil +nil = Gen.constant Lua.nil literalBool ∷ Gen Lua.Exp -literalBool = Lua.Boolean <$> Gen.bool +literalBool = Lua.boolean <$> Gen.bool literalInt ∷ Gen Lua.Exp -literalInt = Lua.Integer <$> Gen.integral integerRange +literalInt = Lua.integer <$> Gen.integral integerRange where integerRange ∷ Range Integer integerRange = fromIntegral <$> (Range.exponentialBounded ∷ Range Int64) literalFloat ∷ Gen Lua.Exp literalFloat = - Lua.Float + Lua.float <$> Gen.double (Range.exponentialFloatFrom 0 (-1234567890.0) 1234567890) literalString ∷ Gen Lua.Exp -literalString = Lua.String <$> Gen.text (Range.linear 1 16) Gen.unicode +literalString = Lua.string <$> Gen.text (Range.linear 1 16) Gen.unicode nonRecursiveVar ∷ Gen Lua.Var -nonRecursiveVar = Gen.frequency [(1, Lua.VarName <$> name)] +nonRecursiveVar = Gen.frequency [(1, Lua.VarName Lua.newAnn <$> name)] recursiveExpressions ∷ [(Int, Gen Lua.Exp)] recursiveExpressions = @@ -122,7 +131,7 @@ function = Lua.functionDef <$> Gen.list (Range.linear 0 5) - (maybe ParamUnused ParamNamed <$> Gen.maybe name) + (maybe Lua.paramUnused Lua.paramNamed <$> Gen.maybe name) <*> chunk unOp ∷ Gen Lua.Exp @@ -137,10 +146,16 @@ table = Lua.table <$> Gen.list (Range.linear 0 5) tableRow recursiveVar ∷ Gen Lua.Exp recursiveVar = do Gen.choice - [ Lua.varIndex <$> expression <*> expression - , Lua.varField <$> expression <*> name + [ fmap Lua.var . Lua.varIndex <$> expression <*> expression + , fmap Lua.var . Lua.varField <$> expression <*> name ] functionCall ∷ Gen Lua.Exp functionCall = Lua.functionCall <$> expression <*> Gen.list (Range.linear 0 5) expression + +appliedHow ∷ Gen AppliedHow +appliedHow = Gen.enumBounded + +knownAppliedHow ∷ Gen AppliedHow +knownAppliedHow = Gen.filter (/= Unknown) appliedHow diff --git a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs index e712f35..01e8264 100644 --- a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs @@ -9,6 +9,8 @@ import Data.List qualified as List import Data.String qualified as String import Data.Tagged (Tagged (..)) import Data.Text qualified as Text +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) +import Language.PureScript.Backend.IR (ModuleName) import Language.PureScript.Backend.IR qualified as IR import Language.PureScript.Backend.IR.Linker (LinkMode (..)) import Language.PureScript.Backend.IR.Linker qualified as IR @@ -17,9 +19,8 @@ import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule) import Language.PureScript.Backend.Lua qualified as Lua import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk) import Language.PureScript.Backend.Lua.Printer qualified as Printer -import Language.PureScript.Backend.Types (AppOrModule (..)) +import Language.PureScript.CoreFn qualified as Cfn import Language.PureScript.CoreFn.Reader qualified as CoreFn -import Language.PureScript.Names qualified as PS import Path ( Abs , Dir @@ -89,7 +90,7 @@ spec = do for_ corefns \corefn → do let modulePath = parent corefn moduleName = - PS.ModuleName + Cfn.unsafeModuleNameFromText . toText . FilePath.dropTrailingPathSeparator . toFilePath @@ -120,8 +121,8 @@ spec = do it luaTestName do defaultGolden luaGolden (Just luaActual) do appOrModule ← - (doesFileExist evalGolden) <&> \case - True → AsApplication moduleName (PS.Ident "main") + doesFileExist evalGolden <&> \case + True → AsApplication moduleName (Cfn.Ident "main") False → AsModule moduleName cfn ← compileCorefn (Tagged (Rel psOutputPath)) moduleName compileIr appOrModule cfn @@ -201,7 +202,7 @@ compileCorefn ∷ ∀ m . (MonadIO m, MonadFail m) ⇒ Tagged "output" (SomeBase Dir) - → PS.ModuleName + → ModuleName → m IR.UberModule compileCorefn outputDir uberModuleName = do cfnModules ← diff --git a/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs b/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs index 9910a2a..f8a5420 100644 --- a/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs @@ -2,16 +2,31 @@ module Language.PureScript.Backend.Lua.Optimizer.Spec where +import Hedgehog (annotate, forAll, (===)) +import Language.PureScript.Backend.Lua.Gen qualified as Gen import Language.PureScript.Backend.Lua.Name (name) import Language.PureScript.Backend.Lua.Optimizer - ( pushDeclarationsDownTheInnerScope + ( AppliedHow (..) + , RewriteRule + , appliedHow + , collapseFunCalls + , pushDeclarationsDownTheInnerScope , removeScopeWhenInsideEmptyFunction - , rewriteExpWithRule + , rewriteCurried ) -import Language.PureScript.Backend.Lua.Types (ParamF (..)) +import Language.PureScript.Backend.Lua.Printer (printLuaChunk) +import Language.PureScript.Backend.Lua.Traversal (everywhereExp) import Language.PureScript.Backend.Lua.Types qualified as Lua +import Prettyprinter (defaultLayoutOptions, layoutPretty) +import Prettyprinter.Render.Text (renderStrict) import Test.Hspec (Spec, describe, it) -import Test.Hspec.Expectations.Pretty (assertEqual) +import Test.Hspec.Expectations.Pretty + ( assertEqualPretty + , assertEqualShowing + , shouldBe + ) +import Test.Hspec.Hedgehog (hedgehog) +import Test.Hspec.Hedgehog.Extended (test) import Text.Pretty.Simple (pShow) spec ∷ Spec @@ -20,48 +35,400 @@ spec = describe "Lua AST Optimizer" do it "removes scope when inside an empty function" do let original ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|]] + [Lua.paramNamed [name|a|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|b|]] - [Lua.return (Lua.scope [Lua.return (Lua.varName [name|c|])])] + [Lua.paramNamed [name|b|]] + [ Lua.return + ( Lua.scope + [Lua.return $ Lua.var (Lua.varName [name|c|])] + ) + ] ) ] expected ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|]] + [Lua.paramNamed [name|a|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|b|]] - [Lua.return (Lua.varName [name|c|])] + [Lua.paramNamed [name|b|]] + [Lua.return $ Lua.var (Lua.varName [name|c|])] ) ] - assertEqual (toString $ pShow original) expected $ + assertEqualPretty (toString $ pShow original) expected $ rewriteExpWithRule removeScopeWhenInsideEmptyFunction original it "pushes declarations down into an inner scope" do let original ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|], ParamNamed [name|b|]] - [ Lua.local1 [name|i|] (Lua.Integer 42) - , Lua.local1 [name|j|] (Lua.Integer 43) + [Lua.paramNamed [name|a|], Lua.paramNamed [name|b|]] + [ Lua.local1 [name|i|] (Lua.integer 42) + , Lua.local1 [name|j|] (Lua.integer 43) , Lua.return ( Lua.functionDef - [ParamNamed [name|d|]] - [Lua.return (Lua.varName [name|c|])] + [Lua.paramNamed [name|d|]] + [Lua.return $ Lua.var (Lua.varName [name|c|])] ) ] expected ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|], ParamNamed [name|b|]] + [Lua.paramNamed [name|a|], Lua.paramNamed [name|b|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|d|]] - [ Lua.local1 [name|i|] (Lua.Integer 42) - , Lua.local1 [name|j|] (Lua.Integer 43) - , Lua.return (Lua.varName [name|c|]) + [Lua.paramNamed [name|d|]] + [ Lua.local1 [name|i|] (Lua.integer 42) + , Lua.local1 [name|j|] (Lua.integer 43) + , Lua.return $ Lua.var (Lua.varName [name|c|]) ] ) ] - assertEqual (toString $ pShow @Lua.Exp original) expected $ + assertEqualPretty (toString $ pShow @Lua.Exp original) expected $ rewriteExpWithRule pushDeclarationsDownTheInnerScope original + + describe "Determines how a variable is applied" do + it "Unknown always loses" $ hedgehog do + how ← forAll Gen.appliedHow + Unknown <> how === how + + it "AppliedAtLeastTwice always loses" $ hedgehog do + how ← forAll Gen.knownAppliedHow + AppliedAtLeastTwice <> how === how + + it "NotApplied always wins" $ hedgehog do + how ← forAll Gen.knownAppliedHow + NotApplied <> how === NotApplied + + it "is not applied" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = [Lua.S . Lua.return $ Lua.var var] + appliedHow var terms `shouldBe` NotApplied + + it "is applied once" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall + (Lua.var var) + [Lua.functionCall (Lua.var var) [Lua.string "x"]] + , Lua.S . Lua.return $ + Lua.functionCall + ( Lua.functionCall + (Lua.var var) + [Lua.string "y"] + ) + [Lua.functionCall (Lua.var var) [Lua.string "z"]] + ] + appliedHow var terms `shouldBe` AppliedOnce + + it "is applied at least twice" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall (Lua.functionCall (Lua.var var) []) [] + ] + appliedHow var terms `shouldBe` AppliedAtLeastTwice + + it "is applied twice but with different vars" do + let var1 ∷ Lua.Var = Lua.varName [name|v1|] + let var2 ∷ Lua.Var = Lua.varName [name|v2|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall (Lua.functionCall (Lua.var var1) []) [] + ] + appliedHow var2 terms `shouldBe` Unknown + + describe "Uncurries functions" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let printedChunk s = + toString . unlines $ + [ renderStrict . layoutPretty defaultLayoutOptions $ + printLuaChunk (fromList s) + ] + let assertRewriteCurried + ∷ HasCallStack + ⇒ Lua.Var + → [Lua.Statement] + → Maybe [Lua.Statement] + → IO () + assertRewriteCurried variable stats expected = + assertEqualShowing showRewriteCurried "" expected actual + where + actual = rewriteCurried variable stats + -- actual = rewriteTillFixpoint (rewriteCurried variable) stats + showRewriteCurried = \case + Nothing → "Nothing" + Just s → printedChunk s + + it "No uncurrying if function is never referred to by name" do + assertRewriteCurried var [] Nothing + + it "No uncurrying if function is never applied" do + let stats = [Lua.return $ Lua.var var] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a function is applied once" do + let call1 = Lua.functionCall (Lua.var var) [Lua.integer 1] + let call2 = Lua.functionCall call1 [Lua.integer 2] + let stats = [Lua.assignVar [name|r|] call1, Lua.return call2] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a function is applied to one argument at least once" do + let varEx = Lua.var var + call1 = Lua.functionCall varEx [] + call2 = Lua.functionCall call1 [Lua.integer 1] + call3 = Lua.functionCall call2 [Lua.integer 2] + stats = + [ Lua.assignVar [name|tmp1|] call2 + , Lua.assignVar [name|tmp2|] call1 + , Lua.return call3 + ] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a variable is reassigned" do + let var0 = Lua.varName [name|v0|] + var1 = Lua.varName [name|v1|] + call1 = Lua.functionCall (Lua.var var1) [Lua.integer 1] + stats = + [ Lua.assign var1 (Lua.var var0) + , Lua.return $ Lua.functionCall call1 [Lua.integer 2] + ] + assertRewriteCurried var stats Nothing + + it "Uncurried: up to min number of applications (2)" do + let varEx = Lua.var var + call1 = Lua.functionCall varEx [] + call2 = Lua.functionCall call1 [Lua.nil, Lua.integer 1] + call3 = Lua.functionCall call2 [Lua.integer 2] + call2' = + Lua.functionCall varEx [Lua.nil, Lua.nil, Lua.integer 1] + call3' = + Lua.functionCall + ( Lua.functionCall + varEx + [Lua.nil, Lua.nil, Lua.integer 1] + ) + [Lua.integer 2] + stats = + [ Lua.assignVar [name|tmp1|] call2 + , Lua.assignVar [name|tmp2|] call3 + , Lua.return call3 + ] + stats' = + [ Lua.assignVar [name|tmp1|] call2' + , Lua.assignVar [name|tmp2|] call3' + , Lua.return call3' + ] + assertRewriteCurried var stats $ Just stats' + + test "Uncurried: rewrite 3 times" do + let varEx = Lua.var var + call3 = + Lua.functionCall + ( Lua.functionCall + (Lua.functionCall varEx []) + [Lua.nil, Lua.integer 1] + ) + [Lua.integer 2] + + let rewrittenOnce = rewriteCurried var [Lua.return call3] + + annotate $ toString $ pShow rewrittenOnce + + let rewrittenTwice = rewriteCurried var =<< rewrittenOnce + + annotate $ toString $ pShow rewrittenTwice + + let rewrittenThrice = rewriteCurried var =<< rewrittenTwice + + annotate $ toString $ pShow rewrittenThrice + + rewrittenOnce + === Just + [ Lua.return $ + Lua.functionCall + (Lua.functionCall varEx [Lua.nil, Lua.nil, Lua.integer 1]) + [Lua.integer 2] + ] + + rewrittenTwice + === Just + [ Lua.return $ + Lua.functionCall + varEx + [ Lua.nil + , Lua.nil + , Lua.integer 1 + , Lua.integer 2 + ] + ] + + rewrittenThrice === Nothing + + {- + + (fun ((fun 1) 2)) ((fun 3) 4) + + ==> + + fun (fun (1, 2), fun (3, 4)) + + -} + test "rewrite 2 + 2" do + let fun = Lua.var var + terms = + [ Lua.return $ + Lua.functionCall + ( Lua.functionCall + fun + [ Lua.functionCall + (Lua.functionCall fun [Lua.string "1"]) + [Lua.string "2"] + ] + ) + [ Lua.functionCall + (Lua.functionCall fun [Lua.string "3"]) + [Lua.string "4"] + ] + ] + + actual = rewriteTillFixpoint (rewriteCurried var) terms + + annotate $ toString $ pShow actual + + actual + === Just + [ Lua.return $ + Lua.functionCall + fun + [ Lua.functionCall fun [Lua.string "1", Lua.string "2"] + , Lua.functionCall fun [Lua.string "3", Lua.string "4"] + ] + ] + + let subterms = + Lua.functionCall -- 5 + ( Lua.functionCall -- 4 + ( Lua.functionCall -- 3 + ( Lua.functionCall -- 2 + ( Lua.functionCall -- 1 + (Lua.varNameExp [name|v|]) + [] -- 1 + ) + [Lua.string "a"] -- 2 + ) + [Lua.string "b", Lua.integer 1] -- 3 + ) + [Lua.integer 2] -- 4 + ) + [Lua.integer 3] -- 5 + -- + it "rewrite curried functions, sample 1" do + let + _0 = Lua.integer 0 + _1 = Lua.integer 1 + fooField = Lua.varField (Lua.var (Lua.varName [name|M|])) [name|foo|] + + {- + + if foo(0)(1) + then return 0 + else return foo(0)(1) + + ====> + + if foo(0, 1) -- rewritten + then return 0 + else return foo(0, 1) -- rewritten + -} + original = + Lua.ifThenElse + (Lua.boolean True) + [ Lua.return + ( Lua.functionCall + (Lua.functionCall (Lua.var fooField) [_0]) + [_1] + ) + ] + [ Lua.return + ( Lua.functionCall + (Lua.functionCall (Lua.var fooField) [_0]) + [_1] + ) + ] + + {- Lua.ifThenElse + ( Lua.functionCall + (Lua.functionCall (Lua.var fooField) [_0]) + [_1] + ) + [Lua.return _0] + [ Lua.return + ( Lua.functionCall + (Lua.functionCall (Lua.var fooField) [_0]) + [_1] + ) + ] -} + + rewritten = + {- Lua.ifThenElse + (Lua.functionCall (Lua.var fooField) [_0, _1]) + [Lua.return _0] + [ Lua.return + (Lua.functionCall (Lua.var fooField) [_0, _1]) + ] -} + + Lua.ifThenElse + (Lua.boolean True) + [Lua.return (Lua.functionCall (Lua.var fooField) [_0, _1])] + [Lua.return (Lua.functionCall (Lua.var fooField) [_0, _1])] + + assertRewriteCurried fooField [original] (Just [rewritten]) + + test "collapseFunCalls 0" do + collapseFunCalls 0 subterms === Lua.E subterms + + test "collapseFunCalls 1" do + collapseFunCalls 1 subterms === Lua.E subterms + + test "collapseFunCalls 2" do + collapseFunCalls 2 subterms + === Lua.E + ( Lua.functionCall -- 5 + ( Lua.functionCall -- 4 + ( Lua.functionCall -- 3 + ( Lua.functionCall -- (1 + 2) + (Lua.varNameExp [name|v|]) + [Lua.nil, Lua.string "a"] + ) + [Lua.string "b", Lua.integer 1] -- 3 + ) + [Lua.integer 2] -- 4 + ) + [Lua.integer 3] -- 5 + ) + + test "collapseFunCalls 4" do + collapseFunCalls 4 subterms + === Lua.E + ( Lua.functionCall -- 5 + ( Lua.functionCall + (Lua.varNameExp [name|v|]) + [ Lua.nil -- 1 + , Lua.string "a" -- 2 + , Lua.string "b" -- 3 + , Lua.integer 1 -- 3 + , Lua.integer 2 -- 4 + ] + ) + [Lua.integer 3] -- 5 + ) + +rewriteExpWithRule ∷ RewriteRule → Lua.Exp → Lua.Exp +rewriteExpWithRule rule = everywhereExp rule identity + +rewriteTillFixpoint ∷ (t → Maybe t) → t → Maybe t +rewriteTillFixpoint f ss = + let r = f ss + in case r of + Nothing → Just ss + Just ss' → rewriteTillFixpoint f ss' diff --git a/test/Language/PureScript/Backend/Lua/Printer/Spec.hs b/test/Language/PureScript/Backend/Lua/Printer/Spec.hs index f1f4857..f9626cf 100644 --- a/test/Language/PureScript/Backend/Lua/Printer/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Printer/Spec.hs @@ -6,7 +6,6 @@ module Language.PureScript.Backend.Lua.Printer.Spec where import Data.Text qualified as Text import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Printer qualified as Printer -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict) @@ -18,48 +17,48 @@ spec = do (rendered . Printer.printName) [Lua.name|foo|] `shouldBe` "foo" it "VarName" do - renderedExpression (Lua.varName [Lua.name|foo|]) `shouldBe` "foo" + renderedExpression (Lua.varNameExp [Lua.name|foo|]) `shouldBe` "foo" describe "VarField" do it "var.field" do - let e = Lua.varName [Lua.name|expr|] + let e = Lua.varNameExp [Lua.name|expr|] f = [Lua.name|foo|] - renderedExpression (Lua.varField e f) `shouldBe` "expr.foo" + renderedExpression (Lua.varFieldExp e f) `shouldBe` "expr.foo" it "({field = 1}).field" do - let e = Lua.table [Lua.tableRowNV f (Lua.Integer 1)] + let e = Lua.table [Lua.tableRowNV f (Lua.integer 1)] f = [Lua.name|foo|] - renderedExpression (Lua.varField e f) `shouldBe` "({ foo = 1 }).foo" + renderedExpression (Lua.varFieldExp e f) `shouldBe` "({ foo = 1 }).foo" it "Assignment" do - let s = Lua.assign (Lua.VarName [Lua.name|foo|]) (Lua.Boolean True) + let s = Lua.assignVar [Lua.name|foo|] (Lua.boolean True) renderedStatement s `shouldBe` "foo = true" describe "Local declaration" do it "without a value" do - let s = Lua.Local [Lua.name|foo|] Nothing + let s = Lua.local [Lua.name|foo|] Nothing renderedStatement s `shouldBe` "local foo" it "with value" do - let s = Lua.local [Lua.name|foo|] (Just (Lua.Boolean True)) + let s = Lua.local [Lua.name|foo|] (Just (Lua.boolean True)) renderedStatement s `shouldBe` "local foo = true" describe "If Then Else" do it "if / then" do - let p = Lua.Boolean True - let t = pure $ Lua.return $ Lua.Integer 1 + let p = Lua.boolean True + let t = pure $ Lua.return $ Lua.integer 1 let s = Lua.ifThenElse p t [] renderedStatement s `shouldBe` "if true then return 1 end" it "if / then / else" do - let p = Lua.Boolean True - let t = pure $ Lua.return $ Lua.Integer 1 - let e = pure $ Lua.return $ Lua.Integer 0 + let p = Lua.boolean True + let t = pure $ Lua.return $ Lua.integer 1 + let e = pure $ Lua.return $ Lua.integer 0 let s = Lua.ifThenElse p t e renderedStatement s `shouldBe` "if true then return 1 else return 0 end" describe "Return" do it "statement" do - let s = Lua.return $ Lua.Boolean True + let s = Lua.return $ Lua.boolean True renderedStatement s `shouldBe` "return true" describe "Table" do @@ -69,18 +68,18 @@ spec = do it "small table constructor in one line" do let e = Lua.table - [ Lua.tableRowKV (Lua.Integer 42) (Lua.Boolean True) - , Lua.tableRowNV [Lua.name|foo|] (Lua.String "ok") + [ Lua.tableRowKV (Lua.integer 42) (Lua.boolean True) + , Lua.tableRowNV [Lua.name|foo|] (Lua.string "ok") ] renderedExpression e `shouldBe` "{ [42] = true, foo = \"ok\" }" it "large table constructor on muliple lines" do let e = Lua.table - [ Lua.tableRowKV (Lua.Integer 42) (Lua.Boolean True) - , Lua.tableRowNV [Lua.name|foo|] (Lua.String "bar") - , Lua.tableRowNV [Lua.name|loooooooooooong1|] (Lua.String "value") - , Lua.tableRowNV [Lua.name|loooooooooooong2|] (Lua.String "value") + [ Lua.tableRowKV (Lua.integer 42) (Lua.boolean True) + , Lua.tableRowNV [Lua.name|foo|] (Lua.string "bar") + , Lua.tableRowNV [Lua.name|loooooooooooong1|] (Lua.string "value") + , Lua.tableRowNV [Lua.name|loooooooooooong2|] (Lua.string "value") ] renderedExpression e `shouldBe` multiline @@ -94,18 +93,18 @@ spec = do describe "function" do it "one-liner" do - let params = ParamNamed <$> [[Lua.name|a|], [Lua.name|b|]] - let result = Lua.Integer 1 - let stats = [Lua.assign (Lua.VarName [Lua.name|x|]) Lua.Nil] + let params = Lua.paramNamed <$> [[Lua.name|a|], [Lua.name|b|]] + let result = Lua.integer 1 + let stats = [Lua.assignVar [Lua.name|x|] Lua.nil] let expr = Lua.functionDef params (stats <> [Lua.return result]) renderedExpression expr `shouldBe` "function(a, b) x = nil return 1 end" it "multi-liner" do - let params = ParamNamed <$> [[Lua.name|aaa|], [Lua.name|bbb|]] + let params = Lua.paramNamed <$> [[Lua.name|aaa|], [Lua.name|bbb|]] let result = - Lua.varName + Lua.varNameExp [Lua.name|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|] - let stats = [Lua.assign (Lua.VarName [Lua.name|x|]) Lua.Nil] + let stats = [Lua.assignVar [Lua.name|x|] Lua.nil] let expr = Lua.functionDef params (stats <> [Lua.return result]) renderedExpression expr `shouldBe` multiline @@ -118,40 +117,40 @@ spec = do let expr = Lua.functionCall ( Lua.functionDef - [ParamNamed [Lua.name|a|], ParamNamed [Lua.name|b|]] - [Lua.return (Lua.varName [Lua.name|a|])] + [Lua.paramNamed [Lua.name|a|], Lua.paramNamed [Lua.name|b|]] + [Lua.return (Lua.varNameExp [Lua.name|a|])] ) - [Lua.Integer 1, Lua.Integer 2] + [Lua.integer 1, Lua.integer 2] renderedExpression expr `shouldBe` "(function(a, b) return a end)(1, 2)" describe "expression" do describe "unary" do it "hash" do - renderedExpression (Lua.hash (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.hash (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "#(foo)" it "negate" do - renderedExpression (Lua.negate (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.negate (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "-(foo)" it "logicalNot" do - renderedExpression (Lua.logicalNot (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.logicalNot (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "not(foo)" it "bitwiseNot" do - renderedExpression (Lua.bitwiseNot (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.bitwiseNot (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "~(foo)" describe "binary" do it "Op with lower precedence is braced" do renderedExpression - ((Lua.Integer 2 `Lua.add` Lua.Integer 3) `Lua.mul` Lua.Integer 4) + ((Lua.integer 2 `Lua.add` Lua.integer 3) `Lua.mul` Lua.integer 4) `shouldBe` "(2 + 3) * 4" it "Op with higher precedence is not braced" do renderedExpression - (Lua.Integer 2 `Lua.add` (Lua.Integer 3 `Lua.mul` Lua.Integer 4)) + (Lua.integer 2 `Lua.add` (Lua.integer 3 `Lua.mul` Lua.integer 4)) `shouldBe` "2 + 3 * 4" -------------------------------------------------------------------------------- diff --git a/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs b/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs new file mode 100644 index 0000000..fac9a67 --- /dev/null +++ b/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Language.PureScript.Backend.Lua.Traversal.Spec where + +import Control.Lens.Plated qualified as Plated +import Control.Monad.Trans.Accum (Accum, add, execAccum) +import Data.Set qualified as Set +import Hedgehog (annotate, forAll, (===)) +import Language.PureScript.Backend.Lua.Gen qualified as Gen +import Language.PureScript.Backend.Lua.Name qualified as Lua +import Language.PureScript.Backend.Lua.Types qualified as Lua +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Hedgehog (hedgehog) +import Test.Hspec.Hedgehog.Extended (test) +import Text.Pretty.Simple (pShow) + +spec ∷ Spec +spec = do + describe "Plated-based traversals" do + test "Not rewriting a single term is identity" do + name ← forAll Gen.name + let term = Lua.S (Lua.assignVar name (Lua.boolean True)) + annotate $ toString $ pShow term + Plated.rewrite (const Nothing) term === term + + it "Not rewriting a single term visits every term once" $ hedgehog do + term ← forAll Gen.term + annotate $ toString $ pShow term + let visit ∷ Lua.Term → Accum [Lua.Term] (Maybe (Lua.Term)) + visit t = do + add [t] + pure Nothing + Set.fromList (execAccum (Plated.rewriteM visit term) []) + === Set.fromList (Plated.universe term) + + it "Rewrites all named variables to fields" do + term ← forAll Gen.term + name ← forAll Gen.name + annotate $ toString $ pShow term + let term' = + term & Plated.rewrite \case + Lua.V (Lua.VarName ann n) + | n /= name → + Just $ Lua.V (Lua.VarField ann (Lua.varNameExp name) n) + _ → Nothing + [n | Lua.V (Lua.VarName _ann n) ← Plated.universe term', n /= name] === [] + + test "Rewrites terms bottom-up" do + let term = + Lua.E + ( Lua.functionCall + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + [Lua.string "outermost"] + ) + annotate $ toString $ pShow term + execAccum (Plated.transformM (\t → add [t] $> t) term) [] + === [ Lua.V (Lua.varName [Lua.name|innermost|]) + , Lua.E (Lua.varNameExp [Lua.name|innermost|]) + , Lua.E (Lua.string "inner") + , Lua.E + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + , Lua.E (Lua.string "outer") + , Lua.E + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + , Lua.E (Lua.string "outermost") + , Lua.E + ( Lua.functionCall + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + [Lua.string "outermost"] + ) + ] diff --git a/test/Main.hs b/test/Main.hs index 75c4202..7e4d086 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import Language.PureScript.Backend.Lua.Golden.Spec qualified as Golden import Language.PureScript.Backend.Lua.Linker.Foreign.Spec qualified as LuaLinkerForeign import Language.PureScript.Backend.Lua.Optimizer.Spec qualified as LuaOptimizer import Language.PureScript.Backend.Lua.Printer.Spec qualified as Printer +import Language.PureScript.Backend.Lua.Traversal.Spec qualified as LuaTraversal import Test.Hspec (hspec) main ∷ IO () @@ -18,6 +19,7 @@ main = hspec do Inliner.spec Golden.spec IrDce.spec + LuaTraversal.spec LuaDce.spec Types.spec IROptimizer.spec diff --git a/test/Test/Hspec/Expectations/Pretty.hs b/test/Test/Hspec/Expectations/Pretty.hs index 46f2805..48eb9fa 100644 --- a/test/Test/Hspec/Expectations/Pretty.hs +++ b/test/Test/Hspec/Expectations/Pretty.hs @@ -10,7 +10,10 @@ import Test.HUnit.Lang import Text.Pretty.Simple (pShow) shouldBe ∷ (HasCallStack, Eq a, Show a) ⇒ a → a → Assertion -shouldBe expected actual = assertEqual "" actual expected +shouldBe expected actual = assertEqualPretty "" actual expected + +assertEqualPretty ∷ (HasCallStack, Eq a, Show a) ⇒ String → a → a → Assertion +assertEqualPretty = assertEqualShowing (toString . pShow) {- | Asserts that the specified actual value is equal to the expected value. The output message will contain the prefix, the expected value, and the @@ -19,16 +22,18 @@ shouldBe expected actual = assertEqual "" actual expected If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted and only the expected and actual values are output. -} -assertEqual - ∷ (HasCallStack, Eq a, Show a) - ⇒ String +assertEqualShowing + ∷ (HasCallStack, Eq a) + ⇒ (a → String) + -- ^ A function to convert the expected value to a string + → String -- ^ The message prefix → a -- ^ The expected value → a -- ^ The actual value → Assertion -assertEqual preface expected actual = +assertEqualShowing shower preface expected actual = unless (actual == expected) do prefaceMsg `deepseq` expectedMsg @@ -41,8 +46,8 @@ assertEqual preface expected actual = prefaceMsg | null preface = Nothing | otherwise = Just preface - expectedMsg = toString $ pShow expected - actualMsg = toString $ pShow actual + expectedMsg = shower expected + actualMsg = shower actual location ∷ HasCallStack ⇒ Maybe SrcLoc location = case reverse Data.CallStack.callStack of diff --git a/test/Test/Hspec/Golden.hs b/test/Test/Hspec/Golden.hs index 381ac97..d6a220b 100644 --- a/test/Test/Hspec/Golden.hs +++ b/test/Test/Hspec/Golden.hs @@ -10,6 +10,7 @@ where import Path (Abs, File, Path, parent, toFilePath) import Path.IO (createDirIfMissing, doesFileExist) +import System.Environment.Blank (getEnv) import Test.Hspec.Core.Spec ( Example (..) , FailureReason (..) @@ -78,6 +79,8 @@ fromGoldenResult = \case Result "Golden and Actual output hasn't changed" Success FirstExecutionSucceed → Result "First time execution. Golden file created." Success + GoldenFileOverwritten → + Result "Golden file overwritten" Success FirstExecutionFail → Result "First time execution. Golden file created." @@ -107,6 +110,7 @@ defaultGolden goldenFile actualFile produceOutput = data GoldenResult = MissmatchOutput String String | SameOutput + | GoldenFileOverwritten | FirstExecutionSucceed | FirstExecutionFail @@ -134,10 +138,15 @@ runGolden Golden {..} = do else FirstExecutionSucceed else do contentGolden ← readFromFile goldenFile - pure - if contentGolden == output - then SameOutput - else - MissmatchOutput - (encodePretty contentGolden) - (encodePretty output) + overwriteGolden ← isJust <$> getEnv "UPDATE_GOLDEN" + if contentGolden == output + then pure SameOutput + else + if overwriteGolden + then + GoldenFileOverwritten <$ writeToFile goldenFile output + else + pure $ + MissmatchOutput + (encodePretty contentGolden) + (encodePretty output) diff --git a/test/ps/golden/Golden/Bug2/Test.purs b/test/ps/golden/Golden/Bug2/Test.purs new file mode 100644 index 0000000..be96025 --- /dev/null +++ b/test/ps/golden/Golden/Bug2/Test.purs @@ -0,0 +1,14 @@ +module Golden.Bug2.Test (main) where + +import Prelude (Unit, pure, map) + +import Data.Maybe (Maybe(Just, Nothing), maybe) +import Effect (Effect) +import Effect.Exception (throw) + +main :: Effect Unit +main = + maybe + (throw "Some error") + pure + (maybe Nothing Just (map (\x -> x) Nothing)) diff --git a/test/ps/golden/Golden/Inline/Test.purs b/test/ps/golden/Golden/Inline/Test.purs index 447ac04..f4902ff 100644 --- a/test/ps/golden/Golden/Inline/Test.purs +++ b/test/ps/golden/Golden/Inline/Test.purs @@ -1,4 +1,9 @@ -module Golden.Inline.Test where +module Golden.Inline.Test + ( main + , Mu + , runMu + , iMu + ) where main :: Int main = @@ -7,3 +12,11 @@ main = in let y :: forall b. b -> Int y _ = 2 in x y + +newtype Mu a = MkMu (Mu a -> a) + +runMu :: forall a. Mu a -> a +runMu mu@(MkMu f) = f mu + +iMu :: Mu Int +iMu = MkMu runMu diff --git a/test/ps/golden/Golden/PatternMatching/Test3.purs b/test/ps/golden/Golden/PatternMatching/Test3.purs new file mode 100644 index 0000000..a871462 --- /dev/null +++ b/test/ps/golden/Golden/PatternMatching/Test3.purs @@ -0,0 +1,34 @@ +module Golden.PatternMatching.Test3 where + +import Prelude + +test1 :: { a :: Int, b :: Int } -> Int +test1 = case _ of + { a } | a > 0 -> a + { b } | b > 0 -> b + _ -> 0 + +test2 :: { a :: Int, b :: Int } -> Int +test2 = case _ of + { a } | a > 0 -> a + { a: _, b } | b > 0 -> b + _ -> 0 + +test3 :: { a :: Int, b :: Int } -> Int +test3 = case _ of + { a, b: _ } | a > 0 -> a + { b } | b > 0 -> b + _ -> 0 + +test4 :: { a :: Int, b :: Int } -> Int +test4 = case _ of + { a, b: _ } | a > 0 -> a + { a: _, b } | b > 0 -> b + _ -> 0 + +test5 :: { a :: Int, b :: Int } -> Int +test5 = case _ of + { a, b } + | a > 0 -> a + | b > 0 -> b + _ -> 0 diff --git a/test/ps/golden/Golden/Uncurrying/Test.purs b/test/ps/golden/Golden/Uncurrying/Test.purs new file mode 100644 index 0000000..a0a89dd --- /dev/null +++ b/test/ps/golden/Golden/Uncurrying/Test.purs @@ -0,0 +1,25 @@ +module Golden.Uncurrying.Test (call2, call3, call4, call5) where + +uncurryFirst2Args :: Int -> Boolean -> Char -> Int +uncurryFirst2Args i _b _c = i + +call2 :: Char -> Int +call2 = uncurryFirst2Args 1 true + +call3 :: Int +call3 = uncurryFirst2Args 2 false 'a' + +uncurryFirst4Args :: Int -> Int -> Int -> Int -> Int -> Int +uncurryFirst4Args i _j _k _l _m = i + +call4 :: Int -> Int +call4 = uncurryFirst4Args 1 2 3 (synonym 4 5 6) + +uncurryFirst3Args :: Int -> Int -> Int -> Int +uncurryFirst3Args _i _j k = k + +synonym :: Int -> Int -> Int -> Int +synonym = uncurryFirst3Args + +call5 :: Int -> Int +call5 i = synonym 1 i 3 diff --git a/test/ps/golden/Golden/Uncurrying/Test2.purs b/test/ps/golden/Golden/Uncurrying/Test2.purs new file mode 100644 index 0000000..0e08643 --- /dev/null +++ b/test/ps/golden/Golden/Uncurrying/Test2.purs @@ -0,0 +1,11 @@ +module Golden.Uncurrying.Test2 (test) where + +uncurried :: Int -> Int -> Boolean +uncurried 1 1 = true +uncurried _ _ = false + +test :: { a :: Int, b :: Int } -> Int +test = case _ of + { a } | uncurried a 0 -> a + { b } | uncurried b 0 -> b + _ -> 0 diff --git a/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua b/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua index b02e938..35d5a15 100644 --- a/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua +++ b/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua @@ -109,8 +109,8 @@ M.Effect_Lazy_applyEffect = PSLUA_runtime_lazy("applyEffect")(function() return { apply = (function() return function(f) - local bind = M.Control_Bind_bind(M.Effect_monadEffect.Bind1()) return function(a) + local bind = M.Control_Bind_bind(M.Effect_monadEffect.Bind1()) return bind(f)(function(fPrime) return bind(a)(function(aPrime) return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) diff --git a/test/ps/output/Golden.Bug2.Test/corefn.json b/test/ps/output/Golden.Bug2.Test/corefn.json new file mode 100644 index 0000000..ed10130 --- /dev/null +++ b/test/ps/output/Golden.Bug2.Test/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[9,20],"start":[9,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[11,8],"start":[11,3]}},"type":"Var","value":{"identifier":"maybe","moduleName":["Data","Maybe"]}},"annotation":{"meta":null,"sourceSpan":{"end":[12,25],"start":[11,3]}},"argument":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[12,11],"start":[12,6]}},"type":"Var","value":{"identifier":"throw","moduleName":["Effect","Exception"]}},"annotation":{"meta":null,"sourceSpan":{"end":[12,24],"start":[12,6]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[12,24],"start":[12,12]}},"type":"Literal","value":{"literalType":"StringLiteral","value":"Some error"}},"type":"App"},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[13,9],"start":[11,3]}},"argument":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[13,9],"start":[13,5]}},"type":"Var","value":{"identifier":"pure","moduleName":["Control","Applicative"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[13,9],"start":[13,5]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"applicativeEffect","moduleName":["Effect"]}},"type":"App"},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[11,3]}},"argument":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[14,11],"start":[14,6]}},"type":"Var","value":{"identifier":"maybe","moduleName":["Data","Maybe"]}},"annotation":{"meta":null,"sourceSpan":{"end":[14,19],"start":[14,6]}},"argument":{"annotation":{"meta":{"constructorType":"SumType","identifiers":[],"metaType":"IsConstructor"},"sourceSpan":{"end":[14,19],"start":[14,12]}},"type":"Var","value":{"identifier":"Nothing","moduleName":["Data","Maybe"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,24],"start":[14,6]}},"argument":{"annotation":{"meta":{"constructorType":"SumType","identifiers":["value0"],"metaType":"IsConstructor"},"sourceSpan":{"end":[14,24],"start":[14,20]}},"type":"Var","value":{"identifier":"Just","moduleName":["Data","Maybe"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,48],"start":[14,6]}},"argument":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[14,29],"start":[14,26]}},"type":"Var","value":{"identifier":"map","moduleName":["Data","Functor"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[14,39],"start":[14,26]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"functorMaybe","moduleName":["Data","Maybe"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,39],"start":[14,26]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[14,38],"start":[14,31]}},"argument":"x","body":{"annotation":{"meta":null,"sourceSpan":{"end":[14,38],"start":[14,37]}},"type":"Var","value":{"identifier":"x","sourcePos":[14,32]}},"type":"Abs"},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,47],"start":[14,26]}},"argument":{"annotation":{"meta":{"constructorType":"SumType","identifiers":[],"metaType":"IsConstructor"},"sourceSpan":{"end":[14,47],"start":[14,40]}},"type":"Var","value":{"identifier":"Nothing","moduleName":["Data","Maybe"]}},"type":"App"},"type":"App"},"type":"App"},"identifier":"main"}],"exports":["main"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Control","Applicative"]},{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Data","Functor"]},{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Data","Maybe"]},{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Effect"]},{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Effect","Exception"]},{"annotation":{"meta":null,"sourceSpan":{"end":[3,33],"start":[3,1]}},"moduleName":["Prelude"]},{"annotation":{"meta":null,"sourceSpan":{"end":[14,49],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Bug2","Test"],"modulePath":"golden/Golden/Bug2/Test.purs","reExports":{},"sourceSpan":{"end":[14,49],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Bug2.Test/golden.ir b/test/ps/output/Golden.Bug2.Test/golden.ir new file mode 100644 index 0000000..fe80e4d --- /dev/null +++ b/test/ps/output/Golden.Bug2.Test/golden.ir @@ -0,0 +1,360 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Effect" ) ".spago/effect/v4.1.0/src/Effect.purs" + [ ( Nothing, Name "pureE" ), ( Nothing, Name "bindE" ) ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Effect.Exception", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Effect.Exception" ) ".spago/exceptions/v6.1.0/src/Effect/Exception.purs" + [ ( Nothing, Name "error" ), ( Nothing, Name "throwException" ) ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Control.Applicative", qnameName = Name "pure" + }, Abs Nothing + ( ParamNamed Nothing ( Name "dict" ) ) + ( ObjectProp Nothing ( Ref Nothing ( Local ( Name "dict" ) ) 0 ) ( PropName "pure" ) ) + ), Standalone + ( QName + { qnameModuleName = ModuleName "Data.Maybe", qnameName = Name "Nothing" + }, Ctor Nothing SumType + ( ModuleName "Data.Maybe" ) + ( TyName "Maybe" ) + ( CtorName "Nothing" ) [] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Data.Maybe", qnameName = Name "Just" + }, Ctor Nothing SumType + ( ModuleName "Data.Maybe" ) + ( TyName "Maybe" ) + ( CtorName "Just" ) + [ FieldName "value0" ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Data.Maybe", qnameName = Name "maybe" }, Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "v1" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "v2" ) ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Data.Maybe∷Maybe.Nothing" ) + ( ReflectCtor Nothing ( Ref Nothing ( Local ( Name "v2" ) ) 0 ) ) + ) + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Data.Maybe∷Maybe.Just" ) + ( ReflectCtor Nothing ( Ref Nothing ( Local ( Name "v2" ) ) 0 ) ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "v1" ) ) 0 ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v2" ) ) 0 ) + ( PropName "value0" ) + ) + ) + ( Exception Nothing "No patterns matched" ) + ) + ) + ) + ) + ), RecursiveGroup + ( + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "monadEffect" + }, LiteralObject Nothing + [ + ( PropName "Applicative0", Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 ) + ), + ( PropName "Bind1", Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 ) + ) + ] + ) :| + [ + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "bindEffect" + }, LiteralObject Nothing + [ + ( PropName "bind", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) + ( PropName "bindE" ) + ), + ( PropName "Apply0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_applyEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "applicativeEffect" + }, LiteralObject Nothing + [ + ( PropName "pure", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) + ( PropName "pureE" ) + ), + ( PropName "Apply0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_applyEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "Lazy_functorEffect" + }, App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "PSLUA_runtime_lazy" ) ) 0 ) + ( LiteralString Nothing "functorEffect" ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "map", Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( App Nothing + ( ObjectProp Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 + ) + ( PropName "Apply0" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) + ( PropName "apply" ) + ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 + ) + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 + ) + ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ) + ) + ) + ] + ) + ) + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "Lazy_applyEffect" + }, App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "PSLUA_runtime_lazy" ) ) 0 ) + ( LiteralString Nothing "applyEffect" ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "apply", Let Nothing + ( Standalone + ( Nothing, Name "bind", ObjectProp Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "monadEffect" ) ) 0 + ) + ( PropName "Bind1" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) + ( PropName "bind" ) + ) :| [] + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "f'" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a'" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Applicative" ) + ( Name "pure" ) + ) 0 + ) + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Effect" ) + ( Name "monadEffect" ) + ) 0 + ) + ( PropName "Applicative0" ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 + ) + ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "f'" ) ) 0 ) + ( Ref Nothing ( Local ( Name "a'" ) ) 0 ) + ) + ) + ) + ) + ) + ) + ) + ) + ), + ( PropName "Functor0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_functorEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ) + ) + ) + ] + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "main", App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Data.Maybe" ) ( Name "maybe" ) ) 0 ) + ( App Nothing + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "compose", Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "g" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "x" ) ) + ( App Nothing + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ( App Nothing + ( Ref Nothing ( Local ( Name "g" ) ) 0 ) + ( Ref Nothing ( Local ( Name "x" ) ) 0 ) + ) + ) + ) + ) + ) + ] + ) + ( PropName "compose" ) + ) + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported ( ModuleName "Effect.Exception" ) ( Name "foreign" ) ) 0 + ) + ( PropName "throwException" ) + ) + ) + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported ( ModuleName "Effect.Exception" ) ( Name "foreign" ) ) 0 + ) + ( PropName "error" ) + ) + ) + ( LiteralString Nothing "Some error" ) + ) + ) + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 ) + ) + ) + ( App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Data.Maybe" ) ( Name "maybe" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Data.Maybe" ) ( Name "Nothing" ) ) 0 ) + ) + ( Ref Nothing ( Imported ( ModuleName "Data.Maybe" ) ( Name "Just" ) ) 0 ) + ) + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "map", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "v1" ) ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Data.Maybe∷Maybe.Just" ) + ( ReflectCtor Nothing ( Ref Nothing ( Local ( Name "v1" ) ) 0 ) ) + ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Data.Maybe" ) ( Name "Just" ) ) 0 + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v1" ) ) 0 ) + ( PropName "value0" ) + ) + ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Data.Maybe" ) ( Name "Nothing" ) ) 0 + ) + ) + ) + ) + ] + ) + ( PropName "map" ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "x" ) ) + ( Ref Nothing ( Local ( Name "x" ) ) 0 ) + ) + ) + ( Ref Nothing ( Imported ( ModuleName "Data.Maybe" ) ( Name "Nothing" ) ) 0 ) + ) + ) + ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.Bug2.Test/golden.lua b/test/ps/output/Golden.Bug2.Test/golden.lua new file mode 100644 index 0000000..bd40ac9 --- /dev/null +++ b/test/ps/output/Golden.Bug2.Test/golden.lua @@ -0,0 +1,106 @@ +local function PSLUA_runtime_lazy(name) + return function(init) + return function() + local state = 0 + local val = nil + if state == 2 then + return val + else + if state == 1 then + return error(name .. " was needed before it finished initializing") + else + state = 1 + val = init() + state = 2 + return val + end + end + end + end +end +local M = {} +M.Effect_foreign = { + pureE = function(a) + return function() + return a + end + end, + bindE = function(a) + return function(f) + return function() + return f(a())() + end + end + end +} +M.Effect_Exception_foreign = { + error = function(msg) return msg end, + throwException = function(err) return function() error(err) end end +} +M.Control_Applicative_pure = function(dict) return dict.pure end +M.Data_Maybe_Nothing = { ["$ctor"] = "Data.Maybe∷Maybe.Nothing" } +M.Data_Maybe_Just = function(value0) + return { ["$ctor"] = "Data.Maybe∷Maybe.Just", value0 = value0 } +end +M.Data_Maybe_maybe = function(v, v1) + return function(v2) + if "Data.Maybe∷Maybe.Nothing" == v2["$ctor"] then + return v + else + if "Data.Maybe∷Maybe.Just" == v2["$ctor"] then + return v1(v2.value0) + else + return error("No patterns matched") + end + end + end +end +M.Effect_monadEffect = { + Applicative0 = function() return M.Effect_applicativeEffect end, + Bind1 = function() return M.Effect_bindEffect end +} +M.Effect_bindEffect = { + bind = M.Effect_foreign.bindE, + Apply0 = function() return M.Effect_Lazy_applyEffect(0) end +} +M.Effect_applicativeEffect = { + pure = M.Effect_foreign.pureE, + Apply0 = function() return M.Effect_Lazy_applyEffect(0) end +} +M.Effect_Lazy_functorEffect = PSLUA_runtime_lazy("functorEffect")(function() + return { + map = function(f) + return (M.Effect_applicativeEffect.Apply0()).apply(M.Control_Applicative_pure(M.Effect_applicativeEffect)(f)) + end + } +end) +M.Effect_Lazy_applyEffect = PSLUA_runtime_lazy("applyEffect")(function() + return { + apply = (function() + return function(f) + return function(a) + local bind = (M.Effect_monadEffect.Bind1()).bind + return bind(f)(function(fPrime) + return bind(a)(function(aPrime) + return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) + end) + end) + end + end + end)(), + Functor0 = function() return M.Effect_Lazy_functorEffect(0) end + } +end) +return { + main = M.Data_Maybe_maybe((function(f) + return function(g) return function(x) return f(g(x)) end end + end)(M.Effect_Exception_foreign.throwException)(M.Effect_Exception_foreign.error)("Some error"), M.Control_Applicative_pure(M.Effect_applicativeEffect), M.Data_Maybe_maybe(M.Data_Maybe_Nothing, M.Data_Maybe_Just, (function( v ) + return function(v1) + if "Data.Maybe∷Maybe.Just" == v1["$ctor"] then + return M.Data_Maybe_Just(v(v1.value0)) + else + return M.Data_Maybe_Nothing + end + end + end)(function(x) return x end)(M.Data_Maybe_Nothing))) +} diff --git a/test/ps/output/Golden.HelloPrelude.Test/golden.lua b/test/ps/output/Golden.HelloPrelude.Test/golden.lua index 16977dd..bb5d4af 100644 --- a/test/ps/output/Golden.HelloPrelude.Test/golden.lua +++ b/test/ps/output/Golden.HelloPrelude.Test/golden.lua @@ -57,8 +57,8 @@ M.Effect_Lazy_applyEffect = PSLUA_runtime_lazy("applyEffect")(function() return { apply = (function() return function(f) - local bind = (M.Effect_monadEffect.Bind1()).bind return function(a) + local bind = (M.Effect_monadEffect.Bind1()).bind return bind(f)(function(fPrime) return bind(a)(function(aPrime) return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) diff --git a/test/ps/output/Golden.Inline.Test/corefn.json b/test/ps/output/Golden.Inline.Test/corefn.json index 36ae11a..3105748 100644 --- a/test/ps/output/Golden.Inline.Test/corefn.json +++ b/test/ps/output/Golden.Inline.Test/corefn.json @@ -1 +1 @@ -{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[3,12],"start":[3,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[5,3]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[5,30],"start":[5,7]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[5,30],"start":[5,7]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[6,14],"start":[6,13]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"Abs"},"identifier":"x"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[7,6]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[7,34],"start":[7,11]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[7,34],"start":[7,11]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[8,18],"start":[8,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"Abs"},"identifier":"y"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[9,11],"start":[9,10]}},"type":"Var","value":{"identifier":"x","sourcePos":[5,7]}},"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,10]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,12]}},"type":"Var","value":{"identifier":"y","sourcePos":[7,11]}},"type":"App"},"type":"Let"},"type":"Let"},"identifier":"main"}],"exports":["main"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Inline","Test"],"modulePath":"golden/Golden/Inline/Test.purs","reExports":{},"sourceSpan":{"end":[9,13],"start":[1,1]}} \ No newline at end of file +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[16,32],"start":[16,1]}},"argument":"x","body":{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,1]}},"type":"Var","value":{"identifier":"x","sourcePos":[0,0]}},"type":"Abs"},"identifier":"MkMu"},{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,18],"start":[19,7]}},"binder":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[19,17],"start":[19,11]}},"binderType":"ConstructorBinder","binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,17],"start":[19,16]}},"binderType":"VarBinder","identifier":"f"}],"constructorName":{"identifier":"MkMu","moduleName":["Golden","Inline","Test"]},"typeName":{"identifier":"Mu","moduleName":["Golden","Inline","Test"]}},"binderType":"NamedBinder","identifier":"mu"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[19,22],"start":[19,21]}},"type":"Var","value":{"identifier":"f","sourcePos":[19,16]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,21]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,23]}},"type":"Var","value":{"identifier":"mu","sourcePos":[19,7]}},"type":"App"},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,1]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"runMu"},{"annotation":{"meta":null,"sourceSpan":{"end":[8,12],"start":[8,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[10,3]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[10,30],"start":[10,7]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,30],"start":[10,7]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[11,14],"start":[11,13]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"Abs"},"identifier":"x"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[12,6]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[12,34],"start":[12,11]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[12,34],"start":[12,11]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[13,18],"start":[13,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"Abs"},"identifier":"y"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[14,11],"start":[14,10]}},"type":"Var","value":{"identifier":"x","sourcePos":[10,7]}},"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[14,10]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[14,12]}},"type":"Var","value":{"identifier":"y","sourcePos":[12,11]}},"type":"App"},"type":"Let"},"type":"Let"},"identifier":"main"},{"annotation":{"meta":null,"sourceSpan":{"end":[21,14],"start":[21,1]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[22,11],"start":[22,7]}},"type":"Var","value":{"identifier":"MkMu","moduleName":["Golden","Inline","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[22,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[22,12]}},"type":"Var","value":{"identifier":"runMu","moduleName":["Golden","Inline","Test"]}},"type":"App"},"identifier":"iMu"}],"exports":["main","runMu","iMu"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[1,1]}},"moduleName":["Golden","Inline","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Inline","Test"],"modulePath":"golden/Golden/Inline/Test.purs","reExports":{},"sourceSpan":{"end":[22,17],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Inline.Test/golden.ir b/test/ps/output/Golden.Inline.Test/golden.ir index 7547681..648a313 100644 --- a/test/ps/output/Golden.Inline.Test/golden.ir +++ b/test/ps/output/Golden.Inline.Test/golden.ir @@ -1,4 +1,23 @@ UberModule - { uberModuleBindings = [], uberModuleForeigns = [], uberModuleExports = - [ ( Name "main", LiteralInt Nothing 1 ) ] + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Inline.Test", qnameName = Name "runMu" + }, Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( App Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "main", LiteralInt Nothing 1 ), + ( Name "runMu", Ref Nothing + ( Imported ( ModuleName "Golden.Inline.Test" ) ( Name "runMu" ) ) 0 + ), + ( Name "iMu", Ref Nothing + ( Imported ( ModuleName "Golden.Inline.Test" ) ( Name "runMu" ) ) 0 + ) + ] } \ No newline at end of file diff --git a/test/ps/output/Golden.Inline.Test/golden.lua b/test/ps/output/Golden.Inline.Test/golden.lua index 2764a01..9e0c091 100644 --- a/test/ps/output/Golden.Inline.Test/golden.lua +++ b/test/ps/output/Golden.Inline.Test/golden.lua @@ -1 +1,7 @@ -return { main = 1 } +local M = {} +M.Golden_Inline_Test_runMu = function(v) return v(v) end +return { + main = 1, + runMu = M.Golden_Inline_Test_runMu, + iMu = M.Golden_Inline_Test_runMu +} diff --git a/test/ps/output/Golden.NameShadowing.Test/golden.lua b/test/ps/output/Golden.NameShadowing.Test/golden.lua index 272f73a..ab048ba 100644 --- a/test/ps/output/Golden.NameShadowing.Test/golden.lua +++ b/test/ps/output/Golden.NameShadowing.Test/golden.lua @@ -1,16 +1,14 @@ local M = {} -M.Golden_NameShadowing_Test_f = function(v) - return function(v1) - if 1 == v then return 1 else if 1 == v1 then return 2 else return 3 end end - end +M.Golden_NameShadowing_Test_f = function(v, v1) + if 1 == v then return 1 else if 1 == v1 then return 2 else return 3 end end end return { b = function(x) return function(x1) - return M.Golden_NameShadowing_Test_f(M.Golden_NameShadowing_Test_f(x)(x1))(M.Golden_NameShadowing_Test_f(42)(1)) + return M.Golden_NameShadowing_Test_f(M.Golden_NameShadowing_Test_f(x, x1), M.Golden_NameShadowing_Test_f(42, 1)) end end, c = function(y) - return function(x1) return M.Golden_NameShadowing_Test_f(x1)(y) end + return function(x1) return M.Golden_NameShadowing_Test_f(x1, y) end end } diff --git a/test/ps/output/Golden.PatternMatching.Test3/corefn.json b/test/ps/output/Golden.PatternMatching.Test3/corefn.json new file mode 100644 index 0000000..529ca72 --- /dev/null +++ b/test/ps/output/Golden.PatternMatching.Test3/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[32,10],"start":[32,9]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Data","Ord"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[32,12],"start":[32,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"ordInt","moduleName":["Data","Ord"]}},"type":"App"},"identifier":"greaterThan"},{"annotation":{"meta":null,"sourceSpan":{"end":[29,39],"start":[29,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[34,9],"start":[30,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[34,9],"start":[30,9]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[31,11],"start":[31,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[31,6],"start":[31,5]}},"binderType":"VarBinder","identifier":"a"}],["b",{"annotation":{"meta":null,"sourceSpan":{"end":[31,9],"start":[31,8]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[32,17],"start":[32,16]}},"type":"Var","value":{"identifier":"a","sourcePos":[31,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[32,12],"start":[32,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[32,8],"start":[32,7]}},"type":"Var","value":{"identifier":"a","sourcePos":[31,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[32,12],"start":[32,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[32,12],"start":[32,11]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}},{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[33,17],"start":[33,16]}},"type":"Var","value":{"identifier":"b","sourcePos":[31,8]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[33,12],"start":[33,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[33,8],"start":[33,7]}},"type":"Var","value":{"identifier":"b","sourcePos":[31,8]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[33,12],"start":[33,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[33,12],"start":[33,11]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[34,4],"start":[34,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[34,9],"start":[34,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test5"},{"annotation":{"meta":null,"sourceSpan":{"end":[23,39],"start":[23,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[27,9],"start":[24,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[27,9],"start":[24,9]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[25,14],"start":[25,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[25,6],"start":[25,5]}},"binderType":"VarBinder","identifier":"a"}],["b",{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[25,11]}},"binderType":"NullBinder"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[25,27],"start":[25,26]}},"type":"Var","value":{"identifier":"a","sourcePos":[25,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,18],"start":[25,17]}},"type":"Var","value":{"identifier":"a","sourcePos":[25,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,21]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[26,14],"start":[26,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[26,9],"start":[26,8]}},"binderType":"NullBinder"}],["b",{"annotation":{"meta":null,"sourceSpan":{"end":[26,12],"start":[26,11]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[26,27],"start":[26,26]}},"type":"Var","value":{"identifier":"b","sourcePos":[26,11]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[26,22],"start":[26,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[26,18],"start":[26,17]}},"type":"Var","value":{"identifier":"b","sourcePos":[26,11]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[26,22],"start":[26,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[26,22],"start":[26,21]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[27,4],"start":[27,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[27,9],"start":[27,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test4"},{"annotation":{"meta":null,"sourceSpan":{"end":[17,39],"start":[17,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[21,9],"start":[18,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[21,9],"start":[18,9]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,14],"start":[19,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[19,6],"start":[19,5]}},"binderType":"VarBinder","identifier":"a"}],["b",{"annotation":{"meta":null,"sourceSpan":{"end":[19,12],"start":[19,11]}},"binderType":"NullBinder"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[19,27],"start":[19,26]}},"type":"Var","value":{"identifier":"a","sourcePos":[19,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,22],"start":[19,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,18],"start":[19,17]}},"type":"Var","value":{"identifier":"a","sourcePos":[19,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[19,22],"start":[19,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,22],"start":[19,21]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[20,8],"start":[20,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["b",{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[20,5]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[20,21],"start":[20,20]}},"type":"Var","value":{"identifier":"b","sourcePos":[20,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[20,16],"start":[20,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,12],"start":[20,11]}},"type":"Var","value":{"identifier":"b","sourcePos":[20,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[20,16],"start":[20,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,16],"start":[20,15]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[21,4],"start":[21,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[21,9],"start":[21,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test3"},{"annotation":{"meta":null,"sourceSpan":{"end":[11,39],"start":[11,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,9],"start":[12,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[15,9],"start":[12,9]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[13,8],"start":[13,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[13,6],"start":[13,5]}},"binderType":"VarBinder","identifier":"a"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[13,21],"start":[13,20]}},"type":"Var","value":{"identifier":"a","sourcePos":[13,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[13,16],"start":[13,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[13,12],"start":[13,11]}},"type":"Var","value":{"identifier":"a","sourcePos":[13,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[13,16],"start":[13,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[13,16],"start":[13,15]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[14,14],"start":[14,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[14,9],"start":[14,8]}},"binderType":"NullBinder"}],["b",{"annotation":{"meta":null,"sourceSpan":{"end":[14,12],"start":[14,11]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[14,27],"start":[14,26]}},"type":"Var","value":{"identifier":"b","sourcePos":[14,11]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[14,22],"start":[14,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[14,18],"start":[14,17]}},"type":"Var","value":{"identifier":"b","sourcePos":[14,11]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[14,22],"start":[14,17]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[14,22],"start":[14,21]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[15,4],"start":[15,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,9],"start":[15,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test2"},{"annotation":{"meta":null,"sourceSpan":{"end":[5,39],"start":[5,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,9],"start":[6,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[9,9],"start":[6,9]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[7,8],"start":[7,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[7,6],"start":[7,5]}},"binderType":"VarBinder","identifier":"a"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[7,21],"start":[7,20]}},"type":"Var","value":{"identifier":"a","sourcePos":[7,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[7,16],"start":[7,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,12],"start":[7,11]}},"type":"Var","value":{"identifier":"a","sourcePos":[7,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[7,16],"start":[7,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,16],"start":[7,15]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[8,8],"start":[8,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["b",{"annotation":{"meta":null,"sourceSpan":{"end":[8,6],"start":[8,5]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[8,21],"start":[8,20]}},"type":"Var","value":{"identifier":"b","sourcePos":[8,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThan","moduleName":["Golden","PatternMatching","Test3"]}},"annotation":{"meta":null,"sourceSpan":{"end":[8,16],"start":[8,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[8,12],"start":[8,11]}},"type":"Var","value":{"identifier":"b","sourcePos":[8,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[8,16],"start":[8,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[8,16],"start":[8,15]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[9,4],"start":[9,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,9],"start":[9,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test1"}],"exports":["test1","test2","test3","test4","test5"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[34,9],"start":[1,1]}},"moduleName":["Data","Ord"]},{"annotation":{"meta":null,"sourceSpan":{"end":[3,15],"start":[3,1]}},"moduleName":["Prelude"]},{"annotation":{"meta":null,"sourceSpan":{"end":[34,9],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","PatternMatching","Test3"],"modulePath":"golden/Golden/PatternMatching/Test3.purs","reExports":{},"sourceSpan":{"end":[34,9],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.PatternMatching.Test3/golden.ir b/test/ps/output/Golden.PatternMatching.Test3/golden.ir new file mode 100644 index 0000000..9d2ed7a --- /dev/null +++ b/test/ps/output/Golden.PatternMatching.Test3/golden.ir @@ -0,0 +1,324 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.PatternMatching.Test3", qnameName = Name "greaterThan" + }, Abs Nothing + ( ParamNamed Nothing ( Name "a1" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a2" ) ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Data.Ordering∷Ordering.GT" ) + ( ReflectCtor Nothing + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "compare", App Nothing + ( App Nothing + ( App Nothing + ( ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Data.Ord" ) ".spago/prelude/v7.2.0/src/Data/Ord.purs" + [ ( Nothing, Name "ordIntImpl" ) ] + ) + ( PropName "ordIntImpl" ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "LT" ) [] + ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "EQ" ) [] + ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "GT" ) [] + ) + ), + ( PropName "Eq0", Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "eq", ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Data.Eq" ) ".spago/prelude/v7.2.0/src/Data/Eq.purs" + [ ( Nothing, Name "eqIntImpl" ) ] + ) + ( PropName "eqIntImpl" ) + ) + ] + ) + ) + ] + ) + ( PropName "compare" ) + ) + ( Ref Nothing ( Local ( Name "a1" ) ) 0 ) + ) + ( Ref Nothing ( Local ( Name "a2" ) ) 0 ) + ) + ) + ) ( LiteralBool Nothing True ) ( LiteralBool Nothing False ) + ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "test1", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ), + ( Name "test2", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ), + ( Name "test3", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ), + ( Name "test4", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ), + ( Name "test5", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| + [ Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) + ] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.PatternMatching.Test3" ) + ( Name "greaterThan" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.PatternMatching.Test3/golden.lua b/test/ps/output/Golden.PatternMatching.Test3/golden.lua new file mode 100644 index 0000000..4c71212 --- /dev/null +++ b/test/ps/output/Golden.PatternMatching.Test3/golden.lua @@ -0,0 +1,96 @@ +local M = {} +M.Golden_PatternMatching_Test3_greaterThan = function(a1, a2) + if "Data.Ordering∷Ordering.GT" == ((function() + local unsafeCoerceImpl = function(lt) + return function(eq) + return function(gt) + return function(x) + return function(y) + if x < y then + return lt + elseif x == y then + return eq + else + return gt + end + end + end + end + end + end + return { ordIntImpl = unsafeCoerceImpl } + end)()).ordIntImpl({ ["$ctor"] = "Data.Ordering∷Ordering.LT" })({ + ["$ctor"] = "Data.Ordering∷Ordering.EQ" + })({ ["$ctor"] = "Data.Ordering∷Ordering.GT" })(a1)(a2)["$ctor"] then + return true + else + return false + end +end +return { + test1 = function(v) + local a = v.a + if M.Golden_PatternMatching_Test3_greaterThan(a, 0) then + return a + else + local b = v.b + if M.Golden_PatternMatching_Test3_greaterThan(b, 0) then + return b + else + return 0 + end + end + end, + test2 = function(v) + local a = v.a + if M.Golden_PatternMatching_Test3_greaterThan(a, 0) then + return a + else + local b = v.b + if M.Golden_PatternMatching_Test3_greaterThan(b, 0) then + return b + else + return 0 + end + end + end, + test3 = function(v) + local a = v.a + if M.Golden_PatternMatching_Test3_greaterThan(a, 0) then + return a + else + local b = v.b + if M.Golden_PatternMatching_Test3_greaterThan(b, 0) then + return b + else + return 0 + end + end + end, + test4 = function(v) + local a = v.a + if M.Golden_PatternMatching_Test3_greaterThan(a, 0) then + return a + else + local b = v.b + if M.Golden_PatternMatching_Test3_greaterThan(b, 0) then + return b + else + return 0 + end + end + end, + test5 = function(v) + local b = v.b + local a = v.a + if M.Golden_PatternMatching_Test3_greaterThan(a, 0) then + return a + else + if M.Golden_PatternMatching_Test3_greaterThan(b, 0) then + return b + else + return 0 + end + end + end +} diff --git a/test/ps/output/Golden.Uncurrying.Test/corefn.json b/test/ps/output/Golden.Uncurrying.Test/corefn.json new file mode 100644 index 0000000..cdc0c57 --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_j","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_k","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_l","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_m","body":{"annotation":{"meta":null,"sourceSpan":{"end":[13,36],"start":[13,35]}},"type":"Var","value":{"identifier":"i","sourcePos":[13,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst4Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"_i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"_j","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"k","body":{"annotation":{"meta":null,"sourceSpan":{"end":[19,30],"start":[19,29]}},"type":"Var","value":{"identifier":"k","sourcePos":[19,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst3Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"_b","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"_c","body":{"annotation":{"meta":null,"sourceSpan":{"end":[4,30],"start":[4,29]}},"type":"Var","value":{"identifier":"i","sourcePos":[4,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst2Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[21,36],"start":[21,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[22,28],"start":[22,11]}},"type":"Var","value":{"identifier":"uncurryFirst3Args","moduleName":["Golden","Uncurrying","Test"]}},"identifier":"synonym"},{"annotation":{"meta":null,"sourceSpan":{"end":[24,20],"start":[24,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[24,20],"start":[24,1]}},"argument":"i","body":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[25,18],"start":[25,11]}},"type":"Var","value":{"identifier":"synonym","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[25,20],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,20],"start":[25,19]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,21]}},"type":"Var","value":{"identifier":"i","sourcePos":[25,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[25,23]}},"type":"Literal","value":{"literalType":"IntLiteral","value":3}},"type":"App"},"type":"Abs"},"identifier":"call5"},{"annotation":{"meta":null,"sourceSpan":{"end":[15,20],"start":[15,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[16,26],"start":[16,9]}},"type":"Var","value":{"identifier":"uncurryFirst4Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,30],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,30],"start":[16,29]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,31]}},"type":"Literal","value":{"literalType":"IntLiteral","value":3}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,48],"start":[16,9]}},"argument":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[16,41],"start":[16,34]}},"type":"Var","value":{"identifier":"synonym","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[16,43],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,43],"start":[16,42]}},"type":"Literal","value":{"literalType":"IntLiteral","value":4}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,45],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,45],"start":[16,44]}},"type":"Literal","value":{"literalType":"IntLiteral","value":5}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,47],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,47],"start":[16,46]}},"type":"Literal","value":{"literalType":"IntLiteral","value":6}},"type":"App"},"type":"App"},"identifier":"call4"},{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[10,26],"start":[10,9]}},"type":"Var","value":{"identifier":"uncurryFirst2Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[10,28],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,28],"start":[10,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[10,34],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,34],"start":[10,29]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":false}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[10,38],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,38],"start":[10,35]}},"type":"Literal","value":{"literalType":"CharLiteral","value":"a"}},"type":"App"},"identifier":"call3"},{"annotation":{"meta":null,"sourceSpan":{"end":[6,21],"start":[6,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[7,26],"start":[7,9]}},"type":"Var","value":{"identifier":"uncurryFirst2Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[7,28],"start":[7,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,28],"start":[7,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[7,33],"start":[7,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,33],"start":[7,29]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":true}},"type":"App"},"identifier":"call2"}],"exports":["call2","call3","call4","call5"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[1,1]}},"moduleName":["Golden","Uncurrying","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Uncurrying","Test"],"modulePath":"golden/Golden/Uncurrying/Test.purs","reExports":{},"sourceSpan":{"end":[25,24],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test/golden.ir b/test/ps/output/Golden.Uncurrying.Test/golden.ir new file mode 100644 index 0000000..1ddae8a --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/golden.ir @@ -0,0 +1,36 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Uncurrying.Test", qnameName = Name "uncurryFirst2Args" + }, Abs Nothing + ( ParamNamed Nothing ( Name "i" ) ) + ( Abs Nothing ( ParamUnused Nothing ) + ( Abs Nothing ( ParamUnused Nothing ) ( Ref Nothing ( Local ( Name "i" ) ) 0 ) ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "call2", App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test" ) ( Name "uncurryFirst2Args" ) ) 0 + ) + ( LiteralInt Nothing 1 ) + ) ( LiteralBool Nothing True ) + ), + ( Name "call3", App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test" ) ( Name "uncurryFirst2Args" ) ) 0 + ) + ( LiteralInt Nothing 2 ) + ) ( LiteralBool Nothing False ) + ) + ( LiteralChar Nothing 'a' ) + ), + ( Name "call4", Abs Nothing ( ParamUnused Nothing ) ( LiteralInt Nothing 1 ) ), + ( Name "call5", Abs Nothing ( ParamUnused Nothing ) ( LiteralInt Nothing 3 ) ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test/golden.lua b/test/ps/output/Golden.Uncurrying.Test/golden.lua new file mode 100644 index 0000000..d3f2c1d --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/golden.lua @@ -0,0 +1,10 @@ +local M = {} +M.Golden_Uncurrying_Test_uncurryFirst2Args = function(i) + return function() return i end +end +return { + call2 = M.Golden_Uncurrying_Test_uncurryFirst2Args(1, true), + call3 = M.Golden_Uncurrying_Test_uncurryFirst2Args(2, false)("a"), + call4 = function() return 1 end, + call5 = function() return 3 end +} diff --git a/test/ps/output/Golden.Uncurrying.Test2/corefn.json b/test/ps/output/Golden.Uncurrying.Test2/corefn.json new file mode 100644 index 0000000..0e36819 --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test2/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[3,35],"start":[3,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[3,35],"start":[3,1]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,35],"start":[3,1]}},"argument":"v1","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,35],"start":[3,1]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[4,12],"start":[4,11]}},"binderType":"LiteralBinder","literal":{"literalType":"IntLiteral","value":1}},{"annotation":{"meta":null,"sourceSpan":{"end":[4,14],"start":[4,13]}},"binderType":"LiteralBinder","literal":{"literalType":"IntLiteral","value":1}}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[4,21],"start":[4,17]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":true}},"isGuarded":false},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[5,12],"start":[5,11]}},"binderType":"NullBinder"},{"annotation":{"meta":null,"sourceSpan":{"end":[5,14],"start":[5,13]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[5,22],"start":[5,17]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":false}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[4,21],"start":[4,1]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},{"annotation":{"meta":null,"sourceSpan":{"end":[4,21],"start":[4,1]}},"type":"Var","value":{"identifier":"v1","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"type":"Abs"},"identifier":"uncurried"},{"annotation":{"meta":null,"sourceSpan":{"end":[7,38],"start":[7,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[11,9],"start":[8,8]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[11,9],"start":[8,8]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[9,8],"start":[9,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["a",{"annotation":{"meta":null,"sourceSpan":{"end":[9,6],"start":[9,5]}},"binderType":"VarBinder","identifier":"a"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,29],"start":[9,28]}},"type":"Var","value":{"identifier":"a","sourcePos":[9,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[9,20],"start":[9,11]}},"type":"Var","value":{"identifier":"uncurried","moduleName":["Golden","Uncurrying","Test2"]}},"annotation":{"meta":null,"sourceSpan":{"end":[9,22],"start":[9,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[9,22],"start":[9,21]}},"type":"Var","value":{"identifier":"a","sourcePos":[9,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[9,24],"start":[9,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[9,24],"start":[9,23]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[10,8],"start":[10,3]}},"binderType":"LiteralBinder","literal":{"literalType":"ObjectLiteral","value":[["b",{"annotation":{"meta":null,"sourceSpan":{"end":[10,6],"start":[10,5]}},"binderType":"VarBinder","identifier":"b"}]]}}],"expressions":[{"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,29],"start":[10,28]}},"type":"Var","value":{"identifier":"b","sourcePos":[10,5]}},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[10,20],"start":[10,11]}},"type":"Var","value":{"identifier":"uncurried","moduleName":["Golden","Uncurrying","Test2"]}},"annotation":{"meta":null,"sourceSpan":{"end":[10,22],"start":[10,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,22],"start":[10,21]}},"type":"Var","value":{"identifier":"b","sourcePos":[10,5]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[10,24],"start":[10,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,24],"start":[10,23]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"}}],"isGuarded":true},{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"binderType":"NullBinder"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[11,9],"start":[11,8]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"test"}],"exports":["test"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[11,9],"start":[1,1]}},"moduleName":["Golden","Uncurrying","Test2"]},{"annotation":{"meta":null,"sourceSpan":{"end":[11,9],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Uncurrying","Test2"],"modulePath":"golden/Golden/Uncurrying/Test2.purs","reExports":{},"sourceSpan":{"end":[11,9],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test2/golden.ir b/test/ps/output/Golden.Uncurrying.Test2/golden.ir new file mode 100644 index 0000000..39c9cff --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test2/golden.ir @@ -0,0 +1,59 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Uncurrying.Test2", qnameName = Name "f2" + }, Abs Nothing ( ParamUnused Nothing ) + ( Abs Nothing ( ParamUnused Nothing ) ( LiteralBool Nothing True ) ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "f2", Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test2" ) ( Name "f2" ) ) 0 + ), + ( Name "test1", Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "a", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "a" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test2" ) ( Name "f2" ) ) 0 + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ( Let Nothing + ( Standalone + ( Nothing, Name "b", ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "b" ) + ) :| [] + ) + ( IfThenElse Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test2" ) ( Name "f2" ) ) 0 + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ) + ( LiteralInt Nothing 0 ) + ) + ( Ref Nothing ( Local ( Name "b" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ) + ) + ) + ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test2/golden.lua b/test/ps/output/Golden.Uncurrying.Test2/golden.lua new file mode 100644 index 0000000..89eb4ca --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test2/golden.lua @@ -0,0 +1,23 @@ +local M = {} +M.Golden_Uncurrying_Test2_uncurried = function(v, v1) + if 1 == v then + if 1 == v1 then return true else return false end + else + return false + end +end +return { + test = function(v) + local a = v.a + if M.Golden_Uncurrying_Test2_uncurried(a, 0) then + return a + else + local b = v.b + if M.Golden_Uncurrying_Test2_uncurried(b, 0) then + return b + else + return 0 + end + end + end +} diff --git a/test/ps/spago.dhall b/test/ps/spago.dhall index d7992f0..5419b56 100644 --- a/test/ps/spago.dhall +++ b/test/ps/spago.dhall @@ -1,5 +1,5 @@ { name = "test-project" -, dependencies = [ "console", "effect", "foldable-traversable", "prelude" ] +, dependencies = [ "console", "effect", "foldable-traversable", "prelude", "exceptions", "maybe" ] , packages = ./packages.dhall , sources = [ "golden/**/*.purs" ] }