From bff2fd81eead5e205fa88232a0c4d3ff580bf492 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Mon, 1 Nov 2021 20:46:42 +0900 Subject: [PATCH 01/13] diana --- .gitignore | 6 +- .travis.yml | 89 --- ChangeLog.md | 49 -- FFITestsSummary.md | 52 -- Impl.md | 208 ------ Interops.md | 96 --- LICENSE | 2 +- README.md | 85 +-- app/Main.hs | 108 +-- ci-passing.sh | 11 - env.sh | 2 + impurescript-diana.cabal | 168 +++++ install.sh | 7 + package.yaml | 15 +- passing/packages.dhall | 128 ---- passing/pure-py.json | 8 - passing/python-ffi/Global.py | 97 --- passing/python-ffi/Global/Unsafe.py | 45 -- passing/python-ffi/PythonInterop.py | 25 - passing/python-ffi/Test/Globals.py | 1 - passing/python-ffi/Test/PyUtil.py | 19 - passing/spago.dhall | 36 - passing/src/PythonInterop.js | 12 - passing/src/PythonInterop.purs | 24 - passing/src/Test | 0 passing/src/TestCases/Datatypes.purs | 58 -- passing/src/TestCases/PatternMatching.purs | 50 -- passing/src/TestCases/Records.purs | 23 - passing/test/Arrays/Arrays.purs | 19 - passing/test/Arrays/Data/Array/Array.purs | 414 ----------- passing/test/Arrays/Data/Array/NonEmpty.purs | 314 --------- passing/test/Arrays/Data/Array/Partial.purs | 26 - passing/test/Arrays/Data/Array/ST.purs | 276 -------- .../test/Arrays/Data/Array/ST/Partial.purs | 25 - passing/test/Global.Unsafe.purs | 41 -- passing/test/Global.purs | 93 --- passing/test/Globals.purs | 92 --- passing/test/Int.purs | 182 ----- passing/test/Main.purs | 41 -- passing/test/OrderedCollections/Data/Map.purs | 452 ------------ passing/test/OrderedCollections/Data/Set.purs | 30 - .../OrderedCollections.purs | 14 - passing/test/PyUtil/PyUtil.purs | 8 - passing/test/QuickCheck.purs | 93 --- passing/test/Record.purs | 84 --- passing/test/ST.purs | 23 - passing/test/String/Test/Data/String.purs | 141 ---- .../Test/Data/String/CaseInsensitive.purs | 22 - .../String/Test/Data/String/CodePoints.purs | 645 ------------------ .../String/Test/Data/String/CodeUnits.purs | 461 ------------- .../String/Test/Data/String/NonEmpty.purs | 220 ------ .../Test/Data/String/NonEmpty/CodeUnits.purs | 450 ------------ .../test/String/Test/Data/String/Regex.purs | 56 -- .../test/String/Test/Data/String/Unsafe.purs | 26 - passing/test/String/Test/Main.purs | 32 - passing/test/Unfoldable.purs | 69 -- passing/test/UnsafeCoerce.purs | 29 - .../PureScript/CodeGen/{Py.hs => Diana.hs} | 92 ++- .../PureScript/CodeGen/Diana/Common.hs | 96 +++ .../PureScript/CodeGen/{Py => Diana}/Eval.hs | 76 +-- .../PureScript/CodeGen/Diana/Naming.hs | 18 + .../PureScript/CodeGen/Diana/Serializer.hs | 189 +++++ src/Language/PureScript/CodeGen/Py/Common.hs | 59 -- src/Language/PureScript/CodeGen/Py/Naming.hs | 13 - .../PureScript/CodeGen/Py/Serializer.hs | 162 ----- src/Topdown/Core.hs | 14 - src/Topdown/Pretty.hs | 18 - src/Topdown/Raw.hs | 23 - src/Topdown/Topdown.hs | 63 -- test/Spec.hs | 13 - travis-env.sh | 6 - 71 files changed, 600 insertions(+), 6044 deletions(-) delete mode 100644 .travis.yml delete mode 100644 FFITestsSummary.md delete mode 100644 Impl.md delete mode 100644 Interops.md delete mode 100644 ci-passing.sh create mode 100644 env.sh create mode 100644 impurescript-diana.cabal create mode 100644 install.sh delete mode 100644 passing/packages.dhall delete mode 100644 passing/pure-py.json delete mode 100644 passing/python-ffi/Global.py delete mode 100644 passing/python-ffi/Global/Unsafe.py delete mode 100644 passing/python-ffi/PythonInterop.py delete mode 100644 passing/python-ffi/Test/Globals.py delete mode 100644 passing/python-ffi/Test/PyUtil.py delete mode 100644 passing/spago.dhall delete mode 100644 passing/src/PythonInterop.js delete mode 100644 passing/src/PythonInterop.purs delete mode 100644 passing/src/Test delete mode 100644 passing/src/TestCases/Datatypes.purs delete mode 100644 passing/src/TestCases/PatternMatching.purs delete mode 100644 passing/src/TestCases/Records.purs delete mode 100644 passing/test/Arrays/Arrays.purs delete mode 100644 passing/test/Arrays/Data/Array/Array.purs delete mode 100644 passing/test/Arrays/Data/Array/NonEmpty.purs delete mode 100644 passing/test/Arrays/Data/Array/Partial.purs delete mode 100644 passing/test/Arrays/Data/Array/ST.purs delete mode 100644 passing/test/Arrays/Data/Array/ST/Partial.purs delete mode 100644 passing/test/Global.Unsafe.purs delete mode 100644 passing/test/Global.purs delete mode 100644 passing/test/Globals.purs delete mode 100644 passing/test/Int.purs delete mode 100644 passing/test/Main.purs delete mode 100644 passing/test/OrderedCollections/Data/Map.purs delete mode 100644 passing/test/OrderedCollections/Data/Set.purs delete mode 100644 passing/test/OrderedCollections/OrderedCollections.purs delete mode 100644 passing/test/PyUtil/PyUtil.purs delete mode 100644 passing/test/QuickCheck.purs delete mode 100644 passing/test/Record.purs delete mode 100644 passing/test/ST.purs delete mode 100644 passing/test/String/Test/Data/String.purs delete mode 100644 passing/test/String/Test/Data/String/CaseInsensitive.purs delete mode 100644 passing/test/String/Test/Data/String/CodePoints.purs delete mode 100644 passing/test/String/Test/Data/String/CodeUnits.purs delete mode 100644 passing/test/String/Test/Data/String/NonEmpty.purs delete mode 100644 passing/test/String/Test/Data/String/NonEmpty/CodeUnits.purs delete mode 100644 passing/test/String/Test/Data/String/Regex.purs delete mode 100644 passing/test/String/Test/Data/String/Unsafe.purs delete mode 100644 passing/test/String/Test/Main.purs delete mode 100644 passing/test/Unfoldable.purs delete mode 100644 passing/test/UnsafeCoerce.purs rename src/Language/PureScript/CodeGen/{Py.hs => Diana.hs} (89%) create mode 100644 src/Language/PureScript/CodeGen/Diana/Common.hs rename src/Language/PureScript/CodeGen/{Py => Diana}/Eval.hs (67%) create mode 100644 src/Language/PureScript/CodeGen/Diana/Naming.hs create mode 100644 src/Language/PureScript/CodeGen/Diana/Serializer.hs delete mode 100644 src/Language/PureScript/CodeGen/Py/Common.hs delete mode 100644 src/Language/PureScript/CodeGen/Py/Naming.hs delete mode 100644 src/Language/PureScript/CodeGen/Py/Serializer.hs delete mode 100644 src/Topdown/Core.hs delete mode 100644 src/Topdown/Pretty.hs delete mode 100644 src/Topdown/Raw.hs delete mode 100644 src/Topdown/Topdown.hs delete mode 100644 test/Spec.hs delete mode 100644 travis-env.sh diff --git a/.gitignore b/.gitignore index 8278dee..68fc12d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,17 +1,21 @@ .stack-work/ purescript-python.cabal +impurescript-psdiana.cabal +psdiana + *~ .idea/ stack.yaml.lock # for making statically built libs pspy-blueprint-*.zip +psdiana-*.zip + .DS_Store stack.yaml.lock .DS_Store pspy-blueprint .psc-ide-port output/ - # purescript passing/bower_components/ passing/node_modules/ diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 3cce06c..0000000 --- a/.travis.yml +++ /dev/null @@ -1,89 +0,0 @@ -# This is the complex Travis configuration, which is intended for use -# on open source libraries which need compatibility across multiple GHC -# versions, must work with cabal-install, and should be -# cross-platform. For more information and other options, see: -# -# https://docs.haskellstack.org/en/stable/travis_ci/ -# -# Copy these contents into the root directory of your Github project in a file -# named .travis.yml - -# Run jobs on Linux unless "os" is specified explicitly. -os: linux - -# Do not choose a language; we provide our own build tools. -language: generic - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.ghc - - $HOME/.cabal - - $HOME/.stack - -jobs: - include: - - env: BUILD=stack ARGS="--resolver lts-13.26" - compiler: ": #stack 8.6.5" - addons: {apt: {packages: [libgmp-dev]}} - python: 3.7 - - # Travis includes an macOS which is incompatible with GHC 7.8.4 - #- env: BUILD=stack ARGS="--resolver lts-2" - - - env: BUILD=stack ARGS="--resolver lts-13.26" - compiler: ": #stack 8.6.5 osx" - os: osx - python: 3.7 - - - allow_failures: - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - - env: BUILD=stack ARGS="--resolver nightly" - -before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH -- mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - -script: -- | - set -ex - stack --no-terminal build - stack --no-terminal install - set +ex - - -before_deploy: - - source ./travis-env.sh - - bash ./ci-passing.sh - - git tag $RELEASE_TAG - -deploy: - provider: releases - api_key: $GITHUB_TOKEN - file: $ZIP_FILE - skip_cleanup: true - draft: true - -after_deploy: - - ./pspy-blueprint || echo "done" \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md index 284eb35..e69de29 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,49 +0,0 @@ -# Changelog for purescript-python - -2020-06-13: Version 0.1.3.0 - -- one-liner installation! -- change license to MIT #20 -- update codebase to PureScript v0.13.8 #22 -- fix namespace issues of `getitem_looper` and `getattr_looper` - -2020-03-05: Version 0.1.2.0 ---------------------------------- - -- codegen support for JavaScript-specific behaviors: add default value `None` for each function argument. fix #10 -- faster codegen: avoid pretty print when not specified. #13 -- lighter volume: for generated files. type level computing can produce huge amount of code, to make generated code Git maintainable, we use bzip2 to compress stuffs. #13 -- options for pspy-blueprint changed(`--py-dir --entry-mod --ffi-dep --out-format [Pretty|Compact|Compressed]`). -- special optimization for repeating indexing and attribute accessing. -- the `topdown` file format to allow Python to load large scale code, and load code faster. fix #13 -- tagless final approach to support multiple data formats of output IR for codegen, - check `Topdown/{Raw.hs, Topdown.hs, Pretty.hs}.`. -- add CI tests based on a purescript-python project. #15 - - - -2020-02-24: Version 0.1.1.0 --------------------------------------- - - -- Fix multi-param datatype constructors -- Fix throwing exceptions -- Fix the use of some JS specific features in CodeGen: - - PS codegen uses JS tricks like `"a" + ["b", "c"] == "ab,c"`, - we change the generated code like `throw new Error("a" + ["b", "c"])` - to `throw Error("a" + ",".join(["b", "c"]))`. - - \*Further optimizations can be done later. - - - -2020-02-22: Version 0.1.0.0 -------------------------------------------------- - -- Statically linked Linux executable under License LGPL - -2020-02-21: Version 0.1.0.0a(Preview) -------------------------------------------------- - -- A preview release has finally come. diff --git a/FFITestsSummary.md b/FFITestsSummary.md deleted file mode 100644 index 2930006..0000000 --- a/FFITestsSummary.md +++ /dev/null @@ -1,52 +0,0 @@ -# Purescript JS FFI transfer and test summary - -## purescript-strings - -tests : `purescript-python/passing/test/String` - -note tests for `Data.String.CodePoints` and `Data.String.Regex` is skipped. - -FFI for these to modules is not finished yet. - -## purescript-globals - -tests : `purescript-python/passing/test/Globals.purs` - -FFI for function `toPrescision`, `decodeURI` and `encodeURI` is not finished yet, thus tests for these functions is skipped. - -## modules without tests - -There is no tests for the following packages in their repos, thus no test for FFI of the following packages. - -- `purescript-math` -- `purescript-random` -- `purescript-lazy` -- `purescript-assert` -- `purescript-functions` -- `purescript-exceptions` (TODO: verify implementation manually due to differences between Python `Exception`s and JS `Error`s) -- `purescript-effect` -- `purescript-console` - -## packages with tests but not added to purescript-python/passing yet - -- `purescript-enums` -- `purescript-prelude` -- `purescript-control` -- `purescript-foldable-traversable` -- `purescript-partial` -- `purescript-nullable` -- `purescript-refs` - -## packages with FFI and tests - -- `purescript-arrays` -- `purescript-integers` -- `purescript-quickcheck` -- `purescript-record` -- `purescript-st` -- `purescript-unfoldable` -- `purescript-unsafe-coerce` - -## purescript-python only packages - -- `purescript-show-python` \ No newline at end of file diff --git a/Impl.md b/Impl.md deleted file mode 100644 index 5621017..0000000 --- a/Impl.md +++ /dev/null @@ -1,208 +0,0 @@ -# purescript-python - - -## Motivation - -PureScript(especially PureScript-python) for what? -- Simple and intuitive Python interop --
- Advanced type system - - - higher kinded types - - higer rank types - - functional dependencies - - extensible records - - data kinds - - etc.. - - - This is an extreme of being pragmatic, and makes decoupling and composition easier. - -
--
Excellent IDE, better type-driven programming experience, less of mental burden. - - You understand what does - "implicit type inference + auto-completion + real-time error highlighting + type constraints by advanced type system" mean? - -
- -- Multiple back ends: JavaScript, Go/C++, Python, Kotlin, etc. - -## Status - -Currently many purescript libraries are supported, like -- prelude -- generics-rep(for `deriving` type classes like `Show`, `Generic`, etc.) -- console -- effect -- enums -- controls -- partial -- etc. - -purescript-python has grown up to some degree with pretty nice availability. - -## Python Package Generation Specification - -Generating PySExpr -------------------------- - -After slightly modifying a JavaScript-like IR produced by the builtin compiler, -PureScript gets compiled to [`PySExpr`](https://github.com/thautwarm/PySExpr) and **shall work since Python 3.5**. - -The reason why we generate the IR `PySExpr` instead of Python source code, -is for getting better cross-Python-version compatibility, Python-version-specific optimizations, -**source code positioning for using existing Python debuggers in PureScript**, and expression-first expressiveness. You could check out [this reddit post](https://www.reddit.com/r/ProgrammingLanguages/comments/f41odv/a_compiler_back_end_by_which_you_write) for more details. - - -Directory Tree of Generated Package ---------------------------------------------- - - -Given a PureScript module, not losing the generality, we abbreviate it as `A.B`. - -After processing this module via the command - -```shell -# `output` is the directory produced by the PureScript build tool `spago`. -pspy-blueprint --out-python aaa/bbb/output_top_dir --corefn-entry A.B --out-ffi-dep ffi-requires.txt -``` - -Command `pspy-blueprint` generates following directory tree(all `__init__.py` will be added later, but not in Haskell side): - -``` -- aaa/bbb/output_top_dir - - A - - B - - pure.py - - pure.zip.py - - (optional) pure.raw.py - - - ffi -- ffi-requires.txt # lines of paths from which FFI files are required -``` - -`pure.raw.py` or `pure.zip.py` Generated for Each Module ------------------------------------------------ - -This Python module creates Python code/bytecode object. - -In CPython, every Python file will be compiled to a Python code object, which will finally be executed in -CPython virtual machine. - -In the earlier design, we create the code object in `pure.raw.py`, -but don't execute it, for achieving the further flexibility of caching and composition of our compilation. - -Unfortunately, due to the heavy code generation by PureScript's type-level computation, the generated `pure.raw.py` can be always very huge and cause a `MemoryError` when you want to import it as a python module. - -To address this, we come up with a data file format [topdown](https://github.com/purescript-python/purescript-python/blob/master/src/Topdown/Topdown.hs) and use it to generate `pure.zip.py`, which is actually a `zip` file and shall be regarded as a compressed version of `pure.raw.py`, but also parse faster than a regular Python module. Sometimes, `pure.raw.py` can be more than 300MB, -which certainly crash any `python` executable, but equivalent `pure.zip.py` can be only 50KB, with orders-of-magnitude speed up on parsing. - - - -`pure.py` Generated for Each Module ----------------------------------------------- - -This is, actually the loader for corresponding `pure.zip.py`/`pure.raw.py`. - -This module implements the concrete code caching system which avoids the redundant Python source code to bytecode compilation, and finally greatly reduce the module loading time. - -Hence, a PureScript module `A.B` compiled by PureScript-Python -will be able to imported by the statement `import output_top_dir.A.B.pure`. - -The code of `pure.py`, corresponding to a PureScript module, is fixed to be - -```python -from purescripto import LoadPureScript -__py__ = globals() -__ps__ = LoadPureScript(__file__, __name__) -__all__ = list(__ps__) -__py__.update(__ps__) -``` - -which relies on the Python package `purescripto`. - -The Python package `purescripto` provides a common RTS and supplements all required functionalities for being a full featured PureScript backend. - - diff --git a/Interops.md b/Interops.md deleted file mode 100644 index accaece..0000000 --- a/Interops.md +++ /dev/null @@ -1,96 +0,0 @@ - -# Interops: PureScript <-> Python - -You expect this is a large document? No, it's quite short: -1. `spago build` -2. py call ps: `python -c "from .Main.pure import main;main()"` -3. ps call py: `foreign import : `. - -You can extract the generated Python package out, and encapsulate it as a standalone Python package, and upload to PyPI. - - -## Calling PureScript From Python - -### Module Path - - -Moreover, given such a PS module `A.B`: - -```purescript -module A.B(export1, export2) where -... -``` - -In Python, you can import `export1` by - -```python -import .A.B.pure as AB -AB.export1 # you got it -``` - -### Calling Convention - -This is also a reason why PureScript is pragmatic, -because it uses the same calling convention as Python's. - -It supports tail call optimizations, e.g., a purescript function like - -```purescript -f x y = x + y -``` - -can be used in Python in this way: - -```python -assert f(1)(2) == 3 -``` - - -### Object Representation - - -| Case | Given Definition | PureScript | Python | -|----------|------------------------------------|---------------------------|---------------------------------------------------------------------------------------| -| Datatype | `data S = S1 Int Number \| S2 Text` | `[S1 1 2.0, S2 "hello!"]` | `({"value0": 1, "value1": 2.0, ".t": S1}, {"value0": "hello!", ".t": S2})` | -| Newtype | `newtype A = A Int` | `A 1` | `1` | -| Record | No definition | `{a: 1, b: 2}` | `{"a": 1, "b": 2}` | - - - -## Calling Python From PureScript - -For each project, -if your project directory tree is - -``` -- src - - Main.purs - - Mod - - A.purs -``` - -If you have foreign definitions in module `Mod.A`, such as in `src/Mod/A.purs`: - -```purescript -module Mod.A where -foreign import add233 : Int -> Int -``` - -then you need to create a directory `python-ffi` juxtaposing `src`, and it'll finally look like: - -``` -- python-ffi - - Mod - - A.py -- src - - Main.purs - - Mod - - A.purs -``` - -In `python-ffi/Mod/A.py`: - -```python -def add233(x): - return x + 233 -``` \ No newline at end of file diff --git a/LICENSE b/LICENSE index d9763a5..18c3c4c 100644 --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ The MIT License (MIT) -Copyright (c) 2020 thautwarm +Copyright (c) 2021 thautwarm Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md index fcb701b..88a0b61 100644 --- a/README.md +++ b/README.md @@ -1,85 +1,2 @@ - -# PureScript to Python Compiler - -[![Build Status](https://travis-ci.com/thautwarm/purescript-python.svg?branch=master)](https://travis-ci.com/thautwarm/purescript-python) [![gitter room](https://img.shields.io/badge/chat-tagful initial-Pink.svg?style=flat)](https://gitter.im/reliable-python/community) [![install](https://img.shields.io/badge/install-oneliner-blue.svg?style=flat)](https://github.com/purescript-python/installer/) [![py interop](https://img.shields.io/badge/interop-purescriptโ†”python-teal.svg?style=flat)](./Interops.md) - -- [Specification and Implementation](./Impl.md) -- [Example Project](https://github.com/purescript-python/example-hw) - -## Get Started - -0. \*Install a CPython distribution. - - If you're already a user of CPython, you can skip this step. - - Otherwise, go to [this official download](https://www.python.org/downloads/) page, - download and install any valid distribution(`>=3.5`). - - -1. Install [nodejs](https://nodejs.org/en/), which is distributed with a command `npm`, and use `npm` to install `purescript` and its package manager `spago`: - ```bash - npm install -g purescript - npm install -g spago - ``` - You might check [PureScript: Getting Started](https://github.com/purescript/documentation/blob/master/guides/Getting-Started.md) for more details. - -2. Install PureScript-Python components: - - `curl -fsSL https://raw.githubusercontent.com/purescript-python/installer/master/install.sh | bash` - -3. Create an empty folder called `hello-world` somewhere appropriate,get in, and call - ``` - spago init # init purescript project - pspy --init # init purescript-python local configuration - ``` - -4. Add a key `backend` with value `"pspy"`, to file `spago.dhall` of your `hello-world` project. This is an example: - - ```dhall - {- - Welcome to a Spago project! - You can edit this file as you like. - -} - { name = "my-project" - , dependencies = [ "console", "effect", "psci-support" ] - , packages = ./packages.dhall - , sources = [ "src/**/*.purs", "test/**/*.purs" ] - , backend = "pspy" -- !!NOTE THIS!! - } - ``` - -5. Write your code in `src/**.purs`, and use `spago run` to execute your project(the default entry module is `Main`). - - -## PureScript Learning Materials - -PureScript is close to Haskell, hence a Haskell user can pick it up in few seconds. - -The home of PureScript is [PureScript.org](http://www.purescript.org/), where you can find things involving documentations. - - -## HOW-TO: IDE Support - -A major motivation for my working on PureScript is its lightweighted but awesome IDE support. - -For VSCode users, installing the plugin `PureScript IDE` and `File -> Preferences -> Settings -> (search purescript) -> Turn on "Add Spago sources"` will be sufficient. **No need to install some GitHub repo and build for 4 hours! And this IDE feels swift!** - -## Troubleshoot `pspy-blueprint` - -If `pspy-blueprint` provided by the Python package `purescripto` didn't work(e.g., users of MacOSX < 10.15), you should manually install it from this repository, and currently there're 2 options: - -1. Install from [GitHub release page](https://github.com/purescript-python/purescript-python/releases). -2. Install from source(Need Haskell [stack](https://docs.haskellstack.org/en/stable/README)): clone this repo, and use command `stack install .`, which will install `pspy-blueprint` to your `.local` PATH. - -For Linux users, you might also need to use `chmod u+x ` to allow the permission to execute. - -## Troubleshoot: Execution Not Sync to Latest Code - -This seems to be a recent issue produced by the upstream compiler, and you can resolve this by removing the current `output` directory: - -```bash -rm -rf $YOUR_PROJECT_ROOT/output && spago build && pspy --run -``` - -This will produce the result of your latest code. +# ImpureScript for Diana: Type-safe Scripting for Unity diff --git a/app/Main.hs b/app/Main.hs index ecd46dc..a32395a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,6 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T +import qualified Data.Map as M import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Encoding as L @@ -39,9 +40,9 @@ import Language.PureScript.Names ( moduleNameFromString , isBuiltinModuleName ) -import Language.PureScript.CodeGen.Py (moduleToJS) -import Language.PureScript.CodeGen.Py.Serializer () -import Language.PureScript.CodeGen.Py.Eval (finally, EvalJS) +import Language.PureScript.CodeGen.Diana (moduleToJS) +import Language.PureScript.CodeGen.Diana.Serializer +import Language.PureScript.CodeGen.Diana.Eval (finally, EvalJS) import Control.Monad.Supply import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) @@ -52,11 +53,10 @@ import Control.Monad.Reader (MonadReader(..)) import qualified Control.Monad.State as State import Monads.STEither -import Topdown.Pretty (PrettyTopdown) -import Topdown.Raw () -import Topdown.Topdown (serialize) import Codec.Archive.Zip import StringEscape (escape) +import Control.Monad.State (State) +import Language.PureScript.CodeGen.Diana.Serializer (runDoc) instance MonadReader Options (STEither Options MultipleErrors) where ask = STEither State.get @@ -71,41 +71,31 @@ defaultOpts = main :: IO () main = do - opts <- getArgs - case opts of - [ "--py-dir" - , baseOutDir - , "--entry-mod" - , moduleParts - , "--ffi-dep" - , ffiDepPath - , "--out-format" - , outFormat] -> do - ffiDeps <- - fixPointCG - (read outFormat) - baseOutDir - S.empty - (S.empty, [moduleNameFromString $ T.pack moduleParts]) - T.writeFile ffiDepPath (T.unlines $ map T.pack ffiDeps) - _ -> - putStrLn - "Malformed options, expect form --py-dir --entry-mod --ffi-dep --out-format [Pretty|Compact|Compressed]." >> exitFailure - -data OutFormat = Pretty | Compact | Compressed deriving (Read) + let baseOutDir = "output" + let ffiDepPath = "ffi-deps" + let moduleParts = "Main" + + ffiDeps <- do + + fixPointCG + baseOutDir + S.empty + (S.empty, [moduleNameFromString $ T.pack moduleParts]) + + T.writeFile ffiDepPath (T.unlines $ map T.pack ffiDeps) + -- code generation for used modules -fixPointCG :: OutFormat -> FilePath -> S.Set FilePath -> (S.Set P.ModuleName, [P.ModuleName]) -> IO [FilePath] -fixPointCG outFormat baseOutDir ffiPathReferred (importedModules, moduleImportDeque) = +fixPointCG :: FilePath -> S.Set FilePath -> (S.Set P.ModuleName, [P.ModuleName]) -> IO [FilePath] +fixPointCG baseOutDir ffiPathReferred (importedModules, moduleImportDeque) = case moduleImportDeque of [] -> return $ S.toList ffiPathReferred m:ms | m `S.member` importedModules || isBuiltinModuleName m -> - fixPointCG outFormat baseOutDir ffiPathReferred (importedModules, ms) + fixPointCG baseOutDir ffiPathReferred (importedModules, ms) | otherwise -> do - (newModsToImport, newFFIReferred) <- cg outFormat baseOutDir m + (newModsToImport, newFFIReferred) <- cg baseOutDir m fixPointCG - outFormat baseOutDir (S.union ffiPathReferred newFFIReferred) (S.insert m importedModules, newModsToImport ++ ms) @@ -114,9 +104,9 @@ toStrict :: BL.ByteString -> B.ByteString toStrict = B.concat . BL.toChunks -- code generation for each module -cg :: OutFormat -> FilePath -> P.ModuleName -> IO ([P.ModuleName], S.Set FilePath) -cg outFormat baseOutDir coreFnMN = do - pwd <- getCurrentDirectory +cg :: FilePath -> P.ModuleName -> IO ([P.ModuleName], S.Set FilePath) +cg baseOutDir coreFnMN = do + pwd <- getCurrentDirectory let qualifiedMN = runModuleName [] [] coreFnMN -- TODO: customizable `output` directory let jsonFile = joinPath @@ -134,41 +124,20 @@ cg outFormat baseOutDir coreFnMN = do mp = modulePath module' -- name of the generated python package package = takeFileName baseOutDir - hasForeign <- case flip State.runStateT defaultOpts . runSTEither .runSupplyT 5 $ - moduleToJS module' (T.pack package) of + + hasForeign <- case flip State.runStateT defaultOpts . runSTEither .runSupplyT 5 $ moduleToJS module' (T.pack package) of Left e -> print (e :: MultipleErrors) >> exitFailure Right (((hasForeign, ast), _), _) -> do let augmentedAST = everywhere (astSSToAbsPath pwd) ast outDir = runToModulePath [pwd, baseOutDir] [] mn to :: FilePath -> FilePath to = (outDir ) - implCode :: forall a. EvalJS a => a - implCode = finally augmentedAST + implCode :: EvalJS (State (M.Map String Int) (Doc a)) => Doc a + implCode = runDoc $ finally augmentedAST - putStrLn $ "Codegen Python for " ++ qualifiedMN + putStrLn $ "Codegen DianaScript for " ++ qualifiedMN createDirectoryIfMissing True outDir - - case outFormat of - Compact -> - BL.writeFile (to "pure.raw.py") $ - BLU.fromString ("(" ++ escape mp ++ ",") <> - implCode <> - BLU.fromString ")" - - Pretty -> - T.writeFile (to "pure.raw.py") $ - T.pack ("(" ++ escape mp ++ ",") <> - codePretty implCode <> - T.pack ")" - - Compressed -> do - source <- mkEntrySelector "source" - srcPath <- mkEntrySelector "srcpath" - createArchive (to "pure.zip.py") $ do - addEntry BZip2 (toStrict $ serialize implCode) source - addEntry BZip2 (BSU.fromString mp) srcPath - - T.writeFile (to "pure.py") loaderCode + T.writeFile (to "@main.ran") $ codePretty implCode return hasForeign let newModsToImport = map snd (moduleImports module') @@ -212,16 +181,5 @@ astSSToAbsPath pwd n = withSourceSpan (ss {P.spanName = joinPath [pwd, SP.spanName ss]}) n -codePretty :: Doc PrettyTopdown -> T.Text +codePretty :: Doc a -> T.Text codePretty = renderStrict . layoutPretty defaultLayoutOptions - -loaderCode :: Text -loaderCode = - T.unlines . map T.pack $ - [ - "from purescripto import LoadPureScript" - , "__py__ = globals()" - , "__ps__ = LoadPureScript(__file__, __name__)" - , "__all__ = list(__ps__)" - , "__py__.update(__ps__)" - ] diff --git a/ci-passing.sh b/ci-passing.sh deleted file mode 100644 index 26e4cae..0000000 --- a/ci-passing.sh +++ /dev/null @@ -1,11 +0,0 @@ -cd passing - -nvm install 12.16.1 -nvm use 12.16.1 - - -# this allows failure -pyenv global 3.7 -pip3 install "purescripto>=0.8.0,<0.9.0" - -spago test diff --git a/env.sh b/env.sh new file mode 100644 index 0000000..12a0da0 --- /dev/null +++ b/env.sh @@ -0,0 +1,2 @@ +nvm install 12.16.1 +nvm use 12.16.1 diff --git a/impurescript-diana.cabal b/impurescript-diana.cabal new file mode 100644 index 0000000..741c9ef --- /dev/null +++ b/impurescript-diana.cabal @@ -0,0 +1,168 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: impurescript-diana +version: 0.1.3.0 +description: Please see the README on GitHub at +homepage: https://github.com/thautwarm/impurescript-diana#readme +bug-reports: https://github.com/thautwarm/impurescript-diana/issues +author: Taine Zhao +maintainer: twshere@outlook.com +copyright: 2021 Taine Zhao +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/thautwarm/impurescript-diana + +library + exposed-modules: + Language.PureScript.CodeGen.Diana + Language.PureScript.CodeGen.Diana.Common + Language.PureScript.CodeGen.Diana.Eval + Language.PureScript.CodeGen.Diana.Naming + Language.PureScript.CodeGen.Diana.Serializer + Monads.STEither + StringEscape + other-modules: + Paths_impurescript_diana + hs-source-dirs: + src + default-extensions: + GADTs + ViewPatterns + DeriveGeneric + DeriveFunctor + DeriveTraversable + LambdaCase + TemplateHaskell + DuplicateRecordFields + StandaloneDeriving + ExistentialQuantification + MultiParamTypeClasses + NamedFieldPuns + PartialTypeSignatures + FlexibleInstances + ConstraintKinds + DataKinds + DeriveFoldable + DerivingStrategies + EmptyDataDecls + FlexibleContexts + KindSignatures + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + build-depends: + aeson >=1.5.6.0 && <1.6 + , aeson-better-errors >=0.9.1.0 && <0.10 + , aeson-pretty >=0.8.8 && <0.9 + , base >=4.14.1.0 && <4.15 + , base-compat >=0.11.2 && <0.12 + , bytestring >=0.10.12.0 && <0.11 + , bytestring-conversion + , containers >=0.6.2.1 && <0.7 + , directory >=1.3.6.0 && <1.4 + , filepath >=1.4.2.1 && <1.5 + , monad-control >=1.0.2.3 && <1.1 + , monad-logger >=0.3.36 && <0.4 + , mtl >=2.2.2 && <2.3 + , prettyprinter + , protolude >=0.3.0 && <0.4 + , purescript + , purescript-cst + , semigroups >=0.19.1 && <0.20 + , text >=1.2.4.1 && <1.3 + , transformers >=0.5.6.2 && <0.6 + , transformers-base >=0.4.5.2 && <0.5 + , transformers-compat >=0.6.6 && <0.7 + , utf8-string >=1.0.2 && <1.1 + , zip + if os(darwin) + ghc-options: -O2 -O2 -static -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-missing-pattern-synonym-signatures -fno-warn-unused-matches -fno-warn-orphans + ld-options: -pthread -Wall + else + ghc-options: -O2 -static -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-missing-pattern-synonym-signatures -fno-warn-unused-matches -fno-warn-orphans + cc-options: -static + ld-options: -static -pthread -Wall + default-language: Haskell2010 + +executable psdiana + main-is: Main.hs + other-modules: + Paths_impurescript_diana + hs-source-dirs: + app + default-extensions: + GADTs + ViewPatterns + DeriveGeneric + DeriveFunctor + DeriveTraversable + LambdaCase + TemplateHaskell + DuplicateRecordFields + StandaloneDeriving + ExistentialQuantification + MultiParamTypeClasses + NamedFieldPuns + PartialTypeSignatures + FlexibleInstances + ConstraintKinds + DataKinds + DeriveFoldable + DerivingStrategies + EmptyDataDecls + FlexibleContexts + KindSignatures + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + build-depends: + aeson >=1.5.6.0 && <1.6 + , aeson-better-errors >=0.9.1.0 && <0.10 + , aeson-pretty >=0.8.8 && <0.9 + , base >=4.14.1.0 && <4.15 + , base-compat >=0.11.2 && <0.12 + , bytestring >=0.10.12.0 && <0.11 + , bytestring-conversion + , containers >=0.6.2.1 && <0.7 + , directory >=1.3.6.0 && <1.4 + , filepath >=1.4.2.1 && <1.5 + , impurescript-diana + , monad-control >=1.0.2.3 && <1.1 + , monad-logger >=0.3.36 && <0.4 + , mtl >=2.2.2 && <2.3 + , prettyprinter + , protolude >=0.3.0 && <0.4 + , purescript + , purescript-cst + , semigroups >=0.19.1 && <0.20 + , text >=1.2.4.1 && <1.3 + , transformers >=0.5.6.2 && <0.6 + , transformers-base >=0.4.5.2 && <0.5 + , transformers-compat >=0.6.6 && <0.7 + , utf8-string >=1.0.2 && <1.1 + , zip + if os(darwin) + ghc-options: -O2 -O2 -static -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-missing-pattern-synonym-signatures -fno-warn-unused-matches -fno-warn-orphans + ld-options: -pthread -Wall + else + ghc-options: -O2 -static -fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-missing-pattern-synonym-signatures -fno-warn-unused-matches -fno-warn-orphans + cc-options: -static + ld-options: -static -pthread -Wall + default-language: Haskell2010 diff --git a/install.sh b/install.sh new file mode 100644 index 0000000..fec7c67 --- /dev/null +++ b/install.sh @@ -0,0 +1,7 @@ +echo "installing" +stack build +export DIST_FILE="`stack path --dist-dir`/build/psdiana/psdiana" +cp $DIST_FILE ~/.local/bin +export RELEASE_TAG="`python travis-env.py plat`" +export ZIP_FILE="psdiana-`python travis-env.py plat`.zip" +zip -r $ZIP_FILE . -x "*.git*" "*.stack-work*" "passing/*" "src/" "app/" ".gitignore" "*.py" diff --git a/package.yaml b/package.yaml index 8f1f2d1..8dd9484 100644 --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ -name: purescript-python +name: impurescript-diana version: 0.1.3.0 -github: "purescript-python/purescript-python" +github: "thautwarm/impurescript-diana" license: MIT author: "Taine Zhao" maintainer: "twshere@outlook.com" @@ -110,15 +110,8 @@ library: source-dirs: src executables: - pspy-blueprint: + psdiana: main: Main.hs source-dirs: app dependencies: - - purescript-python - -tests: - purescript-python-test: - main: Spec.hs - source-dirs: test - dependencies: - - purescript-python + - impurescript-diana diff --git a/passing/packages.dhall b/passing/packages.dhall deleted file mode 100644 index 97129b4..0000000 --- a/passing/packages.dhall +++ /dev/null @@ -1,128 +0,0 @@ -{- -Welcome to your new Dhall package-set! - -Below are instructions for how to edit this file for most use -cases, so that you don't need to know Dhall to use it. - -## Warning: Don't Move This Top-Level Comment! - -Due to how `dhall format` currently works, this comment's -instructions cannot appear near corresponding sections below -because `dhall format` will delete the comment. However, -it will not delete a top-level comment like this one. - -## Use Cases - -Most will want to do one or both of these options: -1. Override/Patch a package's dependency -2. Add a package not already in the default package set - -This file will continue to work whether you use one or both options. -Instructions for each option are explained below. - -### Overriding/Patching a package - -Purpose: -- Change a package's dependency to a newer/older release than the - default package set's release -- Use your own modified version of some dependency that may - include new API, changed API, removed API by - using your custom git repo of the library rather than - the package set's repo - -Syntax: -Replace the overrides' "{=}" (an empty record) with the following idea -The "//" or "โซฝ" means "merge these two records and - when they have the same value, use the one on the right:" -------------------------------- -let overrides = - { packageName = - upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" } - , packageName = - upstream.packageName // { version = "v4.0.0" } - , packageName = - upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" } - } -------------------------------- - -Example: -------------------------------- -let overrides = - { halogen = - upstream.halogen // { version = "master" } - , halogen-vdom = - upstream.halogen-vdom // { version = "v4.0.0" } - } -------------------------------- - -### Additions - -Purpose: -- Add packages that aren't already included in the default package set - -Syntax: -Replace the additions' "{=}" (an empty record) with the following idea: -------------------------------- -let additions = - { package-name = - { dependencies = - [ "dependency1" - , "dependency2" - ] - , repo = - "https://example.com/path/to/git/repo.git" - , version = - "tag ('v4.0.0') or branch ('master')" - } - , package-name = - { dependencies = - [ "dependency1" - , "dependency2" - ] - , repo = - "https://example.com/path/to/git/repo.git" - , version = - "tag ('v4.0.0') or branch ('master')" - } - , etc. - } -------------------------------- - -Example: -------------------------------- -let additions = - { benchotron = - { dependencies = - [ "arrays" - , "exists" - , "profunctor" - , "strings" - , "quickcheck" - , "lcg" - , "transformers" - , "foldable-traversable" - , "exceptions" - , "node-fs" - , "node-buffer" - , "node-readline" - , "datetime" - , "now" - ] - , repo = - "https://github.com/hdgarrood/purescript-benchotron.git" - , version = - "v7.0.0" - } - } -------------------------------- --} - - -let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211030/packages.dhall sha256:5cd7c5696feea3d3f84505d311348b9e90a76c4ce3684930a0ff29606d2d816c - -let overrides = {=} - -let additions = {=} - -in upstream // overrides // additions diff --git a/passing/pure-py.json b/passing/pure-py.json deleted file mode 100644 index b8ab0e5..0000000 --- a/passing/pure-py.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "corefn-dir": "output", - "data-format": "Compressed", - - "entry-module": "Test.Main", - "index-mirror": "default", - "pspy-blueprint": "pspy-blueprint" -} \ No newline at end of file diff --git a/passing/python-ffi/Global.py b/passing/python-ffi/Global.py deleted file mode 100644 index 82d6b6c..0000000 --- a/passing/python-ffi/Global.py +++ /dev/null @@ -1,97 +0,0 @@ -import math -import urllib.parse - - -nan = math.nan -isNaN = math.isnan - - -infinity = math.inf -isFinite = math.isfinite - - -def readInt(radix): - def ap(n): - try: - return float(int(n, radix)) - except ValueError: - try: - return float(int(str(int(float(n))), radix)) - except ValueError: - return math.nan - return math.nan - - return ap - - -readFloat = float - - -def unsafeToFixed(digits): - def n_(n): - f = r"{:0." + str(digits) + r"f}" - return f.format(n) - - return n_ - - -def unsafeToExponential(digits): - def n_(n): - f = r"{:." + str(digits) + r"e}" - return f.format(n).replace("e-0", "e-").replace("e+0", "e+") - - return n_ - - -def unsafeToPrecision(digits): - def n_(n): - raise NotImplementedError() - - return n_ - - -def formatNumber(fmt): - def ap(fail, succ, digits, n): - try: - return succ(fmt(digits)(n)) - except Exception as e: - return fail(str(e)) - - return ap - - -_toFixed = formatNumber(unsafeToFixed) -_toExponential = formatNumber(unsafeToExponential) -_toPrecision = formatNumber(unsafeToPrecision) - - -def encdecURI(encdec): - def ap(fail, succ, s): - try: - return succ(encdec(s)) - except Exception as e: - return fail(str(e)) - - return ap - - -def decodeURI(s): - return urllib.parse.unquote(s, errors="strict") - - -def encodeURI(s): - return urllib.parse.quote(s, safe="~@#$&()*!+=:;,.?/'") - - -def decodeURIComponent(s): - return urllib.parse.unquote(s, errors="strict") - - -def encodeURIComponent(s): - return urllib.parse.quote(s, safe="~()*!.'") - - -_decodeURI = encdecURI(decodeURI) -_encodeURI = encdecURI(encodeURI) -_decodeURIComponent = encdecURI(decodeURIComponent) -_encodeURIComponent = encdecURI(encodeURIComponent) diff --git a/passing/python-ffi/Global/Unsafe.py b/passing/python-ffi/Global/Unsafe.py deleted file mode 100644 index b924418..0000000 --- a/passing/python-ffi/Global/Unsafe.py +++ /dev/null @@ -1,45 +0,0 @@ -import json -import urllib.parse -import re - - -def unsafeStringify(x): - return json.dumps(x) - - -def unsafeToFixed(digits): - def n_(n): - f = r"{:0." + str(digits) + r"f}" - return f.format(n) - - return n_ - - -def unsafeToExponential(digits): - def n_(n): - f = r"{:." + str(digits) + r"e}" - return f.format(n).replace("e-0", "e-").replace("e+0", "e+") - - return n_ - - -def unsafeToPrecision(digits): - def n_(n): - raise NotImplementedError() - - return n_ - - -def unsafeDecodeURI(s): - return urllib.parse.unquote(s, errors="strict") - - -def unsafeEncodeURI(s): - return urllib.parse.quote(s, safe="~@#$&()*!+=:;,.?/'") - -def unsafeDecodeURIComponent(s): - return urllib.parse.unquote(s, errors="strict") - - -def unsafeEncodeURIComponent(s): - return urllib.parse.quote(s, safe="~()*!.'") diff --git a/passing/python-ffi/PythonInterop.py b/passing/python-ffi/PythonInterop.py deleted file mode 100644 index ea722b7..0000000 --- a/passing/python-ffi/PythonInterop.py +++ /dev/null @@ -1,25 +0,0 @@ -def assertMsg(cond): - def ap_msg(msg): - def ap(): - assert cond, msg - return () - return ap - return ap_msg - -def assert_(cond): - def ap(): - assert cond - return () - return ap - -def repr(s, *, r=repr): - return lambda: r(s) - -unsafeEval = eval - -def eval(s, *, r=eval): - return lambda: r(s) - - -def error(s): - raise Exception(s) diff --git a/passing/python-ffi/Test/Globals.py b/passing/python-ffi/Test/Globals.py deleted file mode 100644 index b01bfa7..0000000 --- a/passing/python-ffi/Test/Globals.py +++ /dev/null @@ -1 +0,0 @@ -unencodable = "\uDFFF" \ No newline at end of file diff --git a/passing/python-ffi/Test/PyUtil.py b/passing/python-ffi/Test/PyUtil.py deleted file mode 100644 index 1b699c2..0000000 --- a/passing/python-ffi/Test/PyUtil.py +++ /dev/null @@ -1,19 +0,0 @@ -import sys - - -def setrecursionlimit(n: int): - def action(): - sys.setrecursionlimit(n) - - return action - - -def getrecursionlimit(): - return sys.getrecursionlimit() - - -def direct_print(x): - def ap(): - print(x) - - return ap diff --git a/passing/spago.dhall b/passing/spago.dhall deleted file mode 100644 index b56a44f..0000000 --- a/passing/spago.dhall +++ /dev/null @@ -1,36 +0,0 @@ -{- -Welcome to a Spago project! -You can edit this file as you like. --} -{ name = "my-project" -, dependencies = - [ "arrays" - , "assert" - , "console" - , "const" - , "control" - , "effect" - , "either" - , "enums" - , "exceptions" - , "foldable-traversable" - , "foreign" - , "record" - , "math" - , "maybe" - , "ordered-collections" - , "psci-support" - , "quickcheck" - , "random" - , "refs" - , "st" - , "strings" - , "tuples" - , "unfoldable" - , "unsafe-coerce" - , "validation" - ] -, packages = ./packages.dhall -, sources = [ "src/**/*.purs", "test/**/*.purs" ] -, backend = "pspy" -} diff --git a/passing/src/PythonInterop.js b/passing/src/PythonInterop.js deleted file mode 100644 index 4e36566..0000000 --- a/passing/src/PythonInterop.js +++ /dev/null @@ -1,12 +0,0 @@ -exports.assertMsg = function (a, b) { - throw Error("assertMsg is so far a Python backend specific method.") -} - -exports.assert_ = function (a) { - throw Error("assert_ is so far a Python backend specific method.") -} - -exports.eval = 0 -exports.unsafeEval = 0 -exports.repr = 0 -exports.error = 0 diff --git a/passing/src/PythonInterop.purs b/passing/src/PythonInterop.purs deleted file mode 100644 index 17bc8ce..0000000 --- a/passing/src/PythonInterop.purs +++ /dev/null @@ -1,24 +0,0 @@ -module PythonInterop where -import Prelude -import Effect (Effect) - --- | Equal to `assert cond, msg` in Python but wrapped in Effect monad. -foreign import assertMsg :: Boolean -> String -> Effect Unit - --- | Equal to `assert cond` in Python but wrapped in Effect monad. -foreign import assert_ :: Boolean -> Effect Unit - --- | Equal to `repr` in Python but wrapped in Effect monad. -foreign import repr :: forall a. a -> Effect String - --- | Equal to `eval` in Python but wrapped in Effect monad. -foreign import eval :: forall a. String -> Effect a - --- | Equal to `eval` in Python but wrapped in Effect monad. -foreign import unsafeEval :: forall a. String -> a - --- | Equal to `eval` in Python but wrapped in Effect monad. -foreign import error :: forall a. String -> a - -assert :: Boolean -> Effect Unit -assert = assert_ \ No newline at end of file diff --git a/passing/src/Test b/passing/src/Test deleted file mode 100644 index e69de29..0000000 diff --git a/passing/src/TestCases/Datatypes.purs b/passing/src/TestCases/Datatypes.purs deleted file mode 100644 index cd39dd8..0000000 --- a/passing/src/TestCases/Datatypes.purs +++ /dev/null @@ -1,58 +0,0 @@ -module TestCases.Datatypes where - -import Effect -import Prelude -import PythonInterop -import Effect.Console (log) - - -data MyEnum = A | B | C - --- ADT is abbr for algebraic data types -data MyADT -- this is the type declaration - = ADT1 String - | ADT2 Int Number - | ADT3 { x :: Int, y :: Int } - -newtype F = F MyADT - -data MyParametricADT a -- this is the type declaration - = PADT1 a - | PADT2 Int Number - | PADT3 { x :: Int, y :: Int, z :: a } - -newtype PF a = PF {it :: MyParametricADT a} - -testDatatypes :: Effect Unit -testDatatypes = do - f <- eval "lambda x: set(x.keys()) == {'.t'}" - assertMsg (f A) "invalid enumeration layout" - assertMsg (f B) "invalid enumeration layout" - assertMsg (f C) "invalid enumeration layout" - - ff <- eval "lambda name: lambda value: lambda x: x['.t'].__name__ == 'ps_' + name and {k: v for k, v in x.items() if k != '.t'} == value" - - f0 <- eval "lambda o: o['.t'].__name__ == 'ps_ADT1' and o['value0'] == 'this is a string'" - assertMsg (f0 $ ADT1 "this is a string") "invalid ADT layout 1" - f1 <- eval "lambda o: o['.t'].__name__ == 'ps_ADT2' and o['value0'] == 1 and o['value1'] == 2.0 and (type(o['value1']), type(o['value0'])) == (float, int)" - assertMsg (f1 $ ADT2 1 2.0) "invalid ADT layout 2" - - f2 <- eval "lambda o: o['value0']['x'] == 22 and o['value0']['y'] == 33" - assertMsg (f2 $ ADT3 {x : 22, y : 33}) "invalid ADT layout 3" - - (any_eq :: forall a. a) <- eval "lambda a: lambda b: a == b" - assertMsg (F (ADT3 {x : 22, y : 33}) `any_eq` (ADT3 {x : 22, y : 33})) "invalid newtype layout" - - f3 <- eval "lambda o: o['value0'] == 'this is a string'" - assertMsg (f3 $ PADT1 "this is a string") "invalid parameteric ADT 1" - - f4 <- eval "lambda o: (o['value0'], o['value1']) == (1, 2.0) and (type(o['value0']), type(o['value1'])) == (int, float)" - - assertMsg (f4 $ PADT2 1 2.0) "invalid parameteric ADT 2" - unwrap <- eval "lambda x: x['value0']" - assertMsg (unwrap (PADT3 {x : 22, y : 33, z : 2}) `any_eq` {x : 22, y : 33, z: 2}) "invalid parameteric ADT 3" - - let o = PF {it : PADT3 {x : 22, y : 33, z: 2}} - flip assertMsg "invalid nested box" $ case o of - PF {it : PADT3 {x, y}} | x `any_eq` 22 && y `any_eq` 33 -> true - _ -> false diff --git a/passing/src/TestCases/PatternMatching.purs b/passing/src/TestCases/PatternMatching.purs deleted file mode 100644 index 9570e76..0000000 --- a/passing/src/TestCases/PatternMatching.purs +++ /dev/null @@ -1,50 +0,0 @@ -module TestCases.PatternMaching where - -import Prelude -import PythonInterop - -import Data.Function (applyN) -import Effect (Effect) - -data Nat - = Zero -- 0 - | Succ Nat -- succ 0 -> 1; succ 2 -> 3 - -natToInt :: Nat -> Int -natToInt Zero = 0 -natToInt (Succ a) = 1 + natToInt a - -natToIntRecImpl :: Int -> Nat -> Int -natToIntRecImpl a Zero = a -natToIntRecImpl r (Succ a) = natToIntRecImpl (1 + r) a - -natToIntRec :: _ -natToIntRec = natToIntRecImpl 0 - -intToNatRecImpl :: Nat -> Int -> Nat -intToNatRecImpl a 0 = a -intToNatRecImpl a n = intToNatRecImpl (Succ a) (n + -1) - -intToNatRec :: _ -intToNatRec n - | n < 0 = error "" - | true = intToNatRecImpl Zero n - -_3 :: Nat -_3 = Succ (Succ (Succ Zero)) - - -testDeconsGuard :: _ --- test deconstructions in guards -testDeconsGuard n - | Succ a <- n = false - | true = true - -testPM :: Effect Unit -testPM = do - let (any_eq :: forall a b. a -> b -> Boolean) = unsafeEval "lambda a: lambda b: a == b" - assertMsg (natToInt _3 `any_eq` 3) "invalid construction(non rec)" - assertMsg (natToIntRec _3 `any_eq` 3) "invalid construction(rec) 0" - assertMsg (10000 `any_eq` natToIntRec (intToNatRec 10000)) "invalid construction(rec) 1" - assertMsg (false `any_eq` testDeconsGuard _3) "invalid deconstruction 0" - assertMsg (true `any_eq` testDeconsGuard Zero) "invalid deconstruction 1" diff --git a/passing/src/TestCases/Records.purs b/passing/src/TestCases/Records.purs deleted file mode 100644 index 8c17b54..0000000 --- a/passing/src/TestCases/Records.purs +++ /dev/null @@ -1,23 +0,0 @@ -module TestCases.Records (testRecords) where - -import Effect -import Effect.Console -import Prelude -import PythonInterop - -type IO = Effect - - -getFoo :: forall a r. {foo :: a | r} -> a -getFoo {foo} = foo - -infixl 5 pyEq as == -pyEq :: forall a b. a -> b -> Boolean -pyEq = unsafeEval "lambda a: lambda b: a == b" - -testRecords :: IO Unit -testRecords = do - flip assertMsg "invalid record 0" $ {foo: 1, bar: "2"} == unsafeEval "{'foo': 1, 'bar': '2'}" - flip assertMsg "invalid record 1" $ {foo: "3", bar: 4} == unsafeEval "{'foo': '3', 'bar': 4}" - flip assertMsg "invalid record 2" $ {foo: {}} == unsafeEval "{'foo': {}}" - flip assertMsg "invalid record 3" $ getFoo {foo: {foo_nested: 5, bar_nested: 6}, bar: 7} == unsafeEval "{'foo_nested': 5, 'bar_nested': 6}" diff --git a/passing/test/Arrays/Arrays.purs b/passing/test/Arrays/Arrays.purs deleted file mode 100644 index ee04ec2..0000000 --- a/passing/test/Arrays/Arrays.purs +++ /dev/null @@ -1,19 +0,0 @@ -module Test.Arrays where - -import Prelude -import Effect (Effect) -import Test.Arrays.Data.Array (testArray) -import Test.PyUtil (setrecursionlimit, getrecursionlimit) -import Effect.Class.Console (log) -import Test.Arrays.Data.Array.Partial (testArrayPartial) -import Test.Arrays.Data.Array.ST (testArrayST) -import Test.Arrays.Data.Array.ST.Partial (testArraySTPartial) -import Test.Arrays.Data.Array.NonEmpty (testNonEmptyArray) - -testArrays :: Effect Unit -testArrays = do - testArray - testArrayST - testArrayPartial - testArraySTPartial - testNonEmptyArray diff --git a/passing/test/Arrays/Data/Array/Array.purs b/passing/test/Arrays/Data/Array/Array.purs deleted file mode 100644 index c166ea6..0000000 --- a/passing/test/Arrays/Data/Array/Array.purs +++ /dev/null @@ -1,414 +0,0 @@ -module Test.Arrays.Data.Array (testArray) where - -import Prelude - -import Data.Array ((:), (\\), (!!)) -import Data.Array as A -import Data.Array.NonEmpty as NEA -import Data.Const (Const(..)) -import Data.Foldable (for_, foldMapDefaultR, class Foldable, all, traverse_) -import Data.Maybe (Maybe(..), isNothing, fromJust) -import Data.Tuple (Tuple(..)) -import Data.Unfoldable (replicateA) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) - -testArray :: Effect Unit -testArray = do - - log "singleton should construct an array with a single value" - assert $ A.singleton 1 == [1] - assert $ A.singleton "foo" == ["foo"] - assert $ A.singleton nil == [[]] - - log "range should create an inclusive array of integers for the specified start and end" - assert $ (A.range 0 5) == [0, 1, 2, 3, 4, 5] - assert $ (A.range 2 (-3)) == [2, 1, 0, -1, -2, -3] - - log "replicate should produce an array containg an item a specified number of times" - assert $ A.replicate 3 true == [true, true, true] - assert $ A.replicate 1 "foo" == ["foo"] - assert $ A.replicate 0 "foo" == [] - assert $ A.replicate (-1) "foo" == [] - - log "replicateA should perform the monadic action the correct number of times" - assert $ replicateA 3 (Just 1) == Just [1, 1, 1] - assert $ replicateA 1 (Just 1) == Just [1] - assert $ replicateA 0 (Just 1) == Just [] - assert $ replicateA (-1) (Just 1) == Just [] - - log "replicateA should be stack safe" - for_ [1, 1000, 2000, 20000, 50000] \n -> do - assert $ replicateA n (Just unit) == Just (A.replicate n unit :: Array Unit) - - -- some - -- many - - log "null should return false for non-empty arrays" - assert $ A.null [1] == false - assert $ A.null [1, 2, 3] == false - - log "null should return true for an empty array" - assert $ A.null nil == true - - log "length should return the number of items in an array" - assert $ A.length nil == 0 - assert $ A.length [1] == 1 - assert $ A.length [1, 2, 3, 4, 5] == 5 - - log "cons should add an item to the start of an array" - assert $ 4 : [1, 2, 3] == [4, 1, 2, 3] - assert $ 1 : nil == [1] - - log "snoc should add an item to the end of an array" - assert $ [1, 2, 3] `A.snoc` 4 == [1, 2, 3, 4] - assert $ nil `A.snoc` 1 == [1] - - log "insert should add an item at the appropriate place in a sorted array" - assert $ A.insert 1.5 [1.0, 2.0, 3.0] == [1.0, 1.5, 2.0, 3.0] - assert $ A.insert 4 [1, 2, 3] == [1, 2, 3, 4] - assert $ A.insert 0 [1, 2, 3] == [0, 1, 2, 3] - - log "insertBy should add an item at the appropriate place in a sorted array using the specified comparison" - assert $ A.insertBy (flip compare) 1.5 [1.0, 2.0, 3.0] == [1.0, 2.0, 3.0, 1.5] - assert $ A.insertBy (flip compare) 4 [1, 2, 3] == [4, 1, 2, 3] - assert $ A.insertBy (flip compare) 0 [1, 2, 3] == [1, 2, 3, 0] - - log "head should return a Just-wrapped first value of a non-empty array" - assert $ A.head ["foo", "bar"] == Just "foo" - - log "head should return Nothing for an empty array" - assert $ A.head nil == Nothing - - log "last should return a Just-wrapped last value of a non-empty array" - assert $ A.last ["foo", "bar"] == Just "bar" - - log "last should return Nothing for an empty array" - assert $ A.last nil == Nothing - - log "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array" - assert $ A.tail ["foo", "bar", "baz"] == Just ["bar", "baz"] - - log "tail should return Nothing for an empty array" - assert $ A.tail nil == Nothing - - log "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array" - assert $ A.init ["foo", "bar", "baz"] == Just ["foo", "bar"] - - log "init should return Nothing for an empty array" - assert $ A.init nil == Nothing - - log "uncons should return nothing when used on an empty array" - assert $ isNothing (A.uncons nil) - - log "uncons should split an array into a head and tail record when there is at least one item" - let u1 = unsafePartial $ fromJust $ A.uncons [1] - assert $ u1.head == 1 - assert $ u1.tail == [] - let u2 = unsafePartial $ fromJust $ A.uncons [1, 2, 3] - assert $ u2.head == 1 - assert $ u2.tail == [2, 3] - - log "unsnoc should return nothing when used on an empty array" - assert $ isNothing (A.unsnoc nil) - - log "unsnoc should split an array into an init and last record when there is at least one item" - let u3 = unsafePartial $ fromJust $ A.unsnoc [1] - assert $ u3.init == [] - assert $ u3.last == 1 - let u4 = unsafePartial $ fromJust $ A.unsnoc [1, 2, 3] - assert $ u4.init == [1, 2] - assert $ u4.last == 3 - - log "(!!) should return Just x when the index is within the bounds of the array" - assert $ [1, 2, 3] !! 0 == (Just 1) - assert $ [1, 2, 3] !! 1 == (Just 2) - assert $ [1, 2, 3] !! 2 == (Just 3) - - log "(!!) should return Nothing when the index is outside of the bounds of the array" - assert $ [1, 2, 3] !! 6 == Nothing - assert $ [1, 2, 3] !! (-1) == Nothing - - log "elemIndex should return the index of an item that a predicate returns true for in an array" - assert $ (A.elemIndex 1 [1, 2, 1]) == Just 0 - assert $ (A.elemIndex 4 [1, 2, 1]) == Nothing - - log "elemLastIndex should return the last index of an item in an array" - assert $ (A.elemLastIndex 1 [1, 2, 1]) == Just 2 - assert $ (A.elemLastIndex 4 [1, 2, 1]) == Nothing - - log "findIndex should return the index of an item that a predicate returns true for in an array" - assert $ (A.findIndex (_ /= 1) [1, 2, 1]) == Just 1 - assert $ (A.findIndex (_ == 3) [1, 2, 1]) == Nothing - - log "findLastIndex should return the last index of an item in an array" - assert $ (A.findLastIndex (_ /= 1) [2, 1, 2]) == Just 2 - assert $ (A.findLastIndex (_ == 3) [2, 1, 2]) == Nothing - - log "insertAt should add an item at the specified index" - assert $ (A.insertAt 0 1 [2, 3]) == Just [1, 2, 3] - assert $ (A.insertAt 1 1 [2, 3]) == Just [2, 1, 3] - assert $ (A.insertAt 2 1 [2, 3]) == Just [2, 3, 1] - - log "insertAt should return Nothing if the index is out of A.range" - assert $ (A.insertAt 2 1 nil) == Nothing - - log "deleteAt should remove an item at the specified index" - assert $ (A.deleteAt 0 [1, 2, 3]) == Just [2, 3] - assert $ (A.deleteAt 1 [1, 2, 3]) == Just [1, 3] - - log "deleteAt should return Nothing if the index is out of A.range" - assert $ (A.deleteAt 1 nil) == Nothing - - log "updateAt should replace an item at the specified index" - assert $ (A.updateAt 0 9 [1, 2, 3]) == Just [9, 2, 3] - assert $ (A.updateAt 1 9 [1, 2, 3]) == Just [1, 9, 3] - - log "updateAt should return Nothing if the index is out of A.range" - assert $ (A.updateAt 1 9 nil) == Nothing - - log "modifyAt should update an item at the specified index" - assert $ (A.modifyAt 0 (_ + 1) [1, 2, 3]) == Just [2, 2, 3] - assert $ (A.modifyAt 1 (_ + 1) [1, 2, 3]) == Just [1, 3, 3] - - log "modifyAt should return Nothing if the index is out of A.range" - assert $ (A.modifyAt 1 (_ + 1) nil) == Nothing - - log "alterAt should update an item at the specified index when the function returns Just" - assert $ (A.alterAt 0 (Just <<< (_ + 1)) [1, 2, 3]) == Just [2, 2, 3] - assert $ (A.alterAt 1 (Just <<< (_ + 1)) [1, 2, 3]) == Just [1, 3, 3] - - log "alterAt should drop an item at the specified index when the function returns Nothing" - assert $ (A.alterAt 0 (const Nothing) [1, 2, 3]) == Just [2, 3] - assert $ (A.alterAt 1 (const Nothing) [1, 2, 3]) == Just [1, 3] - - log "alterAt should return Nothing if the index is out of A.range" - assert $ (A.alterAt 1 (Just <<< (_ + 1)) nil) == Nothing - - log "reverse should reverse the order of items in an array" - assert $ (A.reverse [1, 2, 3]) == [3, 2, 1] - assert $ (A.reverse nil) == nil - - log "concat should join an array of arrays" - assert $ (A.concat [[1, 2], [3, 4]]) == [1, 2, 3, 4] - assert $ (A.concat [[1], nil]) == [1] - assert $ (A.concat [nil, nil]) == nil - - log "concatMap should be equivalent to (concat <<< map)" - assert $ A.concatMap doubleAndOrig [1, 2, 3] == A.concat (map doubleAndOrig [1, 2, 3]) - - log "filter should remove items that don't match a predicate" - assert $ A.filter odd (A.range 0 10) == [1, 3, 5, 7, 9] - - log "filterA should remove items that don't match a predicate while using an applicative behaviour" - assert $ A.filterA (Just <<< odd) (A.range 0 10) == Just [1, 3, 5, 7, 9] - assert $ A.filterA (const Nothing) (A.range 0 10) == Nothing - - log "filterA should apply effects in the right order" - assert $ A.filterA (Const <<< show) (A.range 1 5) == Const "12345" - - log "mapMaybe should transform every item in an array, throwing out Nothing values" - assert $ A.mapMaybe (\x -> if x /= 0 then Just x else Nothing) [0, 1, 0, 0, 2, 3] == [1, 2, 3] - - log "catMaybe should take an array of Maybe values and throw out Nothings" - assert $ A.catMaybes [Nothing, Just 2, Nothing, Just 4] == [2, 4] - - log "mapWithIndex applies a function with an index for every element" - assert $ A.mapWithIndex (\i x -> x - i) [9,8,7,6,5] == [9,7,5,3,1] - - log "updateAtIndices changes the elements at specified indices" - assert $ A.updateAtIndices - [Tuple 0 false, Tuple 2 false, Tuple 8 false] - [true, true, true, true] == - [false, true, false, true] - - log "modifyAtIndices modifies the elements at specified indices" - assert $ A.modifyAtIndices [0, 2, 8] not [true, true, true, true] == - [false, true, false, true] - - log "sort should reorder a list into ascending order based on the result of compare" - assert $ A.sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6] - - log "sortBy should reorder a list into ascending order based on the result of a comparison function" - assert $ A.sortBy (flip compare) [1, 3, 2, 5, 6, 4] == [6, 5, 4, 3, 2, 1] - - log "sortWith should reorder a list into ascending order based on the result of compare over a projection" - assert $ A.sortWith identity [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6] - - log "take should keep the specified number of items from the front of an array, discarding the rest" - assert $ (A.take 1 [1, 2, 3]) == [1] - assert $ (A.take 2 [1, 2, 3]) == [1, 2] - assert $ (A.take 1 nil) == nil - - log "takeWhile should keep all values that match a predicate from the front of an array" - assert $ (A.takeWhile (_ /= 2) [1, 2, 3]) == [1] - assert $ (A.takeWhile (_ /= 3) [1, 2, 3]) == [1, 2] - assert $ (A.takeWhile (_ /= 1) nil) == nil - - log "take should keep the specified number of items from the end of an array, discarding the rest" - assert $ (A.takeEnd 1 [1, 2, 3]) == [3] - assert $ (A.takeEnd 2 [1, 2, 3]) == [2, 3] - assert $ (A.takeEnd 1 nil) == nil - - log "drop should remove the specified number of items from the front of an array" - assert $ (A.drop 1 [1, 2, 3]) == [2, 3] - assert $ (A.drop 2 [1, 2, 3]) == [3] - assert $ (A.drop 1 nil) == nil - - log "dropWhile should remove all values that match a predicate from the front of an array" - assert $ (A.dropWhile (_ /= 1) [1, 2, 3]) == [1, 2, 3] - assert $ (A.dropWhile (_ /= 2) [1, 2, 3]) == [2, 3] - assert $ (A.dropWhile (_ /= 1) nil) == nil - - log "drop should remove the specified number of items from the end of an array" - assert $ (A.dropEnd 1 [1, 2, 3]) == [1, 2] - assert $ (A.dropEnd 2 [1, 2, 3]) == [1] - assert $ (A.dropEnd 1 nil) == nil - - log "take and drop should treat negative arguments as zero" - assert $ (A.take (-2) [1, 2, 3]) == nil - assert $ (A.drop (-2) [1, 2, 3]) == [1, 2, 3] - - log "span should split an array in two based on a predicate" - let testSpan { p, input, init_, rest_ } = do - let result = A.span p input - assert $ result.init == init_ - assert $ result.rest == rest_ - - let oneToSeven = [1, 2, 3, 4, 5, 6, 7] - testSpan { p: (_ < 4), input: oneToSeven, init_: [1, 2, 3], rest_: [4, 5, 6, 7] } - - log "span with all elements satisfying the predicate" - testSpan { p: const true, input: oneToSeven, init_: oneToSeven, rest_: [] } - - log "span with no elements satisfying the predicate" - testSpan { p: const false, input: oneToSeven, init_: [], rest_: oneToSeven } - - log "span with large inputs: 10000" - let testBigSpan n = - testSpan { p: (_ < n), input: A.range 1 n, init_: A.range 1 (n-1), rest_: [n] } - testBigSpan 10000 - - log "span with large inputs: 40000" - testBigSpan 40000 - - log "span with large inputs: 100000" - testBigSpan 100000 - - log "group should group consecutive equal elements into arrays" - assert $ A.group [1, 2, 2, 3, 3, 3, 1] == [NEA.singleton 1, nea [2, 2], nea [3, 3, 3], NEA.singleton 1] - - log "group' should sort then group consecutive equal elements into arrays" - assert $ A.group' [1, 2, 2, 3, 3, 3, 1] == [nea [1, 1], nea [2, 2], nea [3, 3, 3]] - - log "groupBy should group consecutive equal elements into arrays based on an equivalence relation" - assert $ A.groupBy (\x y -> odd x && odd y) [1, 1, 2, 2, 3, 3] == [nea [1, 1], NEA.singleton 2, NEA.singleton 2, nea [3, 3]] - - log "groupBy should be stable" - assert $ A.groupBy (\_ _ -> true) [1, 2, 3] == [nea [1, 2, 3]] - - log "nub should remove duplicate elements from the list, keeping the first occurence" - assert $ A.nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4] - - log "nub should preserve order" - assert $ A.nub [1, 3, 4, 2, 2, 1] == [1, 3, 4, 2] - - log "nubEq should remove duplicate elements from the list, keeping the first occurence" - assert $ A.nubEq [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4] - - log "nubEq should preserve order" - assert $ A.nubEq [1, 3, 4, 2, 2, 1] == [1, 3, 4, 2] - - log "nubBy should remove duplicate items from the list using a supplied predicate" - assert $ A.nubBy compare [1, 3, 4, 2, 2, 1] == [1, 3, 4, 2] - - log "nubByEq should remove duplicate items from the list using a supplied predicate" - let nubPred = \x y -> if odd x then false else x == y - assert $ A.nubByEq nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1] - - log "union should produce the union of two arrays" - assert $ A.union [1, 2, 3] [2, 3, 4] == [1, 2, 3, 4] - assert $ A.union [1, 1, 2, 3] [2, 3, 4] == [1, 1, 2, 3, 4] - - log "unionBy should produce the union of two arrays using the specified equality relation" - assert $ A.unionBy (\_ y -> y < 5) [1, 2, 3] [2, 3, 4, 5, 6] == [1, 2, 3, 5, 6] - - log "delete should remove the first matching item from an array" - assert $ A.delete 1 [1, 2, 1] == [2, 1] - assert $ A.delete 2 [1, 2, 1] == [1, 1] - - log "deleteBy should remove the first equality-relation-matching item from an array" - assert $ A.deleteBy (/=) 2 [1, 2, 1] == [2, 1] - assert $ A.deleteBy (/=) 1 [1, 2, 1] == [1, 1] - - log "(\\\\) should return the difference between two lists" - assert $ [1, 2, 3, 4, 3, 2, 1] \\ [1, 1, 2, 3] == [4, 3, 2] - - log "intersect should return the intersection of two arrays" - assert $ A.intersect [1, 2, 3, 4, 3, 2, 1] [1, 1, 2, 3] == [1, 2, 3, 3, 2, 1] - - log "intersectBy should return the intersection of two arrays using the specified equivalence relation" - assert $ A.intersectBy (\x y -> (x * 2) == y) [1, 2, 3] [2, 6] == [1, 3] - - log "zipWith should use the specified function to zip two lists together" - assert $ A.zipWith (\x y -> [show x, y]) [1, 2, 3] ["a", "b", "c"] == [["1", "a"], ["2", "b"], ["3", "c"]] - - log "zipWithA should use the specified function to zip two lists together" - assert $ A.zipWithA (\x y -> Just $ Tuple x y) [1, 2, 3] ["a", "b", "c"] == Just [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] - - log "zip should use the specified function to zip two lists together" - assert $ A.zip [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] - - log "unzip should deconstruct a list of tuples into a tuple of lists" - assert $ A.unzip [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] == Tuple [1, 2, 3] ["a", "b", "c"] - - log "foldM should perform a fold using a monadic step function" - assert $ A.foldM (\x y -> Just (x + y)) 0 (A.range 1 10) == Just 55 - assert $ A.foldM (\_ _ -> Nothing) 0 (A.range 1 10) == Nothing - - log "fromFoldable" - for_ [[], [1], [1,2], [1,2,3,4,5]] \xs -> do - assert $ A.fromFoldable xs == xs - - log "fromFoldable is stack safe" - for_ [1, 1000, 10000, 20000, 50000] \n -> do - let elem = 0 - let arr = A.fromFoldable (Replicated n elem) - assert $ A.length arr == n - assert $ all (_ == elem) arr - - log "toUnfoldable" - let toUnfoldableId xs = A.toUnfoldable xs == xs - traverse_ (assert <<< toUnfoldableId) - [ [] - , [1] - , [1,2,3] - , [2,3,1] - , [4,0,0,1,25,36,458,5842,23757] - ] - -nea :: Array ~> NEA.NonEmptyArray -nea = unsafePartial fromJust <<< NEA.fromArray - -nil :: Array Int -nil = [] - -odd :: Int -> Boolean -odd n = n `mod` 2 /= zero - -doubleAndOrig :: Int -> Array Int -doubleAndOrig x = [x * 2, x] - -data Replicated a = Replicated Int a - -instance foldableReplicated :: Foldable Replicated where - foldr f z (Replicated n x) = applyN n (f x) z - foldl f z (Replicated n x) = applyN n (flip f x) z - foldMap = foldMapDefaultR - -applyN :: forall a. Int -> (a -> a) -> a -> a -applyN n f x - | n <= 0 = x - | otherwise = applyN (n - 1) f (f x) diff --git a/passing/test/Arrays/Data/Array/NonEmpty.purs b/passing/test/Arrays/Data/Array/NonEmpty.purs deleted file mode 100644 index 83c8b4f..0000000 --- a/passing/test/Arrays/Data/Array/NonEmpty.purs +++ /dev/null @@ -1,314 +0,0 @@ -module Test.Arrays.Data.Array.NonEmpty (testNonEmptyArray) where - -import Prelude - -import Data.Array as A -import Data.Array.NonEmpty as NEA -import Data.Const (Const(..)) -import Data.Foldable (for_, sum, traverse_) -import Data.FunctorWithIndex (mapWithIndex) -import Data.Maybe (Maybe(..), fromJust) -import Data.Monoid.Additive (Additive(..)) -import Data.NonEmpty ((:|)) -import Data.Semigroup.Foldable (foldMap1) -import Data.Semigroup.Traversable (traverse1) -import Data.Tuple (Tuple(..)) -import Data.Unfoldable1 as U1 -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) - -testNonEmptyArray :: Effect Unit -testNonEmptyArray = do - let fromArray :: forall a. Array a -> NEA.NonEmptyArray a - fromArray = unsafePartial fromJust <<< NEA.fromArray - - log "singleton should construct an array with a single value" - assert $ NEA.toArray (NEA.singleton 1) == [1] - assert $ NEA.toArray (NEA.singleton "foo") == ["foo"] - - log "range should create an inclusive array of integers for the specified start and end" - assert $ NEA.toArray (NEA.range 0 5) == [0, 1, 2, 3, 4, 5] - assert $ NEA.toArray (NEA.range 2 (-3)) == [2, 1, 0, -1, -2, -3] - assert $ NEA.toArray (NEA.range 0 0) == [0] - - log "replicate should produce an array containg an item a specified number of times" - assert $ NEA.toArray (NEA.replicate 3 true) == [true, true, true] - assert $ NEA.toArray (NEA.replicate 1 "foo") == ["foo"] - assert $ NEA.toArray (NEA.replicate 0 "foo") == ["foo"] - assert $ NEA.toArray (NEA.replicate (-1) "foo") == ["foo"] - - log "length should return the number of items in an array" - assert $ NEA.length (NEA.singleton 1) == 1 - assert $ NEA.length (fromArray [1, 2, 3, 4, 5]) == 5 - - log "cons should add an item to the start of an array" - assert $ NEA.cons 4 (fromArray [1, 2, 3]) == fromArray [4, 1, 2, 3] - assert $ NEA.cons' 4 [1, 2, 3] == fromArray [4, 1, 2, 3] - - log "snoc should add an item to the end of an array" - assert $ fromArray [1, 2, 3] `NEA.snoc` 4 == fromArray [1, 2, 3, 4] - assert $ [1, 2, 3] `NEA.snoc'` 4 == fromArray [1, 2, 3, 4] - - log "insert should add an item at the appropriate place in a sorted array" - assert $ NEA.insert 1.5 (fromArray [1.0, 2.0, 3.0]) - == fromArray [1.0, 1.5, 2.0, 3.0] - assert $ NEA.insert 4 (fromArray [1, 2, 3]) == fromArray [1, 2, 3, 4] - - log "insertBy should add an item at the appropriate place in a sorted array using the specified comparison" - assert $ NEA.insertBy (flip compare) 1.5 (fromArray [1.0, 2.0, 3.0]) - == fromArray [1.0, 2.0, 3.0, 1.5] - - log "head should return the first value of a non-empty array" - assert $ NEA.head (fromArray ["foo", "bar"]) == "foo" - - log "last should return the last value of a non-empty array" - assert $ NEA.last (fromArray ["foo", "bar"]) == "bar" - - log "tail should return an array containing all the items in an array apart from the first for a non-empty array" - assert $ NEA.tail (fromArray ["foo", "bar", "baz"]) == ["bar", "baz"] - - log "init should return an array containing all the items in an array apart from the first for a non-empty array" - assert $ NEA.init (fromArray ["foo", "bar", "baz"]) == ["foo", "bar"] - - log "uncons should split an array into a head and tail record" - let u1 = NEA.uncons $ NEA.singleton 1 - assert $ u1.head == 1 - assert $ u1.tail == [] - let u2 = NEA.uncons $ fromArray [1, 2, 3] - assert $ u2.head == 1 - assert $ u2.tail == [2, 3] - - log "unsnoc should split an array into an init and last record" - let u3 = NEA.unsnoc $ NEA.singleton 1 - assert $ u3.init == [] - assert $ u3.last == 1 - let u4 = NEA.unsnoc $ fromArray [1, 2, 3] - assert $ u4.init == [1, 2] - assert $ u4.last == 3 - - log "index should return Just x when the index is within the bounds of the array" - assert $ NEA.index (fromArray [1, 2, 3]) 0 == Just 1 - assert $ NEA.index (fromArray [1, 2, 3]) 1 == Just 2 - assert $ NEA.index (fromArray [1, 2, 3]) 2 == Just 3 - - log "index should return Nothing when the index is outside of the bounds of the array" - assert $ NEA.index (fromArray [1, 2, 3]) 6 == Nothing - assert $ NEA.index (fromArray [1, 2, 3]) (-1) == Nothing - - log "elemIndex should return the index of an item that a predicate returns true for in an array" - assert $ NEA.elemIndex 1 (fromArray [1, 2, 1]) == Just 0 - assert $ NEA.elemIndex 4 (fromArray [1, 2, 1]) == Nothing - - log "elemLastIndex should return the last index of an item in an array" - assert $ NEA.elemLastIndex 1 (fromArray [1, 2, 1]) == Just 2 - assert $ NEA.elemLastIndex 4 (fromArray [1, 2, 1]) == Nothing - - log "findIndex should return the index of an item that a predicate returns true for in an array" - assert $ (NEA.findIndex (_ /= 1) (fromArray [1, 2, 1])) == Just 1 - assert $ (NEA.findIndex (_ == 3) (fromArray [1, 2, 1])) == Nothing - - log "findLastIndex should return the last index of an item in an array" - assert $ (NEA.findLastIndex (_ /= 1) (fromArray [2, 1, 2])) == Just 2 - assert $ (NEA.findLastIndex (_ == 3) (fromArray [2, 1, 2])) == Nothing - - log "insertAt should add an item at the specified index" - assert $ NEA.insertAt 0 1 (fromArray [2, 3]) == Just (fromArray [1, 2, 3]) - assert $ NEA.insertAt 1 1 (fromArray [2, 3]) == Just (fromArray [2, 1, 3]) - assert $ NEA.insertAt 2 1 (fromArray [2, 3]) == Just (fromArray [2, 3, 1]) - - log "insertAt should return Nothing if the index is out of A.range" - assert $ (NEA.insertAt 2 1 (NEA.singleton 1)) == Nothing - - log "deleteAt should remove an item at the specified index" - assert $ (NEA.deleteAt 0 (fromArray [1, 2, 3])) == Just [2, 3] - assert $ (NEA.deleteAt 1 (fromArray [1, 2, 3])) == Just [1, 3] - - log "deleteAt should return Nothing if the index is out of A.range" - assert $ (NEA.deleteAt 1 (NEA.singleton 1)) == Nothing - - log "updateAt should replace an item at the specified index" - assert $ NEA.updateAt 0 9 (fromArray [1, 2, 3]) == Just (fromArray [9, 2, 3]) - assert $ NEA.updateAt 1 9 (fromArray [1, 2, 3]) == Just (fromArray [1, 9, 3]) - - log "updateAt should return Nothing if the index is out of A.range" - assert $ NEA.updateAt 1 9 (NEA.singleton 0) == Nothing - - log "modifyAt should update an item at the specified index" - assert $ NEA.modifyAt 0 (_ + 1) (fromArray [1, 2, 3]) == Just (fromArray [2, 2, 3]) - assert $ NEA.modifyAt 1 (_ + 1) (fromArray [1, 2, 3]) == Just (fromArray [1, 3, 3]) - - log "modifyAt should return Nothing if the index is out of A.range" - assert $ NEA.modifyAt 1 (_ + 1) (NEA.singleton 0) == Nothing - - log "alterAt should update an item at the specified index when the function returns Just" - assert $ NEA.alterAt 0 (Just <<< (_ + 1)) (fromArray [1, 2, 3]) == Just [2, 2, 3] - assert $ NEA.alterAt 1 (Just <<< (_ + 1)) (fromArray [1, 2, 3]) == Just [1, 3, 3] - - log "alterAt should drop an item at the specified index when the function returns Nothing" - assert $ NEA.alterAt 0 (const Nothing) (fromArray [1, 2, 3]) == Just [2, 3] - assert $ NEA.alterAt 1 (const Nothing) (fromArray [1, 2, 3]) == Just [1, 3] - - log "alterAt should return Nothing if the index is out of NEA.range" - assert $ NEA.alterAt 1 (Just <<< (_ + 1)) (NEA.singleton 1) == Nothing - - log "reverse should reverse the order of items in an array" - assert $ NEA.reverse (fromArray [1, 2, 3]) == fromArray [3, 2, 1] - assert $ NEA.reverse (NEA.singleton 0) == NEA.singleton 0 - - log "concat should join an array of arrays" - assert $ NEA.concat (fromArray [fromArray [1, 2], fromArray [3, 4]]) == fromArray [1, 2, 3, 4] - - log "concatMap should be equivalent to (concat <<< map)" - assert $ NEA.concatMap doubleAndOrig (fromArray [1, 2, 3]) == NEA.concat (map doubleAndOrig (fromArray [1, 2, 3])) - - log "filter should remove items that don't match a predicate" - assert $ NEA.filter odd (NEA.range 0 10) == [1, 3, 5, 7, 9] - - log "filterA should remove items that don't match a predicate while using an applicative behaviour" - assert $ NEA.filterA (Just <<< odd) (NEA.range 0 10) == Just [1, 3, 5, 7, 9] - assert $ NEA.filterA (const Nothing) (NEA.range 0 10) == Nothing - - log "filterA should apply effects in the right order" - assert $ NEA.filterA (Const <<< show) (NEA.range 1 5) == Const "12345" - - log "mapMaybe should transform every item in an array, throwing out Nothing values" - assert $ NEA.mapMaybe (\x -> if x /= 0 then Just x else Nothing) (fromArray [0, 1, 0, 0, 2, 3]) == [1, 2, 3] - - log "catMaybe should take an array of Maybe values and throw out Nothings" - assert $ NEA.catMaybes (fromArray [Nothing, Just 2, Nothing, Just 4]) == [2, 4] - - log "mapWithIndex applies a function with an index for every element" - assert $ mapWithIndex (\i x -> x - i) (fromArray [9,8,7,6,5]) == fromArray [9,7,5,3,1] - - log "updateAtIndices changes the elements at specified indices" - assert $ NEA.updateAtIndices - [Tuple 0 false, Tuple 2 false, Tuple 8 false] - (fromArray [true, true, true, true]) == - fromArray [false, true, false, true] - - log "modifyAtIndices modifies the elements at specified indices" - assert $ NEA.modifyAtIndices [0, 2, 8] not (fromArray [true, true, true, true]) == - (fromArray [false, true, false, true]) - - log "sort should reorder a list into ascending order based on the result of compare" - assert $ NEA.sort (fromArray [1, 3, 2, 5, 6, 4]) == fromArray [1, 2, 3, 4, 5, 6] - - log "sortBy should reorder a list into ascending order based on the result of a comparison function" - assert $ NEA.sortBy (flip compare) (fromArray [1, 3, 2, 5, 6, 4]) == fromArray [6, 5, 4, 3, 2, 1] - - log "sortWith should reorder a list into ascending order based on the result of compare over a projection" - assert $ NEA.sortWith identity (fromArray [1, 3, 2, 5, 6, 4]) == fromArray [1, 2, 3, 4, 5, 6] - - log "take should keep the specified number of items from the front of an array, discarding the rest" - assert $ NEA.take 1 (fromArray [1, 2, 3]) == [1] - assert $ NEA.take 2 (fromArray [1, 2, 3]) == [1, 2] - - log "takeWhile should keep all values that match a predicate from the front of an array" - assert $ NEA.takeWhile (_ /= 2) (fromArray [1, 2, 3]) == [1] - assert $ NEA.takeWhile (_ /= 3) (fromArray [1, 2, 3]) == [1, 2] - - log "take should keep the specified number of items from the end of an array, discarding the rest" - assert $ NEA.takeEnd 1 (fromArray [1, 2, 3]) == [3] - assert $ NEA.takeEnd 2 (fromArray [1, 2, 3]) == [2, 3] - - log "drop should remove the specified number of items from the front of an array" - assert $ NEA.drop 1 (fromArray [1, 2, 3]) == [2, 3] - assert $ NEA.drop 2 (fromArray [1, 2, 3]) == [3] - - log "dropWhile should remove all values that match a predicate from the front of an array" - assert $ NEA.dropWhile (_ /= 1) (fromArray [1, 2, 3]) == [1, 2, 3] - assert $ NEA.dropWhile (_ /= 2) (fromArray [1, 2, 3]) == [2, 3] - - log "drop should remove the specified number of items from the end of an array" - assert $ NEA.dropEnd 1 (fromArray [1, 2, 3]) == [1, 2] - assert $ NEA.dropEnd 2 (fromArray [1, 2, 3]) == [1] - - log "span should split an array in two based on a predicate" - let testSpan { p, input, init_, rest_ } = do - let result = NEA.span p input - assert $ result.init == init_ - assert $ result.rest == rest_ - - let oneToSeven = fromArray [1, 2, 3, 4, 5, 6, 7] - testSpan { p: (_ < 4), input: oneToSeven, init_: [1, 2, 3], rest_: [4, 5, 6, 7] } - - log "nub should remove duplicate elements from the list, keeping the first occurence" - assert $ NEA.nub (fromArray [1, 2, 2, 3, 4, 1]) == fromArray [1, 2, 3, 4] - - log "nubEq should remove duplicate elements from the list, keeping the first occurence" - assert $ NEA.nubEq (fromArray [1, 2, 2, 3, 4, 1]) == fromArray [1, 2, 3, 4] - - log "nubByEq should remove duplicate items from the list using a supplied predicate" - let nubPred = \x y -> if odd x then false else x == y - assert $ NEA.nubByEq nubPred (fromArray [1, 2, 2, 3, 3, 4, 4, 1]) == fromArray [1, 2, 3, 3, 4, 1] - - log "union should produce the union of two arrays" - assert $ NEA.union (fromArray [1, 2, 3]) (fromArray [2, 3, 4]) == fromArray [1, 2, 3, 4] - assert $ NEA.union (fromArray [1, 1, 2, 3]) (fromArray [2, 3, 4]) == fromArray [1, 1, 2, 3, 4] - - log "unionBy should produce the union of two arrays using the specified equality relation" - assert $ NEA.unionBy (\_ y -> y < 5) (fromArray [1, 2, 3]) (fromArray [2, 3, 4, 5, 6]) == fromArray [1, 2, 3, 5, 6] - - log "delete should remove the first matching item from an array" - assert $ NEA.delete 1 (fromArray [1, 2, 1]) == [2, 1] - assert $ NEA.delete 2 (fromArray [1, 2, 1]) == [1, 1] - - log "deleteBy should remove the first equality-relation-matching item from an array" - assert $ NEA.deleteBy (/=) 2 (fromArray [1, 2, 1]) == [2, 1] - assert $ NEA.deleteBy (/=) 1 (fromArray [1, 2, 1]) == [1, 1] - - log "intersect should return the intersection of two arrays" - assert $ NEA.intersect (fromArray [1, 2, 3, 4, 3, 2, 1]) (fromArray [1, 1, 2, 3]) == [1, 2, 3, 3, 2, 1] - - log "intersectBy should return the intersection of two arrays using the specified equivalence relation" - assert $ NEA.intersectBy (\x y -> (x * 2) == y) (fromArray [1, 2, 3]) (fromArray [2, 6]) == [1, 3] - - log "zipWith should use the specified function to zip two arrays together" - assert $ NEA.zipWith (\x y -> [show x, y]) (fromArray [1, 2, 3]) (fromArray ["a", "b", "c"]) == fromArray [["1", "a"], ["2", "b"], ["3", "c"]] - - log "zipWithA should use the specified function to zip two lists together" - assert $ NEA.zipWithA (\x y -> Just $ Tuple x y) (fromArray [1, 2, 3]) (fromArray ["a", "b", "c"]) == Just (fromArray [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]) - - log "zip should use the specified function to zip two lists together" - assert $ NEA.zip (fromArray [1, 2, 3]) (fromArray ["a", "b", "c"]) == fromArray [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] - - log "unzip should deconstruct a list of tuples into a tuple of lists" - assert $ NEA.unzip (fromArray [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]) == Tuple (fromArray [1, 2, 3]) (fromArray ["a", "b", "c"]) - - log "fromFoldable" - for_ (fromArray [[], [1], [1,2], [1,2,3,4,5]]) \xs -> do - assert $ NEA.fromFoldable xs == NEA.fromArray xs - - log "toUnfoldable" - let toUnfoldableId xs = NEA.toUnfoldable xs == NEA.toArray xs - traverse_ (assert <<< toUnfoldableId) $ - fromArray ( - [ fromArray [1] - , fromArray [1,2,3] - , fromArray [2,3,1] - , fromArray [4,0,0,1,25,36,458,5842,23757] - ]) - - log "toUnfoldable1" - assert $ NEA.toUnfoldable1 (NEA.range 0 9) == 0 :| A.range 1 9 - - log "Unfoldable instance" - assert $ U1.range 0 9 == NEA.range 0 9 - - log "foldl should work" - -- test through sum - assert $ sum (fromArray [1, 2, 3, 4]) == 10 - - log "foldMap1 should work" - assert $ foldMap1 Additive (fromArray [1, 2, 3, 4]) == Additive 10 - - log "traverse1 should work" - assert $ traverse1 Just (fromArray [1, 2, 3, 4]) == NEA.fromArray [1, 2, 3, 4] - -odd :: Int -> Boolean -odd n = n `mod` 2 /= zero - -doubleAndOrig :: Int -> NEA.NonEmptyArray Int -doubleAndOrig x = NEA.cons (x * 2) (NEA.singleton x) diff --git a/passing/test/Arrays/Data/Array/Partial.purs b/passing/test/Arrays/Data/Array/Partial.purs deleted file mode 100644 index 605a938..0000000 --- a/passing/test/Arrays/Data/Array/Partial.purs +++ /dev/null @@ -1,26 +0,0 @@ -module Test.Arrays.Data.Array.Partial (testArrayPartial) where - -import Prelude - -import Data.Array.Partial (init, last, tail, head) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) - -testArrayPartial :: Effect Unit -testArrayPartial = do - - log "head should return the first item in an array" - assert $ unsafePartial $ head [1, 2, 3] == 1 - assert $ unsafePartial $ head [1] == 1 - - log "tail should return all but the first item in an array" - assert $ unsafePartial $ tail [1, 2, 3] == [2, 3] - - log "last should return the last item of an array" - assert $ unsafePartial $ last [1, 2, 3] == 3 - assert $ unsafePartial $ last [1] == 1 - - log "init should return all but the last item of an array" - assert $ unsafePartial $ init [1, 2, 3] == [1, 2] diff --git a/passing/test/Arrays/Data/Array/ST.purs b/passing/test/Arrays/Data/Array/ST.purs deleted file mode 100644 index fe9a912..0000000 --- a/passing/test/Arrays/Data/Array/ST.purs +++ /dev/null @@ -1,276 +0,0 @@ -module Test.Arrays.Data.Array.ST (testArrayST) where - -import Prelude - -import Control.Monad.ST as ST -import Data.Array.ST (withArray) -import Data.Array.ST as STA -import Data.Foldable (all) -import Data.Maybe (Maybe(..), isNothing) -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert) - -testArrayST :: Effect Unit -testArrayST = do - - log "run should produce an immutable array by running a constructor operation" - - assert $ STA.run (do - arr <- STA.empty - void $ STA.push 1 arr - void $ STA.push 2 arr - pure arr) == [1, 2] - - log "withArray should run an operation on a copy of an array" - - let original = [1, 2, 3] - assert $ ST.run (withArray (STA.push 42) original) == [1, 2, 3, 42] - assert $ original == [1, 2, 3] - - log "empty should produce an empty array" - - assert $ STA.run STA.empty == nil - - log "thaw should produce an STArray from a standard array" - - assert $ STA.run (STA.thaw [1, 2, 3]) == [1, 2, 3] - - log "freeze should produce a standard array from an STArray" - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.freeze arr) == [1, 2, 3] - - log "unsafeThaw should produce an STArray from a standard array" - - assert $ STA.run (STA.unsafeThaw [1, 2, 3]) == [1, 2, 3] - - log "pop should remove elements from an STArray" - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.pop arr - pure arr) == [1, 2] - - log "pop should return the last element of an STArray" - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.pop arr) == Just 3 - - log "pop should return Nothing when given an empty array" - - assert $ isNothing $ ST.run (do - arr <- STA.empty - STA.pop arr) - - log "push should append a value to the end of the array" - - assert $ STA.run (do - arr <- STA.empty - void $ STA.push 1 arr - void $ STA.push 2 arr - pure arr) == [1, 2] - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.push 4 arr - pure arr) == [1, 2, 3, 4] - - log "push should return the new length of the array" - - assert $ ST.run (do - arr <- STA.thaw [unit, unit, unit] - STA.push unit arr) == 4 - - log "pushAll should append multiple values to the end of the array" - - assert $ STA.run (do - arr <- STA.empty - void $ STA.pushAll [1, 2] arr - pure arr) == [1, 2] - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.pushAll [4, 5, 6] arr - pure arr) == [1, 2, 3, 4, 5, 6] - - log "pushAll should return the new length of the array" - - assert $ ST.run (do - arr <- STA.thaw [unit, unit, unit] - STA.pushAll [unit, unit] arr) == 5 - - log "peek should return Nothing when peeking a value outside the array bounds" - - assert $ isNothing $ ST.run (do - arr <- STA.empty - STA.peek 0 arr) - - assert $ isNothing $ ST.run (do - arr <- STA.thaw [1] - STA.peek 1 arr) - - assert $ isNothing $ ST.run (do - arr <- STA.empty - STA.peek (-1) arr) - - log "peek should return the value at the specified index" - - assert $ ST.run (do - arr <- STA.thaw [1] - STA.peek 0 arr) == Just 1 - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.peek 2 arr) == Just 3 - - log "poke should return true when a value has been updated succesfully" - - assert $ ST.run (do - arr <- STA.thaw [1] - STA.poke 0 10 arr) - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.poke 2 30 arr) - - log "poke should return false when attempting to modify a value outside the array bounds" - - assert $ not $ ST.run (do - arr <- STA.empty - STA.poke 0 10 arr) - - assert $ not $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.poke 3 100 arr) - - assert $ not $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.poke (-1) 100 arr) - - log "poke should replace the value at the specified index" - - assert $ STA.run (do - arr <- STA.thaw [1] - void $ STA.poke 0 10 arr - pure arr) == [10] - - log "poke should do nothing when attempting to modify a value outside the array bounds" - - assert $ STA.run (do - arr <- STA.thaw [1] - void $ STA.poke 1 2 arr - pure arr) == [1] - - log "shift should remove elements from an STArray" - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.shift arr - pure arr) == [2, 3] - - log "shift should return the first element of an STArray" - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3] - STA.shift arr) == Just 1 - - log "shift should return Nothing when given an empty array" - - assert $ isNothing $ ST.run (do - arr <- STA.empty - STA.shift arr) - - log "unshift should append a value to the front of the array" - - assert $ STA.run (do - arr <- STA.empty - void $ STA.unshift 1 arr - void $ STA.unshift 2 arr - pure arr) == [2, 1] - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.unshift 4 arr - pure arr) == [4, 1, 2, 3] - - log "unshift should return the new length of the array" - - assert $ ST.run (do - arr <- STA.thaw [unit, unit, unit] - STA.unshift unit arr) == 4 - - log "unshiftAll should append multiple values to the front of the array" - - assert $ STA.run (do - arr <- STA.empty - void $ STA.unshiftAll [1, 2] arr - pure arr) == [1, 2] - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3] - void $ STA.unshiftAll [4, 5, 6] arr - pure arr) == [4, 5, 6, 1, 2, 3] - - log "unshiftAll should return the new length of the array" - - assert $ ST.run (do - arr <- STA.thaw [unit, unit, unit] - STA.unshiftAll [unit, unit] arr) == 5 - - log "sort should reorder a list into ascending order based on the result of compare" - assert $ STA.run ( - STA.sort =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4] - ) == [1, 2, 3, 4, 5, 6] - - log "sortBy should reorder a list into ascending order based on the result of a comparison function" - assert $ STA.run ( - STA.sortBy (flip compare) =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4] - ) == [6, 5, 4, 3, 2, 1] - - log "sortWith should reorder a list into ascending order based on the result of compare over a projection" - assert $ STA.run ( - STA.sortWith identity =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4] - ) == [1, 2, 3, 4, 5, 6] - - log "splice should be able to delete multiple items at a specified index" - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3, 4, 5] - void $ STA.splice 1 3 [] arr - pure arr) == [1, 5] - - log "splice should return the items removed" - - assert $ ST.run (do - arr <- STA.thaw [1, 2, 3, 4, 5] - STA.splice 1 3 [] arr) == [2, 3, 4] - - log "splice should be able to insert multiple items at a specified index" - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3, 4, 5] - void $ STA.splice 1 0 [0, 100] arr - pure arr) == [1, 0, 100, 2, 3, 4, 5] - - log "splice should be able to delete and insert at the same time" - - assert $ STA.run (do - arr <- STA.thaw [1, 2, 3, 4, 5] - void $ STA.splice 1 2 [0, 100] arr - pure arr) == [1, 0, 100, 4, 5] - - log "toAssocArray should return all items in the array with the correct indices and values" - - assert $ all (\{ value: v, index: i } -> v == i + 1) $ ST.run (do - arr <- STA.thaw [1, 2, 3, 4, 5] - STA.toAssocArray arr) - - assert $ all (\{ value: v, index: i } -> v == (i + 1) * 10) $ ST.run (do - arr <- STA.thaw [10, 20, 30, 40, 50] - STA.toAssocArray arr) - -nil :: Array Int -nil = [] diff --git a/passing/test/Arrays/Data/Array/ST/Partial.purs b/passing/test/Arrays/Data/Array/ST/Partial.purs deleted file mode 100644 index 080828e..0000000 --- a/passing/test/Arrays/Data/Array/ST/Partial.purs +++ /dev/null @@ -1,25 +0,0 @@ -module Test.Arrays.Data.Array.ST.Partial (testArraySTPartial) where - -import Prelude - -import Control.Monad.ST as ST -import Data.Array.ST (thaw, unsafeFreeze) -import Data.Array.ST.Partial as STAP -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) - -testArraySTPartial :: Effect Unit -testArraySTPartial = do - - log "peekSTArray should return the value at the specified index" - assert $ 2 == ST.run do - a <- thaw [1, 2, 3] - unsafePartial $ STAP.peek 1 a - - log "pokeSTArray should modify the value at the specified index" - assert $ [1, 4, 3] == ST.run do - a <- thaw [1, 2, 3] - unsafePartial $ STAP.poke 1 4 a - unsafeFreeze a diff --git a/passing/test/Global.Unsafe.purs b/passing/test/Global.Unsafe.purs deleted file mode 100644 index 1c8552e..0000000 --- a/passing/test/Global.Unsafe.purs +++ /dev/null @@ -1,41 +0,0 @@ -module Global.Unsafe where - --- | Uses the global JSON object to turn anything into a string. Careful! Trying --- | to serialize functions returns undefined -foreign import unsafeStringify :: forall a. a -> String - --- | Formats Number as a String with limited number of digits after the dot. --- | --- | May throw RangeError if the number of digits is not within the allowed range --- | (standard precision range is 0 to 20, but implementations may change it) -foreign import unsafeToFixed :: Int -> Number -> String - --- | Formats Number as String in exponential notation limiting number of digits --- | after the decimal dot. --- | --- | May throw RangeError if the number of digits is not within the allowed range --- | (standard precision range is 0 to 20, but implementations may change it) -foreign import unsafeToExponential :: Int -> Number -> String - --- | Formats Number as String in fixed-point or exponential notation rounded --- | to specified number of significant digits. --- | --- | May throw RangeError if the number of digits is not within the allowed range --- | (standard precision range is 0 to 100, but implementations may change it) -foreign import unsafeToPrecision :: Int -> Number -> String - --- | URI decoding. May throw a `URIError` if given a value with undecodeable --- | escape sequences. -foreign import unsafeDecodeURI :: String -> String - --- | URI encoding. May throw a `URIError` if given a value with unencodeable --- | characters. -foreign import unsafeEncodeURI :: String -> String - --- | URI component decoding. May throw a `URIError` if given a value with --- | undecodeable escape sequences. -foreign import unsafeDecodeURIComponent :: String -> String - --- | URI component encoding. May throw a `URIError` if given a value with --- | unencodeable characters. -foreign import unsafeEncodeURIComponent :: String -> String \ No newline at end of file diff --git a/passing/test/Global.purs b/passing/test/Global.purs deleted file mode 100644 index 5019e55..0000000 --- a/passing/test/Global.purs +++ /dev/null @@ -1,93 +0,0 @@ --- | This module defines types for some global Javascript functions --- | and values. -module Global - ( nan - , isNaN - , infinity - , isFinite - , readInt - , readFloat - , toFixed - , toExponential - , toPrecision - , decodeURI - , encodeURI - , decodeURIComponent - , encodeURIComponent - ) where - -import Prelude -import Data.Function.Uncurried (Fn3, Fn4, runFn3, runFn4) -import Data.Maybe (Maybe(..)) - --- | Not a number (NaN) -foreign import nan :: Number - --- | Test whether a number is NaN -foreign import isNaN :: Number -> Boolean - --- | Positive infinity -foreign import infinity :: Number - --- | Test whether a number is finite -foreign import isFinite :: Number -> Boolean - --- | Parse an integer from a `String` in the specified base -foreign import readInt :: Int -> String -> Number - --- | Parse a floating point value from a `String` -foreign import readFloat :: String -> Number - -foreign import _toFixed :: forall a. Fn4 (String -> a) (String -> a) Int Number a - -foreign import _toExponential :: forall a. Fn4 (String -> a) (String -> a) Int Number a - -foreign import _toPrecision :: forall a. Fn4 (String -> a) (String -> a) Int Number a - --- | Formats Number as a String with limited number of digits after the dot. --- | May return `Nothing` when specified number of digits is less than 0 or --- | greater than 20. See ECMA-262 for more information. -toFixed :: Int -> Number -> Maybe String -toFixed digits n = runFn4 _toFixed (const Nothing) Just digits n - --- | Formats Number as String in exponential notation limiting number of digits --- | after the decimal dot. May return `Nothing` when specified number of --- | digits is less than 0 or greater than 20 depending on the implementation. --- | See ECMA-262 for more information. -toExponential :: Int -> Number -> Maybe String -toExponential digits n = runFn4 _toExponential (const Nothing) Just digits n - --- | Formats Number as String in fixed-point or exponential notation rounded --- | to specified number of significant digits. May return `Nothing` when --- | precision is less than 1 or greater than 21 depending on the --- | implementation. See ECMA-262 for more information. -toPrecision :: Int -> Number -> Maybe String -toPrecision digits n = runFn4 _toPrecision (const Nothing) Just digits n - -foreign import _decodeURI :: forall a. Fn3 (String -> a) (String -> a) String a - -foreign import _encodeURI :: forall a. Fn3 (String -> a) (String -> a) String a - -foreign import _decodeURIComponent :: forall a. Fn3 (String -> a) (String -> a) String a - -foreign import _encodeURIComponent :: forall a. Fn3 (String -> a) (String -> a) String a - --- | URI decoding. Returns `Nothing` when given a value with undecodeable --- | escape sequences. -decodeURI :: String -> Maybe String -decodeURI s = runFn3 _decodeURI (const Nothing) Just s - --- | URI encoding. Returns `Nothing` when given a value with unencodeable --- | characters. -encodeURI :: String -> Maybe String -encodeURI s = runFn3 _encodeURI (const Nothing) Just s - --- | URI component decoding. Returns `Nothing` when given a value with --- | undecodeable escape sequences. -decodeURIComponent :: String -> Maybe String -decodeURIComponent s = runFn3 _decodeURIComponent (const Nothing) Just s - --- | URI component encoding. Returns `Nothing` when given a value with --- | unencodeable characters. -encodeURIComponent :: String -> Maybe String -encodeURIComponent s = runFn3 _encodeURIComponent (const Nothing) Just s \ No newline at end of file diff --git a/passing/test/Globals.purs b/passing/test/Globals.purs deleted file mode 100644 index 8eb5eeb..0000000 --- a/passing/test/Globals.purs +++ /dev/null @@ -1,92 +0,0 @@ -module Test.Globals (testGlobals) where - -import Prelude -import Data.Maybe (Maybe(..)) -import Effect (Effect) -import Effect.Console (log) -import Global - ( readFloat - , readInt - , isFinite - , infinity - , nan - , isNaN - , toPrecision - , toExponential - , toFixed - , decodeURI - , encodeURI - , decodeURIComponent - , encodeURIComponent - ) -import Global.Unsafe (unsafeToPrecision, unsafeToExponential, unsafeToFixed) -import Test.Assert (assert) - -testGlobals :: Effect Unit -testGlobals = do - let - num = 12345.6789 - log "nan /= nan" - assert $ nan /= nan - log "not (isNaN 6.0)" - assert $ not (isNaN 6.0) - log "isNaN nan" - assert $ isNaN nan - log "infinity > 0.0" - assert $ infinity > 0.0 - log "-infinity < 0.0" - assert $ -infinity < 0.0 - log "not (isFinite infinity)" - assert $ not (isFinite infinity) - log "isFinite 0.0" - assert $ isFinite 0.0 - log "readInt 16 \"0xFF\" == 255.0" - assert $ readInt 16 "0xFF" == 255.0 - log "readInt 10 \"3.5\" == 3.0" - assert $ readInt 10 "3.5" == 3.0 - log "readFloat \"3.5\" == 3.5" - assert $ readFloat "3.5" == 3.5 - -- note the rounding - log $ "unsafeToFixed 1" <> (show num) <> " == \"12345.7\"" - assert $ unsafeToFixed 1 num == "12345.7" - -- padded with zeros - log $ "unsafeToFixed 6" <> (show num) <> " == \"12345.678900\"" - assert $ unsafeToFixed 6 num == "12345.678900" - log $ "unsafeToExponential 4" <> (show num) <> " == \"1.2346e+4\"" - assert $ unsafeToExponential 4 num == "1.2346e+4" - -- TODO: fix toPrecision problems here --- log $ "unsafeToPrecision 3" <> (show num) <> " == \"1.23e+4\"" --- assert $ unsafeToPrecision 3 num == "1.23e+4" --- log $ "unsafeToPrecision 6" <> (show num) <> " == \"12345.7\"" --- assert $ unsafeToPrecision 6 num == "12345.7" - -- note the rounding - log $ "toFixed 1" <> (show num) <> " == (Just \"12345.7\")" - assert $ toFixed 1 num == Just "12345.7" - -- padded with zeros - log $ "toFixed 6" <> (show num) <> " == (Just \"12345.678900\")" - assert $ toFixed 6 num == Just "12345.678900" - log $ "toExponential 4" <> (show num) <> " == (Just \"1.2346e+4\")" - assert $ toExponential 4 num == Just "1.2346e+4" - -- TODO: fix toPrecision problems here --- log $ "toPrecision 3" <> (show num) <> " == (Just \"1.23e+4\")" --- assert $ toPrecision 3 num == Just "1.23e+4" --- log $ "toPrecision 6" <> (show num) <> " == (Just \"12345.7\")" --- assert $ toPrecision 6 num == Just "12345.7" - log $ "decodeURI \"http://test/api?q=hello%20world\" == Just \"http://test/api?q=hello world\"" - assert $ decodeURI "http://test/api?q=hello%20world" == Just "http://test/api?q=hello world" --- log $ "decodeURI \"http://test/api?q=hello%8\" == Nothing\"" --- assert $ decodeURI "http://test/api?q=hello%8" == Nothing - log $ "encodeURI \"http://test/api?q=hello world\" == Just \"http://test/api?q=hello%20world\"" - assert $ encodeURI "http://test/api?q=hello world" == Just "http://test/api?q=hello%20world" --- log $ "encodeURI \"http://test/api?q=" <> unencodable <> "\" == Nothing" --- assert $ encodeURI ("http://test/api?q=" <> unencodable) == Nothing - log $ "decodeURIComponent \"hello%20world\" == Just \"hello world\"" - assert $ decodeURIComponent "hello%20world" == Just "hello world" --- log $ "decodeURIComponent \"hello%8\" == Nothing" --- assert $ decodeURIComponent "hello%8" == Nothing - log $ "encodeURIComponent \"hello world\" == Just \"hello%20world\"" - assert $ encodeURIComponent "hello world" == Just "hello%20world" --- log $ "encodeURIComponent \"" <> unencodable <> "\" == Nothing" --- assert $ encodeURIComponent unencodable == Nothing - -foreign import unencodable :: String diff --git a/passing/test/Int.purs b/passing/test/Int.purs deleted file mode 100644 index 248eba3..0000000 --- a/passing/test/Int.purs +++ /dev/null @@ -1,182 +0,0 @@ -module Test.Int (testInt) where - -import Prelude - -import Data.Int (binary, ceil, even, floor, fromNumber, fromString, fromStringAs, hexadecimal, octal, odd, parity, pow, quot, radix, rem, round, toNumber, toStringAs) -import Data.Maybe (Maybe(..), fromJust) -import Effect (Effect) -import Effect.Console (log) -import Global (nan, infinity) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) - -testInt :: Effect Unit -testInt = do - - log "fromNumber should coerce integer values" - assert $ fromNumber 1.0 == Just 1 - assert $ fromNumber 42.0 == Just 42 - assert $ fromNumber 0.0 == Just 0 - - log "fromNumber should fail on float inputs" - assert $ fromNumber 0.9 == Nothing - assert $ fromNumber (-0.9) == Nothing - - log "toNumber should coerce any integer to a number" - assert $ toNumber 1 == 1.0 - assert $ toNumber (-1) == -1.0 - assert $ toNumber 0 == 0.0 - - log "round should choose the closest integer" - assert $ round 0.3 == 0 - assert $ round 0.7 == 1 - - log "ceil should round up" - assert $ ceil 0.3 == 1 - assert $ ceil 0.7 == 1 - - log "floor should round down" - assert $ floor 0.3 == 0 - assert $ floor 0.7 == 0 - - log "round, ceil, and floor should clamp values outside the Int range" - let testClamping f = do - let low = toNumber bottom - 1.5 - assert $ f low == bottom - - let high = toNumber top + 1.5 - assert $ f high == top - - testClamping round - testClamping ceil - testClamping floor - - - log "round, ceil, and floor should return 0 for NaN and Infinities" - let testNonNumber f = do - assert $ f nan == 0 - assert $ f infinity == 0 - - testNonNumber round - testNonNumber ceil - testNonNumber floor - - log "fromString should read integers" - assert $ fromString "0" == Just 0 - assert $ fromString "9467" == Just 9467 - assert $ fromString "-6" == Just (-6) - assert $ fromString "+6" == Just 6 - - log "fromString should fail to read floats" - assert $ fromString "0.1" == Nothing - assert $ fromString "42.000000000000001" == Nothing - - log "fromString should fail to read integers outside of the int32 range" - assert $ fromString "2147483648" == Nothing - assert $ fromString "-2147483649" == Nothing - - log "fromString should fail to read strings with other non-integer values" - assert $ fromString "" == Nothing - assert $ fromString "a" == Nothing - assert $ fromString "5a" == Nothing - assert $ fromString "42,12" == Nothing - - log "fromStringAs should read integers in different bases" - assert $ fromStringAs binary "100" == Just 4 - assert $ fromStringAs hexadecimal "100" == Just 256 - assert $ fromStringAs hexadecimal "EF" == Just 239 - assert $ fromStringAs hexadecimal "+ef" == Just 239 - assert $ fromStringAs hexadecimal "-ef" == Just (-239) - assert $ fromStringAs hexadecimal "+7fffffff" == Just 2147483647 - assert $ fromStringAs hexadecimal "-80000000" == Just (-2147483648) - assert $ fromStringAs binary "10" == Just 2 - assert $ fromStringAs (unsafePartial $ fromJust $ radix 3) "10" == Just 3 - assert $ fromStringAs (unsafePartial $ fromJust $ radix 11) "10" == Just 11 - assert $ fromStringAs (unsafePartial $ fromJust $ radix 12) "10" == Just 12 - assert $ fromStringAs (unsafePartial $ fromJust $ radix 36) "10" == Just 36 - - log "fromStringAs should fail on unknown digits" - assert $ fromStringAs binary "12" == Nothing - assert $ fromStringAs octal "8" == Nothing - assert $ fromStringAs hexadecimal "1g" == Nothing - - log "toStringAs should transform to a different base" - assert $ toStringAs hexadecimal 255 == "ff" - assert $ toStringAs binary 4 == "100" - assert $ toStringAs binary (-4) == "-100" - assert $ toStringAs hexadecimal 2147483647 == "7fffffff" - - log "zero is even" - assert $ even 0 == true - - log "even numbers are even" - assert $ even 2 == true - assert $ even 4 == true - assert $ even 100 == true - - log "odd numbers are not even" - assert $ even 1 == false - assert $ even 3 == false - assert $ even 73 == false - - log "zero is not odd" - assert $ odd 0 == false - - log "odd numbers are odd" - assert $ odd 1 == true - assert $ odd 3 == true - assert $ odd 73 == true - - log "even numbers are not odd" - assert $ odd 2 == false - assert $ odd 4 == false - assert $ odd 100 == false - - log "parity is a ring homomorphism" - do - let go x y = do - assert $ parity x + parity y == parity (x + y) - assert $ parity x * parity y == parity (x * y) - - go 0 0 - go 0 1 - go 1 0 - go 1 1 - go 2 28 - go 2 3 - go 3 8 - go 49 171 - - log "quotient/remainder law" - do - let - go a b = - let - q = quot a b - r = rem a b - msg = show a <> " / " <> show b <> ": " - in do - assert $ q * b + r == a - -- Check when dividend goes into divisor exactly - go 8 2 - go (-8) 2 - go 8 (-2) - go (-8) (-2) - - -- Check when dividend does not go into divisor exactly - go 2 3 - go (-2) 3 - go 2 (-3) - go (-2) (-3) - - log "pow" - assert $ pow 2 2 == 4 - assert $ pow 5 3 == 125 - assert $ pow 26 0 == 1 - assert $ pow 0 32 == 0 - assert $ pow 2 (-1) == 0 - assert $ pow 1 (-2) == 1 - assert $ pow 2 (-2) == 0 - assert $ pow (-2) (-2) == 0 - assert $ pow (-2) 2 == 4 - assert $ pow (-2) 3 == (-8) \ No newline at end of file diff --git a/passing/test/Main.purs b/passing/test/Main.purs deleted file mode 100644 index a482637..0000000 --- a/passing/test/Main.purs +++ /dev/null @@ -1,41 +0,0 @@ -module Test.Main where - -import Prelude -import TestCases.Datatypes (testDatatypes) -import TestCases.PatternMaching (testPM) -import TestCases.Records (testRecords) -import Effect (Effect) -import Effect.Class.Console (log) -import Test.Unfoldable (testUnfoldable) -import Test.ST (testST) -import Test.UnsafeCoerce (testUnsafeCoerce) -import Test.Arrays (testArrays) -import Data.Array as A -import Data.Maybe (Maybe(..)) -import Test.OrderedCollections (testOrderedCollections) -import Test.Int (testInt) -import Test.Record (testRecord) -import Test.Globals (testGlobals) -import Global as G -import Global.Unsafe as GU -import Record as R -import Test.PyUtil -import Test.String (testStringAll) -import Test.TestQuickCheck (testQuickCheck) - -main :: Effect Unit -main = do - testDatatypes - testPM - testRecords - testRecord - testUnfoldable - testST - testUnsafeCoerce - testArrays - testInt - testGlobals - testStringAll - testQuickCheck - testOrderedCollections - log "CI tests passing!" diff --git a/passing/test/OrderedCollections/Data/Map.purs b/passing/test/OrderedCollections/Data/Map.purs deleted file mode 100644 index 36fb62e..0000000 --- a/passing/test/OrderedCollections/Data/Map.purs +++ /dev/null @@ -1,452 +0,0 @@ -module Test.OrderedCollections.Data.Map where - -import Prelude -import Control.Alt ((<|>)) -import Data.Array as A -import Data.Foldable (foldl, for_, all, and) -import Data.FoldableWithIndex (foldrWithIndex) -import Data.Function (on) -import Data.FunctorWithIndex (mapWithIndex) -import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:)) -import Data.List.NonEmpty as NEL -import Data.Map as M -import Data.Map.Gen (genMap) -import Data.Maybe (Maybe(..), fromMaybe, maybe) -import Data.NonEmpty ((:|)) -import Data.Tuple (Tuple(..), fst, uncurry) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.QuickCheck ((), (===), quickCheck, quickCheck') -import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary) -import Test.QuickCheck.Gen (elements, oneOf) - -newtype TestMap k v - = TestMap (M.Map k v) - -instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where - arbitrary = TestMap <$> genMap arbitrary arbitrary - -data SmallKey - = A - | B - | C - | D - | E - | F - | G - | H - | I - | J - -derive instance eqSmallKey :: Eq SmallKey - -derive instance ordSmallKey :: Ord SmallKey - -instance showSmallKey :: Show SmallKey where - show A = "A" - show B = "B" - show C = "C" - show D = "D" - show E = "E" - show F = "F" - show G = "G" - show H = "H" - show I = "I" - show J = "J" - -instance arbSmallKey :: Arbitrary SmallKey where - arbitrary = elements $ A :| [ B, C, D, E, F, G, H, I, J ] - -data Instruction k v - = Insert k v - | Delete k - -instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where - show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")" - show (Delete k) = "Delete (" <> show k <> ")" - -instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where - arbitrary = oneOf $ (Insert <$> arbitrary <*> arbitrary) :| [ Delete <$> arbitrary ] - -runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v -runInstructions instrs t0 = foldl step t0 instrs - where - step tree (Insert k v) = M.insert k v tree - - step tree (Delete k) = M.delete k tree - -smallKey :: SmallKey -> SmallKey -smallKey k = k - -number :: Int -> Int -number n = n - -smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int -smallKeyToNumberMap m = m - -mapTests :: Effect Unit -mapTests = do - -- Data.Map - log "Test inserting into empty tree" - quickCheck - $ \k v -> - M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v) - ("k: " <> show k <> ", v: " <> show v) - log "Test inserting two values with same key" - quickCheck - $ \k v1 v2 -> - M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2) - log "Test insertWith combining values" - quickCheck - $ \k v1 v2 -> - M.lookup (smallKey k) (M.insertWith (+) k v2 (M.insert k v1 M.empty)) == Just (number (v1 + v2)) - log "Test insertWith passes the first value as the first argument to the combining function" - quickCheck - $ \k v1 v2 -> - M.lookup (smallKey k) (M.insertWith const k v2 (M.insert k v1 M.empty)) == Just (number v1) - log "Test delete after inserting" - quickCheck - $ \k v -> - M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty)) - ("k: " <> show k <> ", v: " <> show v) - log "Test pop after inserting" - quickCheck - $ \k v -> - M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty) - ("k: " <> show k <> ", v: " <> show v) - log "Pop non-existent key" - quickCheck - $ \k1 k2 v -> - ((k1 == k2) || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing) - ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v) - log "Insert two, lookup first" - quickCheck - $ \k1 v1 k2 v2 -> - ((k1 == k2) || (M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1)) - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - log "Insert two, lookup second" - quickCheck - $ \k1 v1 k2 v2 -> - M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2 - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - log "Insert two, delete one" - quickCheck - $ \k1 v1 k2 v2 -> - (k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2) - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - log "Check balance property" - quickCheck' 1000 - $ \instrs -> - let - tree :: M.Map SmallKey Int - tree = runInstructions instrs M.empty - in - M.checkValid tree ("Map not balanced:\n " <> show tree <> "\nGenerated by:\n " <> show instrs) - log "Lookup from empty" - quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing - log "Lookup from singleton" - quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v - log "Random lookup" - quickCheck' 1000 - $ \instrs k v -> - let - tree :: M.Map SmallKey Int - tree = M.insert k v (runInstructions instrs M.empty) - in - M.lookup k tree == Just v ("instrs:\n " <> show instrs <> "\nk:\n " <> show k <> "\nv:\n " <> show v) - log "Singleton to list" - quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v) - log "fromFoldable [] = empty" - quickCheck - ( M.fromFoldable [] == (M.empty :: M.Map Unit Unit) - "was not empty" - ) - log "fromFoldable & key collision" - do - let - nums = M.fromFoldable [ Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one" ] - quickCheck (M.lookup 0 nums == Just "zero" "invalid lookup - 0") - quickCheck (M.lookup 1 nums == Just "one" "invalid lookup - 1") - quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") - log "fromFoldableWith const [] = empty" - quickCheck - ( M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit) - "was not empty" - ) - log "fromFoldableWith (+) & key collision" - do - let - nums = M.fromFoldableWith (+) [ Tuple 0 1, Tuple 1 1, Tuple 1 1 ] - quickCheck (M.lookup 0 nums == Just 1 "invalid lookup - 0") - quickCheck (M.lookup 1 nums == Just 2 "invalid lookup - 1") - quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") - log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)" - quickCheck - $ \(list :: List (Tuple SmallKey Int)) -> - let - nubbedList = nubBy ((==) `on` fst) list - - f x = M.toUnfoldable (M.fromFoldable x) - in - sort (f nubbedList) == sort nubbedList show nubbedList - log "fromFoldable . toUnfoldable = id" - quickCheck - $ \(TestMap (m :: M.Map SmallKey Int)) -> - let - f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int)) - in - f m == m show m - log "fromFoldableWith const = fromFoldable" - quickCheck - $ \arr -> - M.fromFoldableWith const arr - == M.fromFoldable (arr :: List (Tuple SmallKey Int)) - show arr - log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst" - quickCheck - $ \arr -> - let - combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a) - - foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs - - f = - M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) - <<< groupBy ((==) `on` fst) - <<< sortBy (compare `on` fst) - in - M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String)) - log "toUnfoldable is sorted" - quickCheck - $ \(TestMap m) -> - let - list = M.toUnfoldable (m :: M.Map SmallKey Int) - - ascList = M.toUnfoldable m - in - ascList === sortBy (compare `on` fst) list - log "Lookup from union" - quickCheck - $ \(TestMap m1) (TestMap m2) k -> - M.lookup (smallKey k) (M.union m1 m2) - == ( case M.lookup k m1 of - Nothing -> M.lookup k m2 - Just v -> Just (number v) - ) - ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2)) - log "Union is idempotent" - quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int)) - log "Union prefers left" - quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2) - log "unionWith" - for_ [ Tuple (+) 0, Tuple (*) 1 ] - $ \(Tuple op ident) -> - quickCheck - $ \(TestMap m1) (TestMap m2) k -> - let - u = M.unionWith op m1 m2 :: M.Map SmallKey Int - in - case M.lookup k u of - Nothing -> not (M.member k m1 || M.member k m2) - Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2)) - log "unionWith argument order" - quickCheck - $ \(TestMap m1) (TestMap m2) k -> - let - u = M.unionWith (-) m1 m2 :: M.Map SmallKey Int - - in1 = M.member k m1 - - v1 = M.lookup k m1 - - in2 = M.member k m2 - - v2 = M.lookup k m2 - in - case M.lookup k u of - Just v - | in1 && in2 -> Just v == ((-) <$> v1 <*> v2) - Just v - | in1 -> Just v == v1 - Just v -> Just v == v2 - Nothing -> not (in1 || in2) - log "Lookup from intersection" - quickCheck - $ \(TestMap m1) (TestMap m2) k -> - M.lookup (smallKey k) (M.intersection (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey Int)) - == ( case M.lookup k m2 of - Nothing -> Nothing - Just v -> M.lookup k m1 - ) - ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", intersection: " <> show (M.intersection m1 m2)) - log "Intersection is idempotent" - quickCheck $ \(TestMap m1) (TestMap m2) -> ((m1 :: M.Map SmallKey Int) `M.intersection` m2) == ((m1 `M.intersection` m2) `M.intersection` (m2 :: M.Map SmallKey Int)) - log "intersectionWith" - for_ [ (+), (*) ] - $ \op -> - quickCheck - $ \(TestMap m1) (TestMap m2) k -> - let - u = M.intersectionWith op m1 m2 :: M.Map SmallKey Int - in - case M.lookup k u of - Nothing -> not (M.member k m1 && M.member k m2) - Just v -> Just v == (op <$> M.lookup k m1 <*> M.lookup k m2) - log "difference" - quickCheck - $ \(TestMap m1) (TestMap m2) -> - let - d = M.difference (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey String) - in - and (map (\k -> M.member k m1) (A.fromFoldable $ M.keys d)) - && and (map (\k -> not $ M.member k d) (A.fromFoldable $ M.keys m2)) - log "size" - quickCheck - $ \xs -> - let - xs' = nubBy ((==) `on` fst) xs - in - M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int)) - log "lookupLE result is correct" - quickCheck - $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of - Nothing -> all (_ > k) $ M.keys m - Just { key: k1, value: v } -> - let - isCloserKey k2 = k1 < k2 && k2 < k - - isLTwhenEQexists = k1 < k && M.member k m - in - k1 <= k - && all (not <<< isCloserKey) (M.keys m) - && not isLTwhenEQexists - && M.lookup k1 m - == Just v - log "lookupGE result is correct" - quickCheck - $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of - Nothing -> all (_ < k) $ M.keys m - Just { key: k1, value: v } -> - let - isCloserKey k2 = k < k2 && k2 < k1 - - isGTwhenEQexists = k < k1 && M.member k m - in - k1 >= k - && all (not <<< isCloserKey) (M.keys m) - && not isGTwhenEQexists - && M.lookup k1 m - == Just v - log "lookupLT result is correct" - quickCheck - $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of - Nothing -> all (_ >= k) $ M.keys m - Just { key: k1, value: v } -> - let - isCloserKey k2 = k1 < k2 && k2 < k - in - k1 < k - && all (not <<< isCloserKey) (M.keys m) - && M.lookup k1 m - == Just v - log "lookupGT result is correct" - quickCheck - $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of - Nothing -> all (_ <= k) $ M.keys m - Just { key: k1, value: v } -> - let - isCloserKey k2 = k < k2 && k2 < k1 - in - k1 > k - && all (not <<< isCloserKey) (M.keys m) - && M.lookup k1 m - == Just v - log "findMin result is correct" - quickCheck - $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of - Nothing -> M.isEmpty m - Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m) - log "findMax result is correct" - quickCheck - $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of - Nothing -> M.isEmpty m - Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m) - log "mapWithKey is correct" - quickCheck - $ \(TestMap m :: TestMap String Int) -> - let - f k v = k <> show v - - resultViaMapWithKey = m # mapWithIndex f - - toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v) - - resultViaLists = m # toList # map (\(Tuple k v) โ†’ Tuple k (f k v)) # M.fromFoldable - in - resultViaMapWithKey === resultViaLists - log "filterWithKey gives submap" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filterWithKey p s) s - log "filterWithKey keeps those keys for which predicate is true" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - A.all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) - log "filterKeys gives submap" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filterKeys p s) s - log "filterKeys keeps those keys for which predicate is true" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.keys (M.filterKeys p s)) - log "filter gives submap" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filter p s) s - log "filter keeps those values for which predicate is true" - quickCheck - $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.values (M.filter p s)) - log "submap with no bounds = id" - quickCheck \(TestMap m :: TestMap SmallKey Int) -> - M.submap Nothing Nothing m === m - log "submap with lower bound" - quickCheck' 1 - $ M.submap (Just B) Nothing (M.fromFoldable [ Tuple A 0, Tuple B 0 ]) - == M.fromFoldable [ Tuple B 0 ] - log "submap with upper bound" - quickCheck' 1 - $ M.submap Nothing (Just A) (M.fromFoldable [ Tuple A 0, Tuple B 0 ]) - == M.fromFoldable [ Tuple A 0 ] - log "submap with lower & upper bound" - quickCheck' 1 - $ M.submap (Just B) (Just B) (M.fromFoldable [ Tuple A 0, Tuple B 0, Tuple C 0 ]) - == M.fromFoldable [ Tuple B 0 ] - log "submap" - quickCheck' 1000 \(TestMap m :: TestMap SmallKey Int) mmin mmax key -> - let - m' = M.submap mmin mmax m - in - ( if ( maybe true (\min -> min <= key) mmin - && maybe true (\max -> max >= key) mmax - ) then - M.lookup key m == M.lookup key m' - else - (not (M.member key m')) - ) - "m: " - <> show m - <> ", mmin: " - <> show mmin - <> ", mmax: " - <> show mmax - <> ", key: " - <> show key - log "foldrWithIndex maintains order" - quickCheck \(TestMap m :: TestMap Int Int) -> - let - outList = foldrWithIndex (\i a b -> (Tuple i a) : b) Nil m - in - outList == sort outList diff --git a/passing/test/OrderedCollections/Data/Set.purs b/passing/test/OrderedCollections/Data/Set.purs deleted file mode 100644 index 5b07e40..0000000 --- a/passing/test/OrderedCollections/Data/Set.purs +++ /dev/null @@ -1,30 +0,0 @@ -module Test.OrderedCollections.Data.Set where - -import Prelude -import Data.Set (Set) -import Data.Set as S -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert) - -setTests :: Effect Unit -setTests = do - log "fromFoldable - empty" - assert $ S.fromFoldable [] == (S.empty :: Set Unit) - log "fromFoldable - non empty" - do - let - set = S.fromFoldable [ 0, 1, 1, 2 ] - assert $ S.size set == 3 - assert $ S.member 0 set - assert $ S.member 1 set - assert $ S.member 2 set - log "intersection" - do - let - s1 = S.fromFoldable [ 1, 2, 3, 4, 5 ] - - s2 = S.fromFoldable [ 2, 4, 6, 8, 10 ] - - s3 = S.fromFoldable [ 2, 4 ] - assert $ S.intersection s1 s2 == s3 diff --git a/passing/test/OrderedCollections/OrderedCollections.purs b/passing/test/OrderedCollections/OrderedCollections.purs deleted file mode 100644 index c331922..0000000 --- a/passing/test/OrderedCollections/OrderedCollections.purs +++ /dev/null @@ -1,14 +0,0 @@ -module Test.OrderedCollections where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Test.OrderedCollections.Data.Map (mapTests) -import Test.OrderedCollections.Data.Set (setTests) - -testOrderedCollections :: Effect Unit -testOrderedCollections = do - log "Running Map tests" - mapTests - log "Running Set tests" - setTests diff --git a/passing/test/PyUtil/PyUtil.purs b/passing/test/PyUtil/PyUtil.purs deleted file mode 100644 index ed609d0..0000000 --- a/passing/test/PyUtil/PyUtil.purs +++ /dev/null @@ -1,8 +0,0 @@ -module Test.PyUtil where - -import Prelude -import Effect (Effect) - -foreign import setrecursionlimit :: Int -> Effect Unit -foreign import getrecursionlimit :: Effect Int -foreign import direct_print :: forall a. a -> Effect Unit \ No newline at end of file diff --git a/passing/test/QuickCheck.purs b/passing/test/QuickCheck.purs deleted file mode 100644 index d00f6c3..0000000 --- a/passing/test/QuickCheck.purs +++ /dev/null @@ -1,93 +0,0 @@ -module Test.TestQuickCheck where - -import Prelude -import Effect (Effect) -import Effect.Console (log, logShow) -import Effect.Exception (try) -import Control.Monad.Gen.Class as MGen -import Data.Array.Partial (head) -import Data.Either (isLeft) -import Data.Foldable (sum) -import Data.Generic.Rep (class Generic) -import Data.Generic.Rep.Show (genericShow) -import Data.Tuple (fst) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert) -import Test.QuickCheck (class Testable, quickCheck, (/=?), (<=?), (=?), (>?)) -import Test.QuickCheck.Arbitrary (arbitrary, genericArbitrary, class Arbitrary) -import Test.QuickCheck.Gen (Gen, vectorOf, randomSample', resize, Size, runGen, sized) -import Random.LCG (mkSeed) - -data Foo a - = F0 a - | F1 a a - | F2 { foo :: a, bar :: Array a } - -derive instance genericFoo :: Generic (Foo a) _ - -instance showFoo :: Show a => Show (Foo a) where - show = genericShow - -instance arbitraryFoo :: Arbitrary a => Arbitrary (Foo a) where - arbitrary = genericArbitrary - -quickCheckFail :: forall t. Testable t => t -> Effect Unit -quickCheckFail = assert <=< map isLeft <<< try <<< quickCheck - -testResize :: (forall a. Size -> Gen a -> Gen a) -> Boolean -testResize resize' = - let - initialSize = 2 - - gen = do - s1 <- sized pure - s2 <- resize' 1 (sized pure) - s3 <- sized pure - pure $ [ s1, s2, s3 ] == [ initialSize, 1, initialSize ] - in - fst $ runGen gen { newSeed: mkSeed 0, size: initialSize } - -testQuickCheck :: Effect Unit -testQuickCheck = do - log "MonadGen.resize" - assert (testResize (MGen.resize <<< const)) - log "Gen.resize" - assert (testResize (resize)) - log "Try with some little Gens first" - logShow =<< go 10 - logShow =<< go 100 - logShow =<< go 1000 - logShow =<< go 10000 - log "Testing stack safety of Gen" - logShow =<< go 20000 - logShow =<< go 100000 - log "Generating via Generic" - logShow =<< randomSample' 10 (arbitrary :: Gen (Foo Int)) - log "Arbitrary instance for records" - listOfRecords โ† randomSample' 10 (arbitrary :: Gen { foo :: Int, nested :: { bar :: Boolean } }) - let - toString rec = "{ foo: " <> show rec.foo <> "; nested.bar: " <> show rec.nested.bar <> " }" - logShow (toString <$> listOfRecords) - quickCheck \(x :: Int) -> x x <=? x + 1 - quickCheck \(x :: Int) -> x >=? x - 1 - quickCheck \(x :: Int) -> x >? x - 1 - quickCheck \(x :: Int) -> x + x ==? x * 2 - quickCheck \(x :: Int) -> x + x /=? x * 3 - quickCheck $ 1 ==? 1 - quickCheckFail $ 1 /=? 1 - quickCheck $ 1 =? 2 - quickCheck $ 3 <=? 3 - quickCheckFail $ 3 >? 3 - quickCheck $ 3 >=? 3 - quickCheckFail $ 3 ? 3 - quickCheckFail $ 4 <=? 3 - where - go n = map (sum <<< unsafeHead) $ randomSample' 1 (vectorOf n (arbitrary :: Gen Int)) - - unsafeHead :: forall x. Array x -> x - unsafeHead xs = unsafePartial (head xs) diff --git a/passing/test/Record.purs b/passing/test/Record.purs deleted file mode 100644 index cb08f37..0000000 --- a/passing/test/Record.purs +++ /dev/null @@ -1,84 +0,0 @@ -module Test.Record (testRecord) where - -import Prelude -import Effect (Effect) -import Data.Record (delete, equal, get, insert, merge, modify, rename, set) -import Data.Record.Builder as Builder -import Control.Monad.ST (run) as ST -import Data.Record.ST (poke, thaw, freeze, modify) as ST -import Data.Record.Unsafe (unsafeHas) -import Data.Symbol (SProxy(..)) -import Test.Assert (assert') - -testRecord :: Effect Unit -testRecord = do - let - x = SProxy :: SProxy "x" - - y = SProxy :: SProxy "y" - - z = SProxy :: SProxy "z" - assert' "insert, get" - $ get x (insert x 42 {}) - == 42 - assert' "insert, modify, get" - $ get x (modify x (_ + 1) (insert x 42 {})) - == 43 - assert' "set, get" - $ get x (set x 0 { x: 42 }) - == 0 - assert' "set, modify, get" - $ get x (modify x (_ + 1) (set x 0 { x: 42 })) - == 1 - assert' "delete, get" - $ get x (delete y { x: 42, y: 1337 }) - == 42 - assert' "rename" - $ get y (rename x y { x: 42 }) - == 42 - assert' "equal" - $ equal { a: 1, b: "b", c: true } { a: 1, b: "b", c: true } - assert' "equal2" - $ not - $ equal { a: 1, b: "b", c: true } { a: 1, b: "b", c: false } - assert' "merge" - $ equal { x: 1, y: "y" } (merge { y: "y" } { x: 1, y: 2 }) - assert' "unsafeHas1" - $ unsafeHas "a" { a: 42 } - assert' "unsafeHas2" - $ not - $ unsafeHas "b" { a: 42 } - let - stTest1 = - ST.run do - rec <- ST.thaw { x: 41, y: "" } - ST.poke x 42 rec - ST.poke y "testing" rec - ST.freeze rec - - stTest2 = - ST.run do - rec <- ST.thaw { x: 41 } - ST.modify x (_ + 1) rec - ST.freeze rec - assert' "pokeSTRecord" - $ stTest1.x - == 42 - && stTest1.y - == "testing" - assert' "ST.modify" $ stTest2.x == 42 - let - testBuilder = - Builder.build - ( Builder.insert x 42 - >>> Builder.merge { y: true, z: "testing" } - >>> Builder.delete y - >>> Builder.modify x show - >>> Builder.rename z y - ) - {} - assert' "Record.Builder" - $ testBuilder.x - == "42" - && testBuilder.y - == "testing" diff --git a/passing/test/ST.purs b/passing/test/ST.purs deleted file mode 100644 index e0194b0..0000000 --- a/passing/test/ST.purs +++ /dev/null @@ -1,23 +0,0 @@ -module Test.ST where - -import Prelude -import Effect (Effect) -import Effect.Console (logShow) -import Control.Monad.ST as ST -import Control.Monad.ST.Ref as STRef - -sumOfSquares :: Int -sumOfSquares = - ST.run do - total <- STRef.new 0 - let - loop 0 = STRef.read total - - loop n = do - _ <- STRef.modify (_ + (n * n)) total - loop (n - 1) - loop 100 - -testST :: Effect Unit -testST = do - logShow sumOfSquares diff --git a/passing/test/String/Test/Data/String.purs b/passing/test/String/Test/Data/String.purs deleted file mode 100644 index c496798..0000000 --- a/passing/test/String/Test/Data/String.purs +++ /dev/null @@ -1,141 +0,0 @@ -module Test.Data.String (testString) where - -import Prelude - -import Data.Maybe (Maybe(..)) -import Data.String as S -import Data.String.Pattern (Pattern(..), Replacement(..)) -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert, assertEqual) - -testString :: Effect Unit -testString = do - - log "null" - assert $ S.null "" - assert $ not (S.null "a") - - log "stripPrefix" - assertEqual - { actual: S.stripPrefix (Pattern "") "" - , expected: Just "" - } - assertEqual - { actual: S.stripPrefix (Pattern "") "abc" - , expected: Just "abc" - } - assertEqual - { actual: S.stripPrefix (Pattern "a") "abc" - , expected: Just "bc" - } - assertEqual - { actual: S.stripPrefix (Pattern "!") "abc" - , expected: Nothing - } - assertEqual - { actual: S.stripPrefix (Pattern "!") "" - , expected: Nothing - } - - log "contains" - assert $ S.contains (Pattern "") "" - assert $ S.contains (Pattern "") "abcd" - assert $ S.contains (Pattern "bc") "abcd" - assert $ not S.contains (Pattern "cb") "abcd" - - log "localeCompare" - assertEqual - { actual: S.localeCompare "" "" - , expected: EQ - } - assertEqual - { actual: S.localeCompare "a" "a" - , expected: EQ - } - assertEqual - { actual: S.localeCompare "a" "b" - , expected: LT - } - assertEqual - { actual: S.localeCompare "b" "a" - , expected: GT - } - - log "replace" - assertEqual - { actual: S.replace (Pattern "b") (Replacement "") "abc" - , expected: "ac" - } - assertEqual - { actual: S.replace (Pattern "b") (Replacement "!") "abc" - , expected: "a!c" - } - assertEqual - { actual: S.replace (Pattern "d") (Replacement "!") "abc" - , expected: "abc" - } - - log "replaceAll" - assertEqual - { actual: S.replaceAll (Pattern "b") (Replacement "") "abbbbbc" - , expected: "ac" - } - assertEqual - { actual: S.replaceAll (Pattern "[b]") (Replacement "!") "a[b]c" - , expected: "a!c" - } - - log "split" - assertEqual - { actual: S.split (Pattern "") "" - , expected: [] - } - assertEqual - { actual: S.split (Pattern "") "a" - , expected: ["a"] - } - assertEqual - { actual: S.split (Pattern "") "ab" - , expected: ["a", "b"] - } - assertEqual - { actual: S.split (Pattern "b") "aabcc" - , expected: ["aa", "cc"] - } - assertEqual - { actual: S.split (Pattern "d") "abc" - , expected: ["abc"] - } - - log "toLower" - assertEqual - { actual: S.toLower "bAtMaN" - , expected: "batman" - } - - log "toUpper" - assertEqual - { actual: S.toUpper "bAtMaN" - , expected: "BATMAN" - } - - log "trim" - assertEqual - { actual: S.trim " abc " - , expected: "abc" - } - - log "joinWith" - assertEqual - { actual: S.joinWith "" [] - , expected: "" - } - assertEqual - { actual: S.joinWith "" ["a", "b"] - , expected: "ab" - } - assertEqual - { actual: S.joinWith "--" ["a", "b", "c"] - , expected: "a--b--c" - } diff --git a/passing/test/String/Test/Data/String/CaseInsensitive.purs b/passing/test/String/Test/Data/String/CaseInsensitive.purs deleted file mode 100644 index a263732..0000000 --- a/passing/test/String/Test/Data/String/CaseInsensitive.purs +++ /dev/null @@ -1,22 +0,0 @@ -module Test.Data.String.CaseInsensitive (testCaseInsensitiveString) where - -import Prelude - -import Data.String.CaseInsensitive (CaseInsensitiveString(..)) -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assertEqual) - -testCaseInsensitiveString :: Effect Unit -testCaseInsensitiveString = do - log "equality" - assertEqual - { actual: CaseInsensitiveString "aB" - , expected: CaseInsensitiveString "AB" - } - - log "comparison" - assertEqual - { actual: compare (CaseInsensitiveString "qwerty") (CaseInsensitiveString "QWERTY") - , expected: EQ - } diff --git a/passing/test/String/Test/Data/String/CodePoints.purs b/passing/test/String/Test/Data/String/CodePoints.purs deleted file mode 100644 index 310321b..0000000 --- a/passing/test/String/Test/Data/String/CodePoints.purs +++ /dev/null @@ -1,645 +0,0 @@ -module Test.Data.String.CodePoints (testStringCodePoints) where - -import Prelude - -import Data.Enum (fromEnum, toEnum) -import Data.Maybe (Maybe(..), fromJust) -import Data.String.CodePoints as SCP -import Data.String.Pattern (Pattern(..)) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assertEqual) - -str :: String -str = "a\xDC00\xD800\xD800\x16805\x16A06z" - -testStringCodePoints :: Effect Unit -testStringCodePoints = do - - log "show" - assertEqual - { actual: map show (SCP.codePointAt 0 str) - , expected: Just "(CodePoint 0x61)" - } - assertEqual - { actual: map show (SCP.codePointAt 1 str) - , expected: Just "(CodePoint 0xDC00)" - } - assertEqual - { actual: map show (SCP.codePointAt 2 str) - , expected: Just "(CodePoint 0xD800)" - } - assertEqual - { actual: map show (SCP.codePointAt 3 str) - , expected: Just "(CodePoint 0xD800)" - } - assertEqual - { actual: map show (SCP.codePointAt 4 str) - , expected: Just "(CodePoint 0x16805)" - } - assertEqual - { actual: map show (SCP.codePointAt 5 str) - , expected: Just "(CodePoint 0x16A06)" - } - assertEqual - { actual: map show (SCP.codePointAt 6 str) - , expected: Just "(CodePoint 0x7A)" - } - - log "codePointFromChar" - assertEqual - { actual: Just (SCP.codePointFromChar 'A') - , expected: (toEnum 65) - } - assertEqual - { actual: (SCP.codePointFromChar <$> toEnum 0) - , expected: toEnum 0 - } - assertEqual - { actual: (SCP.codePointFromChar <$> toEnum 0xFFFF) - , expected: toEnum 0xFFFF - } - - log "singleton" - assertEqual - { actual: (SCP.singleton <$> toEnum 0x30) - , expected: Just "0" - } - assertEqual - { actual: (SCP.singleton <$> toEnum 0x16805) - , expected: Just "\x16805" - } - - log "codePointAt" - assertEqual - { actual: SCP.codePointAt (-1) str - , expected: Nothing - } - assertEqual - { actual: SCP.codePointAt 0 str - , expected: (toEnum 0x61) - } - assertEqual - { actual: SCP.codePointAt 1 str - , expected: (toEnum 0xDC00) - } - assertEqual - { actual: SCP.codePointAt 2 str - , expected: (toEnum 0xD800) - } - assertEqual - { actual: SCP.codePointAt 3 str - , expected: (toEnum 0xD800) - } - assertEqual - { actual: SCP.codePointAt 4 str - , expected: (toEnum 0x16805) - } - assertEqual - { actual: SCP.codePointAt 5 str - , expected: (toEnum 0x16A06) - } - assertEqual - { actual: SCP.codePointAt 6 str - , expected: (toEnum 0x7A) - } - assertEqual - { actual: SCP.codePointAt 7 str - , expected: Nothing - } - - log "uncons" - assertEqual - { actual: SCP.uncons str - , expected: Just {head: cp 0x61, tail: "\xDC00\xD800\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 1 str) - , expected: Just {head: cp 0xDC00, tail: "\xD800\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 2 str) - , expected: Just {head: cp 0xD800, tail: "\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 3 str) - , expected: Just {head: cp 0xD800, tail: "\x16805\x16A06z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 4 str) - , expected: Just {head: cp 0x16805, tail: "\x16A06z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 5 str) - , expected: Just {head: cp 0x16A06, tail: "z"} - } - assertEqual - { actual: SCP.uncons (SCP.drop 6 str) - , expected: Just {head: cp 0x7A, tail: ""} - } - assertEqual - { actual: SCP.uncons "" - , expected: Nothing - } - - log "length" - assertEqual - { actual: SCP.length "" - , expected: 0 - } - assertEqual - { actual: SCP.length "a" - , expected: 1 - } - assertEqual - { actual: SCP.length "ab" - , expected: 2 - } - assertEqual - { actual: SCP.length str - , expected: 7 - } - - log "countPrefix" - assertEqual - { actual: SCP.countPrefix (\_ -> true) "" - , expected: 0 - } - assertEqual - { actual: SCP.countPrefix (\_ -> false) str - , expected: 0 - } - assertEqual - { actual: SCP.countPrefix (\_ -> true) str - , expected: 7 - } - assertEqual - { actual: SCP.countPrefix (\x -> fromEnum x < 0xFFFF) str - , expected: 4 - } - assertEqual - { actual: SCP.countPrefix (\x -> fromEnum x < 0xDC00) str - , expected: 1 - } - - log "indexOf" - assertEqual - { actual: SCP.indexOf (Pattern "") "" - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf (Pattern "") str - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf (Pattern str) str - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf (Pattern "a") str - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf (Pattern "\xDC00\xD800\xD800") str - , expected: Just 1 - } - assertEqual - { actual: SCP.indexOf (Pattern "\xD800") str - , expected: Just 2 - } - assertEqual - { actual: SCP.indexOf (Pattern "\xD800\xD800") str - , expected: Just 2 - } - assertEqual - { actual: SCP.indexOf (Pattern "\xD800\xD81A") str - , expected: Just 3 - } - assertEqual - { actual: SCP.indexOf (Pattern "\xD800\x16805") str - , expected: Just 3 - } - assertEqual - { actual: SCP.indexOf (Pattern "\x16805") str - , expected: Just 4 - } - assertEqual - { actual: SCP.indexOf (Pattern "\x16A06") str - , expected: Just 5 - } - assertEqual - { actual: SCP.indexOf (Pattern "z") str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf (Pattern "\n") str - , expected: Nothing - } - assertEqual - { actual: SCP.indexOf (Pattern "\xD81A") str - , expected: Just 4 - } - - log "indexOf'" - assertEqual - { actual: SCP.indexOf' (Pattern "") 0 "" - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf' (Pattern str) 0 str - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf' (Pattern str) 1 str - , expected: Nothing - } - assertEqual - { actual: SCP.indexOf' (Pattern "a") 0 str - , expected: Just 0 - } - assertEqual - { actual: SCP.indexOf' (Pattern "a") 1 str - , expected: Nothing - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 0 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 1 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 2 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 3 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 4 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 5 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 6 str - , expected: Just 6 - } - assertEqual - { actual: SCP.indexOf' (Pattern "z") 7 str - , expected: Nothing - } - - log "lastIndexOf" - assertEqual - { actual: SCP.lastIndexOf (Pattern "") "" - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "") str - , expected: Just 7 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern str) str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "a") str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xDC00\xD800\xD800") str - , expected: Just 1 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xD800") str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xD800\xD800") str - , expected: Just 2 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xD800\xD81A") str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xD800\x16805") str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\x16805") str - , expected: Just 4 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\x16A06") str - , expected: Just 5 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "z") str - , expected: Just 6 - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\n") str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf (Pattern "\xD81A") str - , expected: Just 5 - } - - log "lastIndexOf'" - assertEqual - { actual: SCP.lastIndexOf' (Pattern "") 0 "" - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern str) 0 str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern str) 1 str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "a") 0 str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "a") 7 str - , expected: Just 0 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 0 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 1 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 2 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 3 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 4 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 5 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 6 str - , expected: Just 6 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "z") 7 str - , expected: Just 6 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 7 str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 6 str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 5 str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 4 str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 3 str - , expected: Just 3 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 2 str - , expected: Just 2 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 1 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\xD800") 0 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\x16A06") 7 str - , expected: Just 5 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\x16A06") 6 str - , expected: Just 5 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\x16A06") 5 str - , expected: Just 5 - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\x16A06") 4 str - , expected: Nothing - } - assertEqual - { actual: SCP.lastIndexOf' (Pattern "\x16A06") 3 str - , expected: Nothing - } - - log "take" - assertEqual - { actual: SCP.take (-1) str - , expected: "" - } - assertEqual - { actual: SCP.take 0 str - , expected: "" - } - assertEqual - { actual: SCP.take 1 str - , expected: "a" - } - assertEqual - { actual: SCP.take 2 str - , expected: "a\xDC00" - } - assertEqual - { actual: SCP.take 3 str - , expected: "a\xDC00\xD800" - } - assertEqual - { actual: SCP.take 4 str - , expected: "a\xDC00\xD800\xD800" - } - assertEqual - { actual: SCP.take 5 str - , expected: "a\xDC00\xD800\xD800\x16805" - } - assertEqual - { actual: SCP.take 6 str - , expected: "a\xDC00\xD800\xD800\x16805\x16A06" - } - assertEqual - { actual: SCP.take 7 str - , expected: str - } - assertEqual - { actual: SCP.take 8 str - , expected: str - } - - log "takeWhile" - assertEqual - { actual: SCP.takeWhile (\_ -> true) str - , expected: str - } - assertEqual - { actual: SCP.takeWhile (\_ -> false) str - , expected: "" - } - assertEqual - { actual: SCP.takeWhile (\c -> fromEnum c < 0xFFFF) str - , expected: "a\xDC00\xD800\xD800" - } - assertEqual - { actual: SCP.takeWhile (\c -> fromEnum c < 0xDC00) str - , expected: "a" - } - - log "drop" - assertEqual - { actual: SCP.drop (-1) str - , expected: str - } - assertEqual - { actual: SCP.drop 0 str - , expected: str - } - assertEqual - { actual: SCP.drop 1 str - , expected: "\xDC00\xD800\xD800\x16805\x16A06z" - } - assertEqual - { actual: SCP.drop 2 str - , expected: "\xD800\xD800\x16805\x16A06z" - } - assertEqual - { actual: SCP.drop 3 str - , expected: "\xD800\x16805\x16A06z" - } - assertEqual - { actual: SCP.drop 4 str - , expected: "\x16805\x16A06z" - } - assertEqual - { actual: SCP.drop 5 str - , expected: "\x16A06z" - } - assertEqual - { actual: SCP.drop 6 str - , expected: "z" - } - assertEqual - { actual: SCP.drop 7 str - , expected: "" - } - assertEqual - { actual: SCP.drop 8 str - , expected: "" - } - - log "dropWhile" - assertEqual - { actual: SCP.dropWhile (\_ -> true) str - , expected: "" - } - assertEqual - { actual: SCP.dropWhile (\_ -> false) str - , expected: str - } - assertEqual - { actual: SCP.dropWhile (\c -> fromEnum c < 0xFFFF) str - , expected: "\x16805\x16A06z" - } - assertEqual - { actual: SCP.dropWhile (\c -> fromEnum c < 0xDC00) str - , expected: "\xDC00\xD800\xD800\x16805\x16A06z" - } - - log "splitAt" - assertEqual - { actual: SCP.splitAt 0 "" - , expected: {before: "", after: "" } - } - assertEqual - { actual: SCP.splitAt 1 "" - , expected: {before: "", after: "" } - } - assertEqual - { actual: SCP.splitAt 0 "a" - , expected: {before: "", after: "a"} - } - assertEqual - { actual: SCP.splitAt 1 "ab" - , expected: {before: "a", after: "b"} - } - assertEqual - { actual: SCP.splitAt 3 "aabcc" - , expected: {before: "aab", after: "cc"} - } - assertEqual - { actual: SCP.splitAt (-1) "abc" - , expected: {before: "", after: "abc"} - } - assertEqual - { actual: SCP.splitAt 0 str - , expected: {before: "", after: str} - } - assertEqual - { actual: SCP.splitAt 1 str - , expected: {before: "a", after: "\xDC00\xD800\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.splitAt 2 str - , expected: {before: "a\xDC00", after: "\xD800\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.splitAt 3 str - , expected: {before: "a\xDC00\xD800", after: "\xD800\x16805\x16A06z"} - } - assertEqual - { actual: SCP.splitAt 4 str - , expected: {before: "a\xDC00\xD800\xD800", after: "\x16805\x16A06z"} - } - assertEqual - { actual: SCP.splitAt 5 str - , expected: {before: "a\xDC00\xD800\xD800\x16805", after: "\x16A06z"} - } - assertEqual - { actual: SCP.splitAt 6 str - , expected: {before: "a\xDC00\xD800\xD800\x16805\x16A06", after: "z"} - } - assertEqual - { actual: SCP.splitAt 7 str - , expected: {before: str, after: ""} - } - assertEqual - { actual: SCP.splitAt 8 str - , expected: {before: str, after: ""} - } - -cp :: Int -> SCP.CodePoint -cp = unsafePartial fromJust <<< toEnum diff --git a/passing/test/String/Test/Data/String/CodeUnits.purs b/passing/test/String/Test/Data/String/CodeUnits.purs deleted file mode 100644 index af93712..0000000 --- a/passing/test/String/Test/Data/String/CodeUnits.purs +++ /dev/null @@ -1,461 +0,0 @@ -module Test.Data.String.CodeUnits (testStringCodeUnits) where - -import Prelude - -import Data.Enum (fromEnum) -import Data.Maybe (Maybe(..), isNothing) -import Data.String.CodeUnits as SCU -import Data.String.Pattern (Pattern(..)) -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert, assertEqual) - -testStringCodeUnits :: Effect Unit -testStringCodeUnits = do - log "charAt" - assertEqual - { actual: SCU.charAt 0 "" - , expected: Nothing - } - assertEqual - { actual: SCU.charAt 0 "a" - , expected: Just 'a' - } - assertEqual - { actual: SCU.charAt 1 "a" - , expected: Nothing - } - assertEqual - { actual: SCU.charAt 0 "ab" - , expected: Just 'a' - } - assertEqual - { actual: SCU.charAt 1 "ab" - , expected: Just 'b' - } - assertEqual - { actual: SCU.charAt 2 "ab" - , expected: Nothing - } - - log "singleton" - assertEqual - { actual: SCU.singleton 'a' - , expected: "a" - } - - log "charCodeAt" - assertEqual - { actual: (fromEnum <$> SCU.charAt 0 "") - , expected: Nothing - } - assertEqual - { actual: (fromEnum <$> SCU.charAt 0 "a") - , expected: Just 97 - } - assertEqual - { actual: (fromEnum <$> SCU.charAt 1 "a") - , expected: Nothing - } - assertEqual - { actual: (fromEnum <$> SCU.charAt 0 "ab") - , expected: Just 97 - } - assertEqual - { actual: (fromEnum <$> SCU.charAt 1 "ab") - , expected: Just 98 - } - assertEqual - { actual: (fromEnum <$> SCU.charAt 2 "ab") - , expected: Nothing - } - - log "toChar" - assertEqual - { actual: SCU.toChar "" - , expected: Nothing - } - assertEqual - { actual: SCU.toChar "a" - , expected: Just 'a' - } - assertEqual - { actual: SCU.toChar "ab" - , expected: Nothing - } - - log "uncons" - assert $ isNothing (SCU.uncons "") - assertEqual - { actual: SCU.uncons "a" - , expected: Just { head: 'a', tail: "" } - } - assertEqual - { actual: SCU.uncons "ab" - , expected: Just { head: 'a', tail: "b" } - } - - log "takeWhile" - assertEqual - { actual: SCU.takeWhile (\c -> true) "abc" - , expected: "abc" - } - assertEqual - { actual: SCU.takeWhile (\c -> false) "abc" - , expected: "" - } - assertEqual - { actual: SCU.takeWhile (\c -> c /= 'b') "aabbcc" - , expected: "aa" - } - - log "dropWhile" - assertEqual - { actual: SCU.dropWhile (\c -> true) "abc" - , expected: "" - } - assertEqual - { actual: SCU.dropWhile (\c -> false) "abc" - , expected: "abc" - } - assertEqual - { actual: SCU.dropWhile (\c -> c /= 'b') "aabbcc" - , expected: "bbcc" - } - - log "fromCharArray" - assertEqual - { actual: SCU.fromCharArray [] - , expected: "" - } - assertEqual - { actual: SCU.fromCharArray ['a', 'b'] - , expected: "ab" - } - - log "indexOf" - assertEqual - { actual: SCU.indexOf (Pattern "") "" - , expected: Just 0 - } - assertEqual - { actual: SCU.indexOf (Pattern "") "abcd" - , expected: Just 0 - } - assertEqual - { actual: SCU.indexOf (Pattern "bc") "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.indexOf (Pattern "cb") "abcd" - , expected: Nothing - } - - log "indexOf'" - assertEqual - { actual: SCU.indexOf' (Pattern "") 0 "" - , expected: Just 0 - } - assertEqual - { actual: SCU.indexOf' (Pattern "") (-1) "ab" - , expected: Nothing - } - assertEqual - { actual: SCU.indexOf' (Pattern "") 0 "ab" - , expected: Just 0 - } - assertEqual - { actual: SCU.indexOf' (Pattern "") 1 "ab" - , expected: Just 1 - } - assertEqual - { actual: SCU.indexOf' (Pattern "") 2 "ab" - , expected: Just 2 - } - assertEqual - { actual: SCU.indexOf' (Pattern "") 3 "ab" - , expected: Nothing - } - assertEqual - { actual: SCU.indexOf' (Pattern "bc") 0 "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.indexOf' (Pattern "bc") 1 "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.indexOf' (Pattern "bc") 2 "abcd" - , expected: Nothing - } - assertEqual - { actual: SCU.indexOf' (Pattern "cb") 0 "abcd" - , expected: Nothing - } - - log "lastIndexOf" - assertEqual - { actual: SCU.lastIndexOf (Pattern "") "" - , expected: Just 0 - } - assertEqual - { actual: SCU.lastIndexOf (Pattern "") "abcd" - , expected: Just 4 - } - assertEqual - { actual: SCU.lastIndexOf (Pattern "bc") "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.lastIndexOf (Pattern "cb") "abcd" - , expected: Nothing - } - - log "lastIndexOf'" - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") 0 "" - , expected: Just 0 - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") (-1) "ab" - , expected: Nothing - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") 0 "ab" - , expected: Just 0 - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") 1 "ab" - , expected: Just 1 - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") 2 "ab" - , expected: Just 2 - } - log "lastIndexOf' case 5" - assertEqual - { actual: SCU.lastIndexOf' (Pattern "") 3 "ab" - , expected: Nothing - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "bc") 0 "abcd" - , expected: Nothing - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "bc") 1 "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "bc") 2 "abcd" - , expected: Just 1 - } - assertEqual - { actual: SCU.lastIndexOf' (Pattern "cb") 0 "abcd" - , expected: Nothing - } - - log "length" - assertEqual - { actual: SCU.length "" - , expected: 0 - } - assertEqual - { actual: SCU.length "a" - , expected: 1 - } - assertEqual - { actual: SCU.length "ab" - , expected: 2 - } - - log "take" - assertEqual - { actual: SCU.take 0 "ab" - , expected: "" - } - assertEqual - { actual: SCU.take 1 "ab" - , expected: "a" - } - assertEqual - { actual: SCU.take 2 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.take 3 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.take (-1) "ab" - , expected: "" - } - - log "takeRight" - assertEqual - { actual: SCU.takeRight 0 "ab" - , expected: "" - } - assertEqual - { actual: SCU.takeRight 1 "ab" - , expected: "b" - } - assertEqual - { actual: SCU.takeRight 2 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.takeRight 3 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.takeRight (-1) "ab" - , expected: "" - } - - log "drop" - assertEqual - { actual: SCU.drop 0 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.drop 1 "ab" - , expected: "b" - } - assertEqual - { actual: SCU.drop 2 "ab" - , expected: "" - } - assertEqual - { actual: SCU.drop 3 "ab" - , expected: "" - } - assertEqual - { actual: SCU.drop (-1) "ab" - , expected: "ab" - } - - log "dropRight" - assertEqual - { actual: SCU.dropRight 0 "ab" - , expected: "ab" - } - assertEqual - { actual: SCU.dropRight 1 "ab" - , expected: "a" - } - assertEqual - { actual: SCU.dropRight 2 "ab" - , expected: "" - } - assertEqual - { actual: SCU.dropRight 3 "ab" - , expected: "" - } - assertEqual - { actual: SCU.dropRight (-1) "ab" - , expected: "ab" - } - - log "countPrefix" - assertEqual - { actual: SCU.countPrefix (_ == 'a') "" - , expected: 0 - } - assertEqual - { actual: SCU.countPrefix (_ == 'a') "ab" - , expected: 1 - } - assertEqual - { actual: SCU.countPrefix (_ == 'a') "aaab" - , expected: 3 - } - assertEqual - { actual: SCU.countPrefix (_ == 'a') "abaa" - , expected: 1 - } - - log "splitAt" - assertEqual - { actual: SCU.splitAt 1 "" - , expected: {before: "", after: ""} - } - assertEqual - { actual: SCU.splitAt 0 "a" - , expected: {before: "", after: "a"} - } - assertEqual - { actual: SCU.splitAt 1 "a" - , expected: {before: "a", after: ""} - } - assertEqual - { actual: SCU.splitAt 1 "ab" - , expected: {before: "a", after: "b"} - } - assertEqual - { actual: SCU.splitAt 3 "aabcc" - , expected: {before: "aab", after: "cc"} - } - assertEqual - { actual: SCU.splitAt (-1) "abc" - , expected: {before: "", after: "abc"} - } - assertEqual - { actual: SCU.splitAt 10 "Hi" - , expected: {before: "Hi", after: ""} - } - - log "toCharArray" - assertEqual - { actual: SCU.toCharArray "" - , expected: [] - } - assertEqual - { actual: SCU.toCharArray "a" - , expected: ['a'] - } - assertEqual - { actual: SCU.toCharArray "ab" - , expected: ['a', 'b'] - } - - log "slice" - assertEqual - { actual: SCU.slice 0 0 "purescript" - , expected: Just "" - } - assertEqual - { actual: SCU.slice 0 1 "purescript" - , expected: Just "p" - } - assertEqual - { actual: SCU.slice 3 6 "purescript" - , expected: Just "esc" - } - assertEqual - { actual: SCU.slice 3 10 "purescript" - , expected: Just "escript" - } - assertEqual - { actual: SCU.slice (-4) (-1) "purescript" - , expected: Just "rip" - } - assertEqual - { actual: SCU.slice (-4) 3 "purescript" - , expected: Nothing -- b' > e' - } - assertEqual - { actual: SCU.slice 1000 3 "purescript" - , expected: Nothing -- b' > e' (subsumes b > l) - } - assertEqual - { actual: SCU.slice 2 (-15) "purescript" - , expected: Nothing -- e' < 0 - } - assertEqual - { actual: SCU.slice (-15) 9 "purescript" - , expected: Nothing -- b' < 0 - } - assertEqual - { actual: SCU.slice 3 1000 "purescript" - , expected: Nothing -- e > l - } diff --git a/passing/test/String/Test/Data/String/NonEmpty.purs b/passing/test/String/Test/Data/String/NonEmpty.purs deleted file mode 100644 index 59a8f22..0000000 --- a/passing/test/String/Test/Data/String/NonEmpty.purs +++ /dev/null @@ -1,220 +0,0 @@ -module Test.Data.String.NonEmpty (testNonEmptyString) where - -import Prelude - -import Data.Array.NonEmpty as NEA -import Data.Maybe (Maybe(..), fromJust) -import Data.String.NonEmpty (Pattern(..), nes) -import Data.String.NonEmpty as NES -import Data.Symbol (SProxy(..)) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert, assertEqual) - -testNonEmptyString :: Effect Unit -testNonEmptyString = do - - log "fromString" - assertEqual - { actual: NES.fromString "" - , expected: Nothing - } - assertEqual - { actual: NES.fromString "hello" - , expected: Just (nes (SProxy :: SProxy "hello")) - } - - log "toString" - assertEqual - { actual: (NES.toString <$> NES.fromString "hello") - , expected: Just "hello" - } - - log "appendString" - assertEqual - { actual: NES.appendString (nes (SProxy :: SProxy "Hello")) " world" - , expected: nes (SProxy :: SProxy "Hello world") - } - assertEqual - { actual: NES.appendString (nes (SProxy :: SProxy "Hello")) "" - , expected: nes (SProxy :: SProxy "Hello") - } - - log "prependString" - assertEqual - { actual: NES.prependString "be" (nes (SProxy :: SProxy "fore")) - , expected: nes (SProxy :: SProxy "before") - } - assertEqual - { actual: NES.prependString "" (nes (SProxy :: SProxy "fore")) - , expected: nes (SProxy :: SProxy "fore") - } - - log "contains" - assert $ NES.contains (Pattern "") (nes (SProxy :: SProxy "abcd")) - assert $ NES.contains (Pattern "bc") (nes (SProxy :: SProxy "abcd")) - assert $ not NES.contains (Pattern "cb") (nes (SProxy :: SProxy "abcd")) - assert $ NES.contains (Pattern "needle") (nes (SProxy :: SProxy "haystack with needle")) - assert $ not NES.contains (Pattern "needle") (nes (SProxy :: SProxy "haystack")) - - log "localeCompare" - assertEqual - { actual: NES.localeCompare (nes (SProxy :: SProxy "a")) (nes (SProxy :: SProxy "a")) - , expected: EQ - } - assertEqual - { actual: NES.localeCompare (nes (SProxy :: SProxy "a")) (nes (SProxy :: SProxy "b")) - , expected: LT - } - assertEqual - { actual: NES.localeCompare (nes (SProxy :: SProxy "b")) (nes (SProxy :: SProxy "a")) - , expected: GT - } - - log "replace" - assertEqual - { actual: NES.replace (Pattern "b") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "abc")) - , expected: nes (SProxy :: SProxy "a!c") - } - assertEqual - { actual: NES.replace (Pattern "b") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "abbc")) - , expected: nes (SProxy :: SProxy "a!bc") - } - assertEqual - { actual: NES.replace (Pattern "d") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "abc")) - , expected: nes (SProxy :: SProxy "abc") - } - - log "replaceAll" - assertEqual - { actual: NES.replaceAll (Pattern "[b]") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "a[b]c")) - , expected: nes (SProxy :: SProxy "a!c") - } - assertEqual - { actual: NES.replaceAll (Pattern "[b]") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "a[b]c[b]")) - , expected: nes (SProxy :: SProxy "a!c!") - } - assertEqual - { actual: NES.replaceAll (Pattern "x") (NES.NonEmptyReplacement (nes (SProxy :: SProxy "!"))) (nes (SProxy :: SProxy "abc")) - , expected: nes (SProxy :: SProxy "abc") - } - - log "stripPrefix" - assertEqual - { actual: NES.stripPrefix (Pattern "") (nes (SProxy :: SProxy "abc")) - , expected: Just (nes (SProxy :: SProxy "abc")) - } - assertEqual - { actual: NES.stripPrefix (Pattern "a") (nes (SProxy :: SProxy "abc")) - , expected: Just (nes (SProxy :: SProxy "bc")) - } - assertEqual - { actual: NES.stripPrefix (Pattern "abc") (nes (SProxy :: SProxy "abc")) - , expected: Nothing - } - assertEqual - { actual: NES.stripPrefix (Pattern "!") (nes (SProxy :: SProxy "abc")) - , expected: Nothing - } - assertEqual - { actual: NES.stripPrefix (Pattern "http:") (nes (SProxy :: SProxy "http://purescript.org")) - , expected: Just (nes (SProxy :: SProxy "//purescript.org")) - } - assertEqual - { actual: NES.stripPrefix (Pattern "http:") (nes (SProxy :: SProxy "https://purescript.org")) - , expected: Nothing - } - assertEqual - { actual: NES.stripPrefix (Pattern "Hello!") (nes (SProxy :: SProxy "Hello!")) - , expected: Nothing - } - - log "stripSuffix" - assertEqual - { actual: NES.stripSuffix (Pattern ".exe") (nes (SProxy :: SProxy "purs.exe")) - , expected: Just (nes (SProxy :: SProxy "purs")) - } - assertEqual - { actual: NES.stripSuffix (Pattern ".exe") (nes (SProxy :: SProxy "purs")) - , expected: Nothing - } - assertEqual - { actual: NES.stripSuffix (Pattern "Hello!") (nes (SProxy :: SProxy "Hello!")) - , expected: Nothing - } - - log "toLower" - assertEqual - { actual: NES.toLower (nes (SProxy :: SProxy "bAtMaN")) - , expected: nes (SProxy :: SProxy "batman") - } - - log "toUpper" - assertEqual - { actual: NES.toUpper (nes (SProxy :: SProxy "bAtMaN")) - , expected: nes (SProxy :: SProxy "BATMAN") - } - - log "trim" - assertEqual - { actual: NES.trim (nes (SProxy :: SProxy " abc ")) - , expected: Just (nes (SProxy :: SProxy "abc")) - } - assertEqual - { actual: NES.trim (nes (SProxy :: SProxy " \n")) - , expected: Nothing - } - - log "joinWith" - assertEqual - { actual: NES.joinWith "" [] - , expected: "" - } - assertEqual - { actual: NES.joinWith "" [nes (SProxy :: SProxy "a"), nes (SProxy :: SProxy "b")] - , expected: "ab" - } - assertEqual - { actual: NES.joinWith "--" [nes (SProxy :: SProxy "a"), nes (SProxy :: SProxy "b"), nes (SProxy :: SProxy "c")] - , expected: "a--b--c" - } - - log "join1With" - assertEqual - { actual: NES.join1With "" (nea [nes (SProxy :: SProxy "a"), nes (SProxy :: SProxy "b")]) - , expected: nes (SProxy :: SProxy "ab") - } - assertEqual - { actual: NES.join1With "--" (nea [nes (SProxy :: SProxy "a"), nes (SProxy :: SProxy "b"), nes (SProxy :: SProxy "c")]) - , expected: nes (SProxy :: SProxy "a--b--c") - } - assertEqual - { actual: NES.join1With ", " (nea [nes (SProxy :: SProxy "apple"), nes (SProxy :: SProxy "banana")]) - , expected: nes (SProxy :: SProxy "apple, banana") - } - assertEqual - { actual: NES.join1With "" (nea [nes (SProxy :: SProxy "apple"), nes (SProxy :: SProxy "banana")]) - , expected: nes (SProxy :: SProxy "applebanana") - } - - log "joinWith1" - assertEqual - { actual: NES.joinWith1 (nes (SProxy :: SProxy " ")) (nea ["a", "b"]) - , expected: nes (SProxy :: SProxy "a b") - } - assertEqual - { actual: NES.joinWith1 (nes (SProxy :: SProxy "--")) (nea ["a", "b", "c"]) - , expected: nes (SProxy :: SProxy "a--b--c") - } - assertEqual - { actual: NES.joinWith1 (nes (SProxy :: SProxy ", ")) (nea ["apple", "banana"]) - , expected: nes (SProxy :: SProxy "apple, banana") - } - assertEqual - { actual: NES.joinWith1 (nes (SProxy :: SProxy "/")) (nea ["a", "b", "", "c", ""]) - , expected: nes (SProxy :: SProxy "a/b//c/") - } - -nea :: Array ~> NEA.NonEmptyArray -nea = unsafePartial fromJust <<< NEA.fromArray diff --git a/passing/test/String/Test/Data/String/NonEmpty/CodeUnits.purs b/passing/test/String/Test/Data/String/NonEmpty/CodeUnits.purs deleted file mode 100644 index fee9b51..0000000 --- a/passing/test/String/Test/Data/String/NonEmpty/CodeUnits.purs +++ /dev/null @@ -1,450 +0,0 @@ -module Test.Data.String.NonEmpty.CodeUnits (testNonEmptyStringCodeUnits) where - -import Prelude - -import Data.Array.NonEmpty as NEA -import Data.Enum (fromEnum) -import Data.Maybe (Maybe(..), fromJust) -import Data.String.NonEmpty (Pattern(..), nes) -import Data.String.NonEmpty.CodeUnits as NESCU -import Data.Symbol (SProxy(..)) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assertEqual) - -testNonEmptyStringCodeUnits :: Effect Unit -testNonEmptyStringCodeUnits = do - - log "fromCharArray" - assertEqual - { actual: NESCU.fromCharArray [] - , expected: Nothing - } - assertEqual - { actual: NESCU.fromCharArray ['a', 'b'] - , expected: Just (nes (SProxy :: SProxy "ab")) - } - - log "fromNonEmptyCharArray" - assertEqual - { actual: NESCU.fromNonEmptyCharArray (NEA.singleton 'b') - , expected: NESCU.singleton 'b' - } - - log "singleton" - assertEqual - { actual: NESCU.singleton 'a' - , expected: nes (SProxy :: SProxy "a") - } - - log "cons" - assertEqual - { actual: NESCU.cons 'a' "bc" - , expected: nes (SProxy :: SProxy "abc") - } - assertEqual - { actual: NESCU.cons 'a' "" - , expected: nes (SProxy :: SProxy "a") - } - - log "snoc" - assertEqual - { actual: NESCU.snoc 'c' "ab" - , expected: nes (SProxy :: SProxy "abc") - } - assertEqual - { actual: NESCU.snoc 'a' "" - , expected: nes (SProxy :: SProxy "a") - } - - log "fromFoldable1" - assertEqual - { actual: NESCU.fromFoldable1 (nea ['a']) - , expected: nes (SProxy :: SProxy "a") - } - assertEqual - { actual: NESCU.fromFoldable1 (nea ['a', 'b', 'c']) - , expected: nes (SProxy :: SProxy "abc") - } - - log "charAt" - assertEqual - { actual: NESCU.charAt 0 (nes (SProxy :: SProxy "a")) - , expected: Just 'a' - } - assertEqual - { actual: NESCU.charAt 1 (nes (SProxy :: SProxy "a")) - , expected: Nothing - } - assertEqual - { actual: NESCU.charAt 0 (nes (SProxy :: SProxy "ab")) - , expected: Just 'a' - } - assertEqual - { actual: NESCU.charAt 1 (nes (SProxy :: SProxy "ab")) - , expected: Just 'b' - } - assertEqual - { actual: NESCU.charAt 2 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.charAt 2 (nes (SProxy :: SProxy "Hello")) - , expected: Just 'l' - } - assertEqual - { actual: NESCU.charAt 10 (nes (SProxy :: SProxy "Hello")) - , expected: Nothing - } - - log "charCodeAt" - assertEqual - { actual: fromEnum <$> NESCU.charAt 0 (nes (SProxy :: SProxy "a")) - , expected: Just 97 - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 1 (nes (SProxy :: SProxy "a")) - , expected: Nothing - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 0 (nes (SProxy :: SProxy "ab")) - , expected: Just 97 - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 1 (nes (SProxy :: SProxy "ab")) - , expected: Just 98 - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 2 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 2 (nes (SProxy :: SProxy "5 โ‚ฌ")) - , expected: Just 0x20AC - } - assertEqual - { actual: fromEnum <$> NESCU.charAt 10 (nes (SProxy :: SProxy "5 โ‚ฌ")) - , expected: Nothing - } - - log "toChar" - assertEqual - { actual: NESCU.toChar (nes (SProxy :: SProxy "a")) - , expected: Just 'a' - } - assertEqual - { actual: NESCU.toChar (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - - log "toCharArray" - assertEqual - { actual: NESCU.toCharArray (nes (SProxy :: SProxy "a")) - , expected: ['a'] - } - assertEqual - { actual: NESCU.toCharArray (nes (SProxy :: SProxy "ab")) - , expected: ['a', 'b'] - } - assertEqual - { actual: NESCU.toCharArray (nes (SProxy :: SProxy "Helloโ˜บ\n")) - , expected: ['H','e','l','l','o','โ˜บ','\n'] - } - - log "toNonEmptyCharArray" - assertEqual - { actual: NESCU.toNonEmptyCharArray (nes (SProxy :: SProxy "ab")) - , expected: nea ['a', 'b'] - } - - log "uncons" - assertEqual - { actual: NESCU.uncons (nes (SProxy :: SProxy "a")) - , expected: { head: 'a', tail: Nothing } - } - assertEqual - { actual: NESCU.uncons (nes (SProxy :: SProxy "Hello World")) - , expected: { head: 'H', tail: Just (nes (SProxy :: SProxy "ello World")) } - } - - log "takeWhile" - assertEqual - { actual: NESCU.takeWhile (\c -> true) (nes (SProxy :: SProxy "abc")) - , expected: Just (nes (SProxy :: SProxy "abc")) - } - assertEqual - { actual: NESCU.takeWhile (\c -> false) (nes (SProxy :: SProxy "abc")) - , expected: Nothing - } - assertEqual - { actual: NESCU.takeWhile (\c -> c /= 'b') (nes (SProxy :: SProxy "aabbcc")) - , expected: Just (nes (SProxy :: SProxy "aa")) - } - assertEqual - { actual: NESCU.takeWhile (_ /= ':') (nes (SProxy :: SProxy "http://purescript.org")) - , expected: Just (nes (SProxy :: SProxy "http")) - } - assertEqual - { actual: NESCU.takeWhile (_ == 'a') (nes (SProxy :: SProxy "xyz")) - , expected: Nothing - } - - log "dropWhile" - assertEqual - { actual: NESCU.dropWhile (\c -> true) (nes (SProxy :: SProxy "abc")) - , expected: Nothing - } - assertEqual - { actual: NESCU.dropWhile (\c -> false) (nes (SProxy :: SProxy "abc")) - , expected: Just (nes (SProxy :: SProxy "abc")) - } - assertEqual - { actual: NESCU.dropWhile (\c -> c /= 'b') (nes (SProxy :: SProxy "aabbcc")) - , expected: Just (nes (SProxy :: SProxy "bbcc")) - } - assertEqual - { actual: NESCU.dropWhile (_ /= '.') (nes (SProxy :: SProxy "Test.purs")) - , expected: Just (nes (SProxy :: SProxy ".purs")) - } - - log "indexOf" - assertEqual - { actual: NESCU.indexOf (Pattern "") (nes (SProxy :: SProxy "abcd")) - , expected: Just 0 - } - assertEqual - { actual: NESCU.indexOf (Pattern "bc") (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.indexOf (Pattern "cb") (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - - log "indexOf'" - assertEqual - { actual: NESCU.indexOf' (Pattern "") (-1) (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.indexOf' (Pattern "") 0 (nes (SProxy :: SProxy "ab")) - , expected: Just 0 - } - assertEqual - { actual: NESCU.indexOf' (Pattern "") 1 (nes (SProxy :: SProxy "ab")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.indexOf' (Pattern "") 2 (nes (SProxy :: SProxy "ab")) - , expected: Just 2 - } - assertEqual - { actual: NESCU.indexOf' (Pattern "") 3 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.indexOf' (Pattern "bc") 0 (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.indexOf' (Pattern "bc") 1 (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.indexOf' (Pattern "bc") 2 (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - assertEqual - { actual: NESCU.indexOf' (Pattern "cb") 0 (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - - log "lastIndexOf" - assertEqual - { actual: NESCU.lastIndexOf (Pattern "") (nes (SProxy :: SProxy "abcd")) - , expected: Just 4 - } - assertEqual - { actual: NESCU.lastIndexOf (Pattern "bc") (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.lastIndexOf (Pattern "cb") (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - - log "lastIndexOf'" - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "") (-1) (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "") 0 (nes (SProxy :: SProxy "ab")) - , expected: Just 0 - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "") 1 (nes (SProxy :: SProxy "ab")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "") 2 (nes (SProxy :: SProxy "ab")) - , expected: Just 2 - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "") 3 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "bc") 0 (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "bc") 1 (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "bc") 2 (nes (SProxy :: SProxy "abcd")) - , expected: Just 1 - } - assertEqual - { actual: NESCU.lastIndexOf' (Pattern "cb") 0 (nes (SProxy :: SProxy "abcd")) - , expected: Nothing - } - - log "length" - assertEqual - { actual: NESCU.length (nes (SProxy :: SProxy "a")) - , expected: 1 - } - assertEqual - { actual: NESCU.length (nes (SProxy :: SProxy "ab")) - , expected: 2 - } - - log "take" - assertEqual - { actual: NESCU.take 0 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.take 1 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "a")) - } - assertEqual - { actual: NESCU.take 2 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.take 3 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.take (-1) (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - - log "takeRight" - assertEqual - { actual: NESCU.takeRight 0 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.takeRight 1 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "b")) - } - assertEqual - { actual: NESCU.takeRight 2 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.takeRight 3 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.takeRight (-1) (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - - log "drop" - assertEqual - { actual: NESCU.drop 0 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.drop 1 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "b")) - } - assertEqual - { actual: NESCU.drop 2 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.drop 3 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.drop (-1) (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - - log "dropRight" - assertEqual - { actual: NESCU.dropRight 0 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - assertEqual - { actual: NESCU.dropRight 1 (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "a")) - } - assertEqual - { actual: NESCU.dropRight 2 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.dropRight 3 (nes (SProxy :: SProxy "ab")) - , expected: Nothing - } - assertEqual - { actual: NESCU.dropRight (-1) (nes (SProxy :: SProxy "ab")) - , expected: Just (nes (SProxy :: SProxy "ab")) - } - - log "countPrefix" - assertEqual - { actual: NESCU.countPrefix (_ == 'a') (nes (SProxy :: SProxy "ab")) - , expected: 1 - } - assertEqual - { actual: NESCU.countPrefix (_ == 'a') (nes (SProxy :: SProxy "aaab")) - , expected: 3 - } - assertEqual - { actual: NESCU.countPrefix (_ == 'a') (nes (SProxy :: SProxy "abaa")) - , expected: 1 - } - assertEqual - { actual: NESCU.countPrefix (_ == 'c') (nes (SProxy :: SProxy "abaa")) - , expected: 0 - } - - log "splitAt" - assertEqual - { actual: NESCU.splitAt 0 (nes (SProxy :: SProxy "a")) - , expected: { before: Nothing, after: Just (nes (SProxy :: SProxy "a")) } - } - assertEqual - { actual: NESCU.splitAt 1 (nes (SProxy :: SProxy "ab")) - , expected: { before: Just (nes (SProxy :: SProxy "a")), after: Just (nes (SProxy :: SProxy "b")) } - } - assertEqual - { actual: NESCU.splitAt 3 (nes (SProxy :: SProxy "aabcc")) - , expected: { before: Just (nes (SProxy :: SProxy "aab")), after: Just (nes (SProxy :: SProxy "cc")) } - } - assertEqual - { actual: NESCU.splitAt (-1) (nes (SProxy :: SProxy "abc")) - , expected: { before: Nothing, after: Just (nes (SProxy :: SProxy "abc")) } - } - -nea :: Array ~> NEA.NonEmptyArray -nea = unsafePartial fromJust <<< NEA.fromArray diff --git a/passing/test/String/Test/Data/String/Regex.purs b/passing/test/String/Test/Data/String/Regex.purs deleted file mode 100644 index 326b35e..0000000 --- a/passing/test/String/Test/Data/String/Regex.purs +++ /dev/null @@ -1,56 +0,0 @@ -module Test.Data.String.Regex (testStringRegex) where - -import Data.String.Regex - -import Data.Array.NonEmpty (NonEmptyArray, fromArray) -import Data.Either (isLeft) -import Data.Maybe (Maybe(..), fromJust) -import Data.String.Regex.Flags (global, ignoreCase, noFlags) -import Data.String.Regex.Unsafe (unsafeRegex) -import Effect (Effect) -import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Prelude (type (~>), Unit, discard, not, ($), (<<<), (<>), (==)) -import Test.Assert (assert) - -testStringRegex :: Effect Unit -testStringRegex = do - log "regex" - assert $ test (unsafeRegex "^a" noFlags) "abc" - assert $ not (test (unsafeRegex "^b" noFlags) "abc") - assert $ isLeft (regex "+" noFlags) - - log "flags" - assert $ "quxbarfoobaz" == replace (unsafeRegex "foo" noFlags) "qux" "foobarfoobaz" - assert $ "quxbarquxbaz" == replace (unsafeRegex "foo" global) "qux" "foobarfoobaz" - assert $ "quxbarquxbaz" == replace (unsafeRegex "foo" (global <> ignoreCase)) "qux" "foobarFOObaz" - - log "match" - assert $ match (unsafeRegex "^abc$" noFlags) "abc" == Just (nea [Just "abc"]) - assert $ match (unsafeRegex "^abc$" noFlags) "xyz" == Nothing - - log "replace" - assert $ replace (unsafeRegex "-" noFlags) "!" "a-b-c" == "a!b-c" - - log "replace'" - assert $ replace' (unsafeRegex "-" noFlags) (\s xs -> "!") "a-b-c" == "a!b-c" - - log "search" - assert $ search (unsafeRegex "b" noFlags) "abc" == Just 1 - assert $ search (unsafeRegex "d" noFlags) "abc" == Nothing - - log "split" - assert $ split (unsafeRegex "" noFlags) "" == [] - assert $ split (unsafeRegex "" noFlags) "abc" == ["a", "b", "c"] - assert $ split (unsafeRegex "b" noFlags) "" == [""] - assert $ split (unsafeRegex "b" noFlags) "abc" == ["a", "c"] - - log "test" - -- Ensure that we have referential transparency for calls to 'test'. No - -- global state should be maintained between these two calls: - let pattern = unsafeRegex "a" (parseFlags "g") - assert $ test pattern "a" - assert $ test pattern "a" - -nea :: Array ~> NonEmptyArray -nea = unsafePartial fromJust <<< fromArray diff --git a/passing/test/String/Test/Data/String/Unsafe.purs b/passing/test/String/Test/Data/String/Unsafe.purs deleted file mode 100644 index b6b9aca..0000000 --- a/passing/test/String/Test/Data/String/Unsafe.purs +++ /dev/null @@ -1,26 +0,0 @@ -module Test.Data.String.Unsafe (testStringUnsafe) where - -import Prelude - -import Data.String.Unsafe as SU -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assertEqual) - -testStringUnsafe :: Effect Unit -testStringUnsafe = do - log "charAt" - assertEqual - { actual: SU.charAt 0 "ab" - , expected: 'a' - } - assertEqual - { actual: SU.charAt 1 "ab" - , expected: 'b' - } - - log "char" - assertEqual - { actual: SU.char "a" - , expected: 'a' - } diff --git a/passing/test/String/Test/Main.purs b/passing/test/String/Test/Main.purs deleted file mode 100644 index b9375f1..0000000 --- a/passing/test/String/Test/Main.purs +++ /dev/null @@ -1,32 +0,0 @@ -module Test.String (testStringAll) where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Test.Data.String (testString) -import Test.Data.String.CaseInsensitive (testCaseInsensitiveString) -import Test.Data.String.CodePoints (testStringCodePoints) -import Test.Data.String.CodeUnits (testStringCodeUnits) -import Test.Data.String.NonEmpty (testNonEmptyString) -import Test.Data.String.NonEmpty.CodeUnits (testNonEmptyStringCodeUnits) -import Test.Data.String.Regex (testStringRegex) -import Test.Data.String.Unsafe (testStringUnsafe) - -testStringAll :: Effect Unit -testStringAll = do - log "\n--- Data.String ---\n" - testString --- log "\n--- Data.String.CodePoints ---\n" --- testStringCodePoints - log "\n--- Data.String.CodeUnits ---\n" - testStringCodeUnits - log "\n--- Data.String.Unsafe ---\n" - testStringUnsafe --- log "\n--- Data.String.Regex ---\n" --- testStringRegex - log "\n--- Data.String.CaseInsensitive ---\n" - testCaseInsensitiveString - log "\n--- Data.String.NonEmpty ---\n" - testNonEmptyString - log "\n--- Data.String.NonEmpty.CodeUnits ---\n" - testNonEmptyStringCodeUnits diff --git a/passing/test/Unfoldable.purs b/passing/test/Unfoldable.purs deleted file mode 100644 index 397eb48..0000000 --- a/passing/test/Unfoldable.purs +++ /dev/null @@ -1,69 +0,0 @@ -module Test.Unfoldable where - -import Prelude -import Data.Eq (class Eq1) -import Data.Maybe (Maybe(..)) -import Data.Tuple (Tuple(..), uncurry) -import Data.Unfoldable as U -import Data.Unfoldable1 as U1 -import Effect (Effect) -import Effect.Console (log, logShow) -import Test.Assert (assert) - -data NonEmpty f a - = NonEmpty a (f a) - -derive instance eqNonEmpty :: (Eq1 f, Eq a) => Eq (NonEmpty f a) - -instance unfoldable1NonEmpty :: U.Unfoldable f => U1.Unfoldable1 (NonEmpty f) where - unfoldr1 f = uncurry NonEmpty <<< map (U.unfoldr $ map f) <<< f - -collatz :: Int -> Array Int -collatz = U.unfoldr step - where - step 1 = Nothing - - step n = - Just - $ Tuple n - $ if n `mod` 2 == 0 then - n / 2 - else - n * 3 + 1 - -testUnfoldable :: Effect Unit -testUnfoldable = do - log "Collatz 1000" - logShow $ collatz 1000 - log "Test none" - assert $ U.none == ([] :: Array Unit) - log "Test singleton" - assert $ U.singleton unit == [ unit ] - assert $ U1.singleton unit == NonEmpty unit [] - log "Test replicate" - assert $ U.replicate 0 "foo" == [] - assert $ U.replicate 3 "foo" == [ "foo", "foo", "foo" ] - assert $ U1.replicate1 0 "foo" == NonEmpty "foo" [] - assert $ U1.replicate1 3 "foo" == NonEmpty "foo" [ "foo", "foo" ] - log "Test replicateA" - assert $ U.replicateA 3 [ 1, 2 ] - == [ [ 1, 1, 1 ] - , [ 1, 1, 2 ] - , [ 1, 2, 1 ] - , [ 1, 2, 2 ] - , [ 2, 1, 1 ] - , [ 2, 1, 2 ] - , [ 2, 2, 1 ] - , [ 2, 2, 2 ] - ] - log "Test range" - assert $ U1.range 1 0 == [ 1, 0 ] - assert $ U1.range 0 0 == [ 0 ] - assert $ U1.range 0 2 == [ 0, 1, 2 ] - assert $ U1.range 1 0 == NonEmpty 1 [ 0 ] - assert $ U1.range 0 0 == NonEmpty 0 [] - assert $ U1.range 0 2 == NonEmpty 0 [ 1, 2 ] - log "Test Maybe.toUnfoldable" - assert $ U.fromMaybe (Just "a") == [ "a" ] - assert $ U.fromMaybe (Nothing :: Maybe String) == [] - log "All done!" diff --git a/passing/test/UnsafeCoerce.purs b/passing/test/UnsafeCoerce.purs deleted file mode 100644 index 528c316..0000000 --- a/passing/test/UnsafeCoerce.purs +++ /dev/null @@ -1,29 +0,0 @@ -module Test.UnsafeCoerce where - -import Effect (Effect) -import Effect.Console (log) -import Data.Functor (class Functor) -import Data.Semigroup ((<>)) -import Data.Unit (Unit) -import Unsafe.Coerce (unsafeCoerce) - -newtype Foo - = Foo String - -newtype Bar - = Bar String - --- | The two newtypes `Foo` and `Bar` have the same runtime representation, --- | so it is safe to coerce one into the other directly. -coerceFoo :: Foo -> Bar -coerceFoo = unsafeCoerce - --- | It is also safe to coerce entire collections, without having to map over --- | individual elements. -coerceFoos :: forall f. Functor f => f Foo -> f Bar -coerceFoos = unsafeCoerce - -testUnsafeCoerce :: Effect Unit -testUnsafeCoerce = case coerceFoos [ Foo "Hello", Foo " ", Foo "World" ] of - [ Bar x, Bar y, Bar z ] -> log (x <> y <> z) - _ -> log "impossible" diff --git a/src/Language/PureScript/CodeGen/Py.hs b/src/Language/PureScript/CodeGen/Diana.hs similarity index 89% rename from src/Language/PureScript/CodeGen/Py.hs rename to src/Language/PureScript/CodeGen/Diana.hs index 68a8b31..221849b 100644 --- a/src/Language/PureScript/CodeGen/Py.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -14,9 +14,8 @@ #-} -- | This module generates code in the core imperative representation from -- elaborated PureScript code. -module Language.PureScript.CodeGen.Py +module Language.PureScript.CodeGen.Diana ( module AST - , module Common , moduleToJS ) where @@ -41,7 +40,7 @@ import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.AST.SourcePos -import Language.PureScript.CodeGen.JS.Common as Common + import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan) import qualified Language.PureScript.CoreImp.AST as AST import Language.PureScript.CoreImp.Optimizer @@ -56,8 +55,9 @@ import Language.PureScript.PSString (PSString, mkString, decodeStringWithReplace import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants.Prim as C -import Language.PureScript.CodeGen.Py.Common (unmangle) -import Language.PureScript.CodeGen.Py.Naming (identToPy) +import Language.PureScript.CodeGen.Diana.Common (unmangle, SpecialName) +import Language.PureScript.CodeGen.Diana.Naming (identToDiana, properToDiana, moduleNameToDiana) +import qualified Language.PureScript.CodeGen.Diana.Common as SpecialName unComments :: [Comment] -> Text @@ -82,7 +82,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = decls <- return $ renameModules mnLookup decls jsDecls <- mapM bindToJs decls optimized <- traverse (traverse optimize) jsDecls - let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup + let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToDiana safeName, origName)) $ M.toList mnLookup let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized `S.union` M.keysSet reExps jsImports <- traverse (importToJs mnLookup) @@ -91,10 +91,10 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let header | comments && not (null coms) = - mk . mkString . unComments $ coms + mk . mkString . unComments $ coms | otherwise = mk "No document" where mk = AST.StringLiteral Nothing - let foreignImport = AST.VariableIntroduction Nothing (unmangle "$foreign") $ + let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ Just $ AST.App Nothing pyimport [ AST.StringLiteral Nothing $ mkString $ runForeignModuleName mn ] @@ -104,16 +104,16 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) - let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToPy) standardExps + let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToDiana) standardExps ++ map (mkString . runIdent &&& foreignIdent) foreignExps ++ concatMap (reExportPairs mnLookup) reExps' let exportObj = [AST.Assignment Nothing (AST.Var Nothing $ unmangle "exports") exps'] return (hasForeign, AST.Block Nothing $ moduleBody ++ exportObj) where - thisName = unmangle ".this" + thisName = unmangle $ SpecialName.thisName this = AST.Var Nothing thisName - pyimport = AST.Var Nothing $ unmangle "import" + pyimport = AST.Var Nothing $ unmangle SpecialName.importName runModuleNameImpl :: [Text] -> [Text] -> P.ModuleName -> Text runModuleNameImpl prefix suffix (ModuleName pns) = @@ -121,8 +121,8 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = -- https://github.com/purescript/purescript/pull/3843/files T.intercalate "." (package:prefix ++ [pns] ++ suffix) - runForeignModuleName = runModuleNameImpl ["ffi"] [] - runModuleName = runModuleNameImpl [] ["pure"] + runForeignModuleName = runModuleNameImpl [] ["@ffi"] + runModuleName = runModuleNameImpl [] ["@main"] -- | Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] @@ -136,8 +136,8 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = let toExportedMember :: Ident -> AST toExportedMember = maybe - (AST.Var Nothing . identToJs) - (flip accessor . AST.Var Nothing . moduleNameToJs . snd) + (AST.Var Nothing . identToDiana) + (flip accessor . AST.Var Nothing . moduleNameToDiana . snd) (M.lookup mn' mnLookup) in map @@ -151,7 +151,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = where go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) go acc used ((ann, mn') : mns') = - let mni = Ident $ moduleNameToJs mn' + let mni = Ident $ moduleNameToDiana mn' in if mn' /= mn && mni `elem` used then let newName = freshModuleName 1 mn' used in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns' @@ -170,9 +170,9 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = AST.App Nothing (AST.Var Nothing $ unmangle "import") + let moduleBody = AST.App Nothing (AST.Var Nothing $ unmangle SpecialName.importName) [AST.StringLiteral Nothing $ mkString $ runModuleName mn'] - withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) + withPos ss $ AST.VariableIntroduction Nothing (moduleNameToDiana mnSafe) (Just moduleBody) -- | Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. @@ -222,7 +222,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val - withPos ss $ AST.VariableIntroduction Nothing (identToPy ident) (Just js) + withPos ss $ AST.VariableIntroduction Nothing (identToDiana ident) (Just js) withPos :: SourceSpan -> AST -> m AST withPos ss js = do @@ -234,7 +234,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. var :: Ident -> AST - var = AST.Var Nothing . identToPy + var = AST.Var Nothing . identToDiana -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an @@ -277,7 +277,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = ret <- valueToJs val let jsArg = case arg of UnusedIdent -> [] - _ -> [identToPy arg] + _ -> [identToDiana arg] return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret]) valueToJs' e@App{} = do let (f, args) = unApp e [] @@ -306,7 +306,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = ret <- valueToJs val return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) = - let ctorName = properToJs ctor + let ctorName = properToDiana ctor constructor = AST.Function Nothing (Just ctorName) [] $ AST.Block Nothing [ AST.Throw Nothing $ @@ -323,24 +323,25 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = valueToJs' (Constructor _ _ ctor []) = return $ AST.Block Nothing - [ AST.Function Nothing (Just (properToJs ctor)) [thisName] (AST.Block Nothing [this]) - , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor))) - $ AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) [] - , AST.Var Nothing (properToJs ctor) + [ AST.Function Nothing (Just ("๐Ÿ˜˜" <> properToDiana ctor)) [thisName] (AST.Block Nothing [this]) + , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToDiana ctor))) + $ AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToDiana ctor)) [] + , AST.Var Nothing (properToDiana ctor) ] valueToJs' (Constructor _ _ ctor fields) = let constructor = - let body = [ AST.Assignment Nothing ((indexerString $ mkString $ identToPy f) this) (var f) | f <- fields ] - in AST.Function Nothing (Just (properToJs ctor)) (identToPy `map` fields ++ [thisName]) (AST.Block Nothing $ body ++ [AST.Return Nothing this]) + let body = [ AST.Assignment Nothing ((indexerString $ mkString $ identToDiana f) this) (var f) | f <- fields ] + -- ๐Ÿ˜˜ used for class function + in AST.Function Nothing (Just ("๐Ÿ˜˜" <> properToDiana ctor)) (thisName : identToDiana `map` fields) (AST.Block Nothing $ body ++ [AST.Return Nothing this]) createFn = - let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields + let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToDiana ctor)) (var `map` fields) + in foldr (\f inner -> AST.Function Nothing Nothing [identToDiana f] (AST.Block Nothing [AST.Return Nothing inner])) body fields in return $ AST.Block Nothing [ constructor - , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn - , AST.Var Nothing (properToJs ctor) + , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToDiana ctor))) createFn + , AST.Var Nothing (properToDiana ctor) ] literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST @@ -355,15 +356,10 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = -- | Shallow copy an object. extendObj :: AST -> [(PSString, AST)] -> m AST extendObj obj sts = do - newObj <- freshName - key <- freshName - evaluatedObj <- freshName let - -- We shall implement `update` in RTS, - -- update(a, b) = {**a, **b}. - -- Also we should inline it if possible, to avoid function calls. jsNewObj = AST.ObjectLiteral Nothing sts - return $ AST.App Nothing (accessorString "special@record_update" obj) [jsNewObj] + lensFunc = AST.Var Nothing $ unmangle SpecialName.updateRecord + return $ AST.App Nothing lensFunc [jsNewObj, obj] -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. @@ -375,11 +371,11 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn')) - qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToPy (f a) + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToDiana mn')) + qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToDiana (f a) foreignIdent :: Ident -> AST - foreignIdent ident = indexerString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "$foreign") + foreignIdent ident = indexerString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "foreign") -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. @@ -402,11 +398,11 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = failedPatternError :: [Text] -> AST failedPatternError names = - let joinStr = accessorString "join" (AST.StringLiteral Nothing ",") + let joinStr = accessorString "join" (AST.StringLiteral Nothing "str") in AST.App Nothing (AST.Var Nothing $ unmangle "Error") [ AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) $ - AST.App Nothing joinStr [AST.ArrayLiteral Nothing $ zipWith valueError names vals] + AST.App Nothing joinStr [AST.StringLiteral Nothing ",", AST.ArrayLiteral Nothing $ zipWith valueError names vals] ] failedPatternMessage :: Text @@ -418,7 +414,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = valueError _ l@(AST.BooleanLiteral _ _) = l -- Newing an object produces such a Python programs -- `new A(b, c) -> tmp = {".t" : A}; A(b, c, this=tmp); return tmp - valueError s _ = accessorString "__name__" . indexerString ".t" $ AST.Var Nothing s + valueError s _ = indexerString "class" $ AST.Var Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST] guardsToJs (Left gs) = traverse genGuard gs where @@ -443,7 +439,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l binderToJs' varName done (VarBinder _ ident) = - return (AST.VariableIntroduction Nothing (identToPy ident) (Just (AST.Var Nothing varName)) : done) + return (AST.VariableIntroduction Nothing (identToDiana ident) (Just (AST.Var Nothing varName)) : done) binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = binderToJs varName done b binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do @@ -461,12 +457,12 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (AST.VariableIntroduction Nothing argVar (Just $ indexerString (mkString $ identToPy field) $ AST.Var Nothing varName) : js) + return (AST.VariableIntroduction Nothing argVar (Just $ indexerString (mkString $ identToDiana field) $ AST.Var Nothing varName) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder - return (AST.VariableIntroduction Nothing (identToPy ident) (Just (AST.Var Nothing varName)) : js) + return (AST.VariableIntroduction Nothing (identToDiana ident) (Just (AST.Var Nothing varName)) : js) literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST] literalToBinderJS varName done (NumericLiteral num) = diff --git a/src/Language/PureScript/CodeGen/Diana/Common.hs b/src/Language/PureScript/CodeGen/Diana/Common.hs new file mode 100644 index 0000000..dd1233a --- /dev/null +++ b/src/Language/PureScript/CodeGen/Diana/Common.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings + , GADTs +#-} +module Language.PureScript.CodeGen.Diana.Common where + +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc (Doc, pretty) +-- import qualified Data.Char as C +-- import Text.Printf (printf) + + +class SpecialName a where + polyDiv :: a + zeroFillShiftRight :: a + newObject :: a + thisName :: a + importName :: a + updateRecord :: a + ranger :: a + +instance SpecialName Text where + polyDiv = "div" + zeroFillShiftRight = "zfsr32" + newObject = "new" + thisName = "this" + importName = "require" + updateRecord = "update" + ranger = "range" + +prettyText :: Text -> Doc a +prettyText = pretty + +instance SpecialName (Doc a) where + polyDiv = prettyText "div" + zeroFillShiftRight = prettyText "zfsr32" + newObject = prettyText "new" + thisName = prettyText "this" + importName = prettyText "require" + updateRecord = prettyText "update" + ranger = prettyText "range" + + +unmanglePrefix :: Text +unmanglePrefix = "special๐Ÿ˜…" + +-- | unmangle or specialize names +-- current occurrences: +-- - __all__ +-- - import +-- - this + +unmangle :: Text -> Text +unmangle = T.append unmanglePrefix + +data SourceLoc + = SourceLoc + { line :: Int + , col :: Int + , filename :: String + } + +data BoxedName where + This :: BoxedName + Import :: BoxedName + Normal :: Text -> BoxedName + + +instance IsString BoxedName where + fromString = mkName . T.pack + +mkName :: Text -> BoxedName +mkName text + | [_, a] <- T.splitOn unmanglePrefix text = + case a of + -- these are RHS only + "this" -> This + "import" -> Import + _ -> Normal $ T.replace "$" "โ˜†" a + | otherwise = Normal $ + if T.isInfixOf "$" text then T.replace "$" "โ˜†" text + else "x_" <> text + +mustNorm :: BoxedName -> Text +mustNorm (Normal a) = a +mustNorm _ = error "invalid name" + +forceNorm :: BoxedName -> Text +forceNorm (Normal a) = a +forceNorm This = thisName +forceNorm Import = importName + + +{-# COMPLETE MustNorm #-} +pattern MustNorm a <- (mustNorm -> a) \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/Py/Eval.hs b/src/Language/PureScript/CodeGen/Diana/Eval.hs similarity index 67% rename from src/Language/PureScript/CodeGen/Py/Eval.hs rename to src/Language/PureScript/CodeGen/Diana/Eval.hs index f04f92e..d70e385 100644 --- a/src/Language/PureScript/CodeGen/Py/Eval.hs +++ b/src/Language/PureScript/CodeGen/Diana/Eval.hs @@ -3,7 +3,7 @@ , PatternSynonyms #-} -module Language.PureScript.CodeGen.Py.Eval where +module Language.PureScript.CodeGen.Diana.Eval where import System.FilePath (()) @@ -11,7 +11,7 @@ import System.FilePath (()) import Language.PureScript.AST.SourcePos import Language.PureScript.CoreImp.AST import Language.PureScript.Comments (Comment(..)) -import Language.PureScript.CodeGen.Py.Common (BoxedName, SourceLoc(..), mkName) +import Language.PureScript.CodeGen.Diana.Common (BoxedName(..), SourceLoc(..), mkName) import Language.PureScript.PSString (PSString, decodeStringWithReplacement) import Data.Text (Text) @@ -23,6 +23,7 @@ import Control.Monad.State import Control.Applicative import Control.Arrow ((&&&)) + pattern Attr ps <- ArrayLiteral _ [StringLiteral _ ps] class EvalJS repr where @@ -49,17 +50,15 @@ class EvalJS repr where block :: [repr] -> repr var :: BoxedName -> repr - intro :: BoxedName -> repr -> repr + intro :: BoxedName -> Maybe repr -> repr assign :: BoxedName -> repr -> repr while :: repr -> repr -> repr - upRecord :: repr -> repr -> repr forRange :: BoxedName -> repr -> repr -> repr -> repr -- [forIn] -- used only for iterating records: -- github.com/purescript/purescript@master -- src/Language/PureScript/CodeGen/JS.hs - forIn :: BoxedName -> repr -> repr -> repr ite :: repr -> repr -> Maybe repr -> repr ret :: repr -> repr @@ -67,7 +66,7 @@ class EvalJS repr where throw :: repr -> repr isa :: repr -> repr -> repr comment :: [Text] -> repr -> repr - located :: SourceLoc -> repr -> repr + located :: SourceLoc -> Bool -> repr -> repr recurIndex :: (AST -> Maybe AST) -> AST -> (Int, AST) recurIndex f ast = @@ -77,6 +76,8 @@ recurIndex f ast = let (j, inner') = recurIndex f inner in (1 + j, inner') + + finally :: EvalJS repr => AST -> repr finally n = loc $ case n of NumericLiteral _ (Left i) -> intLit i @@ -98,39 +99,18 @@ finally n = loc $ case n of ObjectLiteral _ xs -> objLit $ map (decodeStringWithReplacement . fst &&& finally . snd) xs - Function _ n args body -> - func (fmap mkName n) (map mkName args) $ finally body + Function _ (Just fn) args body + | T.isPrefixOf "๐Ÿ˜˜" fn -> func (Just $ mkName (T.tail fn)) (This : map mkName args) $ finally body + | otherwise -> func (Just $ mkName fn) (map mkName args) $ finally body + + Function _ Nothing args body -> + func Nothing (map mkName args) $ finally body Indexer _ (Attr ps) base -> - let tryRecur = \case - Indexer _ (Attr ps') base' | ps == ps' -> Just base - Comment _ _ exp -> tryRecur exp - _ -> Nothing - (depth, inner) = recurIndex tryRecur base - in - if depth == 0 then - getAttr (finally base) (decodeStringWithReplacement ps) - else - -- this is for speed up compilation - app (var "special@getattr_looper") [intLit (toInteger depth + 1), finally inner, strLit (decodeStringWithReplacement ps)] + getAttr (finally base) (decodeStringWithReplacement ps) Indexer _ item base -> - let (depth, inner) - | StringLiteral _ item' <- item = - let tryRecur = \case - Indexer _ (Attr _) _ -> Nothing - Indexer _ (StringLiteral _ item'') inner | item'' == item' -> - Just inner - Comment _ _ exp -> tryRecur exp - _ -> Nothing - in recurIndex tryRecur base - | otherwise = (0, base) - in - if depth == 0 then - getItem (finally base) (finally item) - else - -- this is for speed up compilation - app (var "special@getitem_looper") [intLit (toInteger depth + 1), finally inner, finally item] + getItem (finally base) (finally item) Assignment _ (Indexer _ (Attr ps) base) rhs -> setAttr (finally base) (decodeStringWithReplacement ps) (finally rhs) @@ -142,9 +122,6 @@ finally n = loc $ case n of Assignment _ lhs _ -> error $ show lhs - App _ (Indexer _ (Attr "special@record_update") old) [new] -> - upRecord (finally old) (finally new) - App _ f args -> app (finally f) (map finally args) @@ -154,19 +131,18 @@ finally n = loc $ case n of Block _ xs -> block $ map finally xs VariableIntroduction _ n Nothing -> - intro (mkName n) none + intro (mkName n) Nothing VariableIntroduction _ n (Just it) -> - intro (mkName n) (finally it) + intro (mkName n) $ Just (finally it) While _ cond body -> while (finally cond) (finally body) - For _ n low high body -> + For _ n low high body -> -- this seems to be not allowed as well forRange (mkName n) (finally low) (finally high) (finally body) - ForIn _ n itr body -> - forIn (mkName n) (finally itr) (finally body) + ForIn _ n itr body -> error "transformation for JavaScript forIn not allowed!" IfElse _ cond te fe -> ite (finally cond) (finally te) (fmap finally fe) @@ -194,7 +170,7 @@ finally n = loc $ case n of -- This is actually invalid line number, -- and will break the support of Python 3.5. else - located loc' + located loc' (isStmt n) | otherwise = id takeSourceLoc @@ -210,3 +186,15 @@ takeSourceLoc let line = line' + 1 in -- Issue #8 SourceLoc {line, col, filename} + + +isStmt :: AST -> Bool +isStmt a = case a of + While {} -> True + Comment {} -> True + ForIn {} -> True + For {} -> True + VariableIntroduction {} -> True + Assignment {} -> True + Block _ _ -> True + _ -> False \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/Diana/Naming.hs b/src/Language/PureScript/CodeGen/Diana/Naming.hs new file mode 100644 index 0000000..df5d611 --- /dev/null +++ b/src/Language/PureScript/CodeGen/Diana/Naming.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE + OverloadedStrings +#-} +module Language.PureScript.CodeGen.Diana.Naming where +import Language.PureScript.Crash +import Language.PureScript.Names +import Data.Text (Text, replace) + +identToDiana :: Ident -> Text +identToDiana (Ident name) = name +identToDiana (GenIdent _ _) = internalError "GenIdent in identToDiana" +identToDiana UnusedIdent = "__unused" + + +properToDiana = runProperName + +moduleNameToDiana (ModuleName mn) = replace "." "_" mn \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs new file mode 100644 index 0000000..9f52ab2 --- /dev/null +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -0,0 +1,189 @@ +-- -- required rts: +-- 1. `zfsr32`, which implements zero_fill_shift_right for 32-bit integers +-- 2. `Error(msg, self) = Exception(msg)` +-- 3. `import_module` from importlib (>=Python 3.5) +{-# LANGUAGE UndecidableInstances #-} + +module Language.PureScript.CodeGen.Diana.Serializer where + +import Control.Applicative hiding (optional) +import Control.Arrow ((&&&)) +import Control.Monad.State +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc +import Language.PureScript.AST.SourcePos +import Language.PureScript.CodeGen.Diana.Common +import Language.PureScript.CodeGen.Diana.Eval +import Language.PureScript.CoreImp.AST (BinaryOperator (..), UnaryOperator (..)) +import StringEscape (escape) +import Text.Printf (printf) + +-- serialize python + +optional :: Maybe (Doc a) -> Doc a +optional (Just a) = a +optional Nothing = pretty "None" + +pattern Optional a <- (optional -> a) + +instance EvalJS (State (M.Map String Int) (Doc a)) where + none = return $ pretty "None" + intLit i = return $ pretty i + doubleLit f = return $ pretty f + strLit s = return $ pretty $ escape s + boolLit b = return $ pretty $ if b then "1" else "0" + objLit xs = do + let meach (field, o) = do + { o <- o + ; return (pretty (escape field) <> pretty ":" <+> o) + } + xs <- mapM meach xs + return $ align (encloseSep (pretty "{|") (pretty "|}") comma xs) + + arrayLit xs = do + xs <- sequence xs + return $ list xs + unary op e = do + e <- e + return $ case op of + Negate -> pretty "-" <> e + Not -> pretty "not" <+> e + BitwiseNot -> pretty "~" <> e + Positive -> pretty "+" <> e + New -> error "impossible" + + binary op l r = do -- actually this will not be called in ImPureScript + l <- l + r <- r + return $ case op of + Add -> l <+> pretty "+" <+> r + Subtract -> l <+> pretty "-" <+> r + Multiply -> l <+> pretty "*" <+> r + Divide -> polyDiv <> tupled [l, r] + Modulus -> l <+> pretty "%" <+> r + EqualTo -> l <+> pretty "==" <+> r + NotEqualTo -> l <+> pretty "!=" <+> r + LessThan -> l <+> pretty "<" <+> r + LessThanOrEqualTo -> l <+> pretty "<=" <+> r + GreaterThan -> l <+> pretty ">" <+> r + GreaterThanOrEqualTo -> l <+> pretty ">=" <+> r + And -> l <+> pretty "and" <+> r + Or -> l <+> pretty "or" <+> r + BitwiseAnd -> l <+> pretty "&" <+> r + BitwiseOr -> l <+> pretty "|" <+> r + BitwiseXor -> l <+> pretty "^" <+> r + ShiftLeft -> l <+> pretty "<<" <+> r + ShiftRight -> l <+> pretty ">>" <+> r + ZeroFillShiftRight -> zeroFillShiftRight <> tupled [l, r] + + getAttr a attr = do + a <- a + return $ a <> pretty "." <> pretty attr + setAttr a attr v = do + a <- a + v <- v + return $ a <> pretty "." <> pretty attr <+> pretty "=" <+> v + getItem a i = do + i <- i + a <- a + return $ a <> pretty ".[" <> i <> pretty "]" + setItem a i v = do + a <- a + i <- i + v <- v + return $ a <> pretty ".[" <> i <> pretty "]" <+> pretty "=" <+> v + func n' args body = do + body <- body + let n = case n' of + Nothing -> T.pack "" + Just (MustNorm n) -> n + return $ vsep [pretty "fun" <+> pretty n <> tupled (map (pretty . forceNorm) args), align $ vsep [ body, pretty "end"]] + + app f args = do + f <- f + args <- sequence args + return $ f <> tupled args + new f args = do + f <- f + args <- sequence args + return $ newObject <> tupled (f : args) + block suite = do + suite <- sequence suite + return $ indent 4 $ vsep suite + var (Normal n) = return $ pretty n + var This = return thisName + var Import = return importName + assign (MustNorm n) v = do + v <- v + return $ pretty n <+> pretty "=" <+> v + intro (MustNorm n) Nothing = return $ pretty "var" <+> pretty n + intro (MustNorm n) (Just it) = do + it <- it + return $ vsep [ pretty "var" <+> pretty n, pretty n <+> pretty "=" <+> it ] + while cond body = do + cond <- cond + body <- body + return $ vsep [ + pretty "while" <+> cond <+> pretty "do", + align $ vsep[ body + , pretty "end"]] + forRange (MustNorm n) low high body = do + low <- low + high <- high + body <- body + return $ vsep + [ pretty "for" <+> pretty "n" <+> pretty "in" <+> ranger <> tupled [low, high] <+> pretty "do" + , align $ vsep [body, pretty "end"] + ] + ite cond te Nothing = do + cond <- cond + te <- te + return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [ te, pretty "end"]] + ite cond te (Just fe) = do + cond <- cond + te <- te + fe <- fe + return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [te, pretty "else", indent (-4) fe, pretty "end"]] + ret v = do + v <- v + return $ pretty "return" <+> v + retNoRes = return $ pretty "return" + throw v = do + v <- v + return $ pretty "raise" <+> v + isa inst ty = do + inst <- inst + ty <- ty + return $ inst <> pretty ".TAG" <> pretty "===" <> ty + comment cs exp = exp + + located SourceLoc {line, col, filename} isStmt term = do + m <- get + let op | Just v <- M.lookup filename m = return v + | otherwise = do + let i = M.size m + put $ M.insert filename i m + return i + i <- op + term <- term + if isStmt then + return $ pretty "__META" <+> pretty i + <> pretty ":" <> pretty (toInteger line) + <> pretty ":" <> pretty (toInteger col) + <+> pretty "do" <+> term + else + return $ pretty "__META" <+> pretty i + <> pretty ":" <> pretty (toInteger line) + <> pretty ":" <> pretty (toInteger col) + <+> pretty "in" <+> term + + +runDoc :: State (M.Map String Int) (Doc a) -> Doc a +runDoc m = + let (a, s) = runState m M.empty + in + vsep [ pretty "__SETMETA" <+> pretty i <+> pretty s | (s, i) <- M.toList s] + <+> hardline <+> a diff --git a/src/Language/PureScript/CodeGen/Py/Common.hs b/src/Language/PureScript/CodeGen/Py/Common.hs deleted file mode 100644 index d4c5110..0000000 --- a/src/Language/PureScript/CodeGen/Py/Common.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings - , GADTs -#-} -module Language.PureScript.CodeGen.Py.Common where - -import Data.String -import Data.Text (Text) -import qualified Data.Text as T --- import qualified Data.Char as C --- import Text.Printf (printf) - -unmanglePrefix :: Text -unmanglePrefix = "special@" - --- | unmangle or specialize names --- current occurrences: --- - __all__ --- - import --- - this - -unmangle :: Text -> Text -unmangle = T.append unmanglePrefix - -data SourceLoc - = SourceLoc - { line :: Int - , col :: Int - , filename :: String - } - -data BoxedName where - This :: BoxedName - Import :: BoxedName - UnMangled :: Text -> BoxedName - Mangled :: Text -> BoxedName - - -instance IsString BoxedName where - fromString = mkName . T.pack - -mkName :: Text -> BoxedName -mkName text - | [_, a] <- T.splitOn unmanglePrefix text = - case a of - -- these are RHS only - "this" -> This - "import" -> Import - _ -> UnMangled a - | otherwise = Mangled text - -unbox :: BoxedName -> Maybe String -unbox = \case - UnMangled n -> Just $ T.unpack n - Mangled n -> Just $ "ps_" ++ T.unpack n - _ -> Nothing - - -pattern Unbox :: String -> BoxedName -pattern Unbox a <- (unbox -> Just a) diff --git a/src/Language/PureScript/CodeGen/Py/Naming.hs b/src/Language/PureScript/CodeGen/Py/Naming.hs deleted file mode 100644 index fd43759..0000000 --- a/src/Language/PureScript/CodeGen/Py/Naming.hs +++ /dev/null @@ -1,13 +0,0 @@ - -{-# LANGUAGE - OverloadedStrings -#-} -module Language.PureScript.CodeGen.Py.Naming where -import Language.PureScript.Crash -import Language.PureScript.Names -import Data.Text (Text) - -identToPy :: Ident -> Text -identToPy (Ident name) = name -identToPy (GenIdent _ _) = internalError "GenIdent in identToPy" -identToPy UnusedIdent = "$__unused" diff --git a/src/Language/PureScript/CodeGen/Py/Serializer.hs b/src/Language/PureScript/CodeGen/Py/Serializer.hs deleted file mode 100644 index 27fcea6..0000000 --- a/src/Language/PureScript/CodeGen/Py/Serializer.hs +++ /dev/null @@ -1,162 +0,0 @@ --- -- required rts: --- 1. `zfsr32`, which implements zero_fill_shift_right for 32-bit integers --- 2. `Error(msg, self) = Exception(msg)` --- 3. `import_module` from importlib (>=Python 3.5) -{-# LANGUAGE UndecidableInstances #-} -module Language.PureScript.CodeGen.Py.Serializer where - -import Language.PureScript.CodeGen.Py.Common -import Language.PureScript.CodeGen.Py.Eval -import Language.PureScript.AST.SourcePos -import Language.PureScript.CoreImp.AST (UnaryOperator(..), BinaryOperator(..)) -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Text as T -import Text.Printf (printf) -import Control.Monad.State -import Control.Applicative hiding (optional) -import Control.Arrow ((&&&)) -import Data.Maybe (fromJust) -import Data.Text.Prettyprint.Doc -import Topdown.Core - - --- serialize python - -data As a where - AsCall :: forall a. Topdown a => a -> As a - AsBin :: String -> As a - AsCmp :: String -> As a - AsOther :: forall a. Topdown a => ((a, a) -> a) -> As a - -py_inst_of :: forall a. Topdown a => a -> a -> a -py_inst_of l r = - tfCons "call" - [ tfCons "var" [tfStr "isinstance"] - , l - , r - ] - - -applyAs :: forall a. Topdown a => As a -> a -> a -> a -applyAs a l r = case a of - AsOther f -> f (l, r) - AsCall f -> tfCons "call" [f, l, r] - AsBin op -> tfCons "binop" - [ l - , tfAcc (tfVar "BinOp") op - , r - ] - AsCmp op -> tfCons "cmp" - [ l - , tfAcc (tfVar "Compare") op - , r - ] - -optional :: forall a. Topdown a => Maybe a -> a -optional (Just a) = a -optional Nothing = tfUnit - -pattern Optional a <- (optional -> a) - -instance Topdown a => EvalJS a where - - none = tfUnit - intLit i = tfInt i - doubleLit f = tfFloat f - strLit s = tfStr s - boolLit b = tfBool b - objLit xs = tfCons "record" $ flip map xs $ \(field, o) -> tfCons "make_pair" [tfStr field, o] - arrayLit = tfCons "mktuple" - unary op e = - let - op' :: String - op' - | Negate <- op = "NEGATIVE" - | Not <- op = "NOT" - | BitwiseNot <- op = "INVERT" - | Positive <- op = "POSITIVE" - | otherwise = error "impossible unary operator" - in tfCons "uop" [tfAcc (tfVar "UOp") op', e] - - binary op l r = - let - is a = a == op - op' :: As a - op' | is Add = AsBin "ADD" - | is Subtract = AsBin "SUBTRACT" - | is Multiply = AsBin "MULTIPLY" - | is Divide = AsOther $ - \(l, r) -> - tfCons "ite" - [ py_inst_of l (tfCons "var" [tfStr "int"]) - , applyAs (AsBin "FLOOR_DIVIDE") l r - , applyAs (AsBin "TRUE_DIVIDE") l r - ] - | is Modulus = AsBin "MODULO" - | is EqualTo = AsCmp "EQ" - | is NotEqualTo = AsCmp "NE" - | is LessThan = AsCmp "LT" - | is LessThanOrEqualTo = AsCmp "LE" - | is GreaterThan = AsCmp "GT" - | is GreaterThanOrEqualTo = AsCmp "GE" - | is And = AsOther $ - \(l, r) -> - tfCons "ite" - [ l - , r - , tfBool False - ] - | is Or = AsOther $ - \(l, r) -> - tfCons "ite" - [ l - , tfBool True - , r - ] - | is BitwiseAnd = AsBin "AND" - | is BitwiseOr = AsBin "OR" - | is BitwiseXor = AsBin "XOR" - | is ShiftLeft = AsBin "LSHIFT" - | is ShiftRight = AsBin "RSHIFT" - | is ZeroFillShiftRight = AsCall $ tfCons "var" [tfStr "zfsr32"] - in applyAs op' l r - - getAttr a attr = tfCons "get_attr" [a, tfStr attr] - setAttr a attr v = tfCons "set_attr" [a, tfStr attr, v] - getItem a i = tfCons "get_item" [a, i] - setItem a i v = tfCons "set_item" [a, i, v] - func n' args body = - let n = case n' of - Nothing -> "None" - Just (Unbox n) -> n - in tfCons "define" - [ tfStr n - , tfSeq (map (tfStr . fromJust . unbox) args) - , body - , tfSeq (map (const tfUnit) args) - ] - - app f args = tfCons "call" (f:args) - - new f args = tfCons "new" (f:args) - - block = tfCons "block" - var (Unbox n) = tfCons "var" [tfStr n] - var This = tfVar "this" -- TODO: correct mangling for this in ../Py.hs - var Import = tfCons "var" [tfStr "import_module"] - assign (Unbox n) v = tfCons "assign" [tfStr n, v] - intro (Unbox n) v = tfCons "assign_star" [tfStr n, v] - while cond body = tfCons "loop" [cond, body] - upRecord old new = tfCons "lens" [old, new] - - forIn (Unbox n) seq body = tfCons "for_in" [tfStr n, seq, body] - forRange (Unbox n) low high body = tfCons "for_range" [tfStr n, low, high, body] - ite cond te (Optional fe) = tfCons "ite" [cond, te, fe] - ret v = tfCons "ret" [v] - retNoRes = tfCons "ret" [tfUnit] - throw v = tfCons "throw" [v] - isa inst ty = tfCons "isa" [inst, ty] - comment cs exp = tfCons "document" [tfStr (unlines (map T.unpack cs)), exp] - located SourceLoc {line, col, filename} term = - tfCons "metadata" [tfInt (toInteger line), tfInt (toInteger col), tfStr filename, term] diff --git a/src/Topdown/Core.hs b/src/Topdown/Core.hs deleted file mode 100644 index 46c9c4a..0000000 --- a/src/Topdown/Core.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | This module implements a data file format, --- tentatively called `topdown`. -module Topdown.Core(Topdown(..)) where - -class Topdown a where - tfFloat :: Double -> a - tfInt :: Integer -> a - tfStr :: String -> a - tfBool :: Bool -> a - tfUnit :: a - tfCons :: String -> [a] -> a - tfSeq :: [a] -> a - tfVar :: String -> a - tfAcc :: a -> String -> a diff --git a/src/Topdown/Pretty.hs b/src/Topdown/Pretty.hs deleted file mode 100644 index 623a1e2..0000000 --- a/src/Topdown/Pretty.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | pretty print top down representations -module Topdown.Pretty(PrettyTopdown) where -import Topdown.Core -import Data.Text.Prettyprint.Doc -import StringEscape (escape) - -data PrettyTopdown - -instance Topdown (Doc PrettyTopdown) where - tfFloat = pretty - tfInt = pretty - tfStr = pretty . escape - tfBool = pretty - tfUnit = pretty "None" - tfCons n xs = pretty n <> vsep [align . tupled $ xs] - tfSeq = list - tfVar = pretty - tfAcc subject attr = subject <> pretty "." <> pretty attr diff --git a/src/Topdown/Raw.hs b/src/Topdown/Raw.hs deleted file mode 100644 index 5abf5e2..0000000 --- a/src/Topdown/Raw.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | pretty print top down representations -{-# LANGUAGE OverloadedStrings #-} -module Topdown.Raw where -import Topdown.Core -import Data.Text.Prettyprint.Doc -import StringEscape (escape) -import Data.ByteString.Conversion (toByteString) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.UTF8 as BLU - - -instance Topdown ByteString where - tfFloat = toByteString - tfInt = toByteString - tfStr = toByteString . escape - tfBool True = "True" - tfBool False = "False" - tfUnit = "None" - tfCons n xs = BLU.fromString n <> "(" <> B.intercalate "," xs <> ")" - tfSeq xs = "[" <> B.intercalate "," xs <> "]" - tfVar = BLU.fromString - tfAcc subject attr = subject <> "." <> BLU.fromString attr diff --git a/src/Topdown/Topdown.hs b/src/Topdown/Topdown.hs deleted file mode 100644 index 746f644..0000000 --- a/src/Topdown/Topdown.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Topdown.Topdown(serialize, Serial) where -import Topdown.Core -import Control.Monad.State - -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Conversion (toByteString) -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.UTF8 as BU - -type Serial a = State (Map.Map String Int) a - -stringCompress :: String -> Serial Int -stringCompress s = do - direct <- get - case Map.lookup s direct of - Nothing -> do - let i = Map.size direct - put (Map.insert s i direct) - return i - Just i -> return i - -instance Topdown (Serial ByteString) where - tfFloat = return . ("f"<>) . toByteString - tfInt = return . ("i"<>) . toByteString - tfBool True = return "bt" - tfBool False = return "bf" - tfUnit = return "n" - tfAcc subj attr = do - s <- subj - return $ "a" <> BU.fromString attr <> "\n" <> s - tfStr s = do - si <- stringCompress s - return $ "s" <> toByteString si - tfVar s = do - si <- stringCompress s - return $ "v" <> toByteString si - tfCons constructor args = do - args <- sequence args - constructor <- toByteString <$> stringCompress constructor - let loads | [] <- args = "c0 " <> constructor - | otherwise = "c" <> toByteString (length args) <> " " <> constructor <> "\n" <> B.intercalate "\n" args - return loads - tfSeq args = do - args <- sequence args - let loads | [] <- args = "l0" - | otherwise = "l" <> toByteString (length args) <> "\n" <> B.intercalate "\n" args - - return loads - -serialize :: Serial ByteString -> ByteString -serialize m = - let (lines, compressed) = runState m Map.empty - compressedSize = Map.size compressed - genCompress :: ByteString -> (String, Int) -> ByteString - genCompress init (string, intIdx) = - toByteString intIdx <> " " <> toByteString (length string) - <> "\n" <> BU.fromString string - <> "\n" <> init - compressTable = foldl genCompress "" (Map.toList compressed) - in toByteString compressedSize <> "\n" <> compressTable <> "\n" <> lines <> "\n" - diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index 19a4482..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Serialize.TaglessPacker -import Data.Text (unpack) -main :: IO () -main = do - putStrLn . unpack . runPacker $ - let res :: Serial Lines - res = - tfCons "cons2" - [ - tfCons "cons1" [tfFloat 1.0, tfInt 1] - , tfCons "cons3" [] - ] - in res diff --git a/travis-env.sh b/travis-env.sh deleted file mode 100644 index bf1b63d..0000000 --- a/travis-env.sh +++ /dev/null @@ -1,6 +0,0 @@ -echo "==================setting travis release uploading environment================" -export DIST_FILE="`stack path --dist-dir`/build/pspy-blueprint/pspy-blueprint" -cp $DIST_FILE ./pspy-blueprint -export RELEASE_TAG="`python travis-env.py plat`" -export ZIP_FILE="pspy-blueprint-`python travis-env.py plat`.zip" -zip -r $ZIP_FILE . -x "*.git*" "*.stack-work*" "passing/*" From b9faaa284fb65809f780f245fc5d5cfbbbaa6a95 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Thu, 4 Nov 2021 04:54:07 +0900 Subject: [PATCH 02/13] stage --- .gitignore | 30 ++++ .gitmodules | 3 + .vscode/settings.json | 3 - DianaScript | 1 + README.md | 3 +- app/Main.hs | 2 +- imps/ffi-deps | 1 + imps/packages.dhall | 90 +++++++++++ imps/spago.dhall | 18 +++ imps/src/Main.purs | 7 + imps/test/Main.purs | 11 ++ impurescript-diana.sln | 34 ++++ impurescript-diana/impurescript-diana.csproj | 10 ++ impurescript-diana/rt.cs | 153 ++++++++++++++++++ src/Language/PureScript/CodeGen/Diana.hs | 4 +- .../PureScript/CodeGen/Diana/Common.hs | 19 +-- .../PureScript/CodeGen/Diana/Serializer.hs | 8 +- 17 files changed, 374 insertions(+), 23 deletions(-) create mode 100644 .gitmodules delete mode 100644 .vscode/settings.json create mode 160000 DianaScript create mode 100644 imps/ffi-deps create mode 100644 imps/packages.dhall create mode 100644 imps/spago.dhall create mode 100644 imps/src/Main.purs create mode 100644 imps/test/Main.purs create mode 100644 impurescript-diana.sln create mode 100644 impurescript-diana/impurescript-diana.csproj create mode 100644 impurescript-diana/rt.cs diff --git a/.gitignore b/.gitignore index 68fc12d..b8a2c00 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,33 @@ passing/.spago passing/.pure-py/ passing/passing passing/**.src.py +.vscode/## Ignore Visual Studio temporary files, build results, and +## files generated by popular Visual Studio add-ons. +## +## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore + +# generated ran code and antlr files +*.tokens +*.interp +*.ran + +# generated Python code +codegen/*_raw.py + +.idea/ +.vscode/ +runtests/mylang_raw.py +docs/_build + +# User-specific files +*.rsuser +*.suo +*.user +*.userosscache +*.sln.docstates + +# User-specific files (MonoDevelop/Xamarin Studio) +*.userprefs + +obj/ +bin/ \ No newline at end of file diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..f0f5dda --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "DianaScript"] + path = DianaScript + url = ssh://git@github.com/thautwarm/DianaScript diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index de288e1..0000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "python.formatting.provider": "black" -} \ No newline at end of file diff --git a/DianaScript b/DianaScript new file mode 160000 index 0000000..2f78b34 --- /dev/null +++ b/DianaScript @@ -0,0 +1 @@ +Subproject commit 2f78b342662d5763f5db02bace3cc40c48baa117 diff --git a/README.md b/README.md index 88a0b61..60303eb 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,3 @@ -# ImpureScript for Diana: Type-safe Scripting for Unity +# ImpureScript for Diana +Type-safe Scripting for Unity without startup time. diff --git a/app/Main.hs b/app/Main.hs index a32395a..fe3089b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -137,7 +137,7 @@ cg baseOutDir coreFnMN = do putStrLn $ "Codegen DianaScript for " ++ qualifiedMN createDirectoryIfMissing True outDir - T.writeFile (to "@main.ran") $ codePretty implCode + T.writeFile (to "@main.diana") $ codePretty implCode return hasForeign let newModsToImport = map snd (moduleImports module') diff --git a/imps/ffi-deps b/imps/ffi-deps new file mode 100644 index 0000000..e021edc --- /dev/null +++ b/imps/ffi-deps @@ -0,0 +1 @@ +src/Main.purs diff --git a/imps/packages.dhall b/imps/packages.dhall new file mode 100644 index 0000000..afde803 --- /dev/null +++ b/imps/packages.dhall @@ -0,0 +1,90 @@ +{- +Welcome to your new Dhall package-set! + +Below are instructions for how to edit this file for most use +cases, so that you don't need to know Dhall to use it. + +## Use Cases + +Most will want to do one or both of these options: +1. Override/Patch a package's dependency +2. Add a package not already in the default package set + +This file will continue to work whether you use one or both options. +Instructions for each option are explained below. + +### Overriding/Patching a package + +Purpose: +- Change a package's dependency to a newer/older release than the + default package set's release +- Use your own modified version of some dependency that may + include new API, changed API, removed API by + using your custom git repo of the library rather than + the package set's repo + +Syntax: +where `entityName` is one of the following: +- dependencies +- repo +- version +------------------------------- +let upstream = -- +in upstream + with packageName.entityName = "new value" +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with halogen.version = "master" + with halogen.repo = "https://example.com/path/to/git/repo.git" + + with halogen-vdom.version = "v4.0.0" + with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies +------------------------------- + +### Additions + +Purpose: +- Add packages that aren't already included in the default package set + +Syntax: +where `` is: +- a tag (i.e. "v4.0.0") +- a branch (i.e. "master") +- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") +------------------------------- +let upstream = -- +in upstream + with new-package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "" + } +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with benchotron = + { dependencies = + [ ] + , repo = + "https://github.com/hdgarrood/purescript-benchotron.git" + , version = + "v7.0.0" + } +------------------------------- +-} +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211030/packages.dhall sha256:5cd7c5696feea3d3f84505d311348b9e90a76c4ce3684930a0ff29606d2d816c + +in upstream diff --git a/imps/spago.dhall b/imps/spago.dhall new file mode 100644 index 0000000..baa6f75 --- /dev/null +++ b/imps/spago.dhall @@ -0,0 +1,18 @@ +{- +Welcome to a Spago project! +You can edit this file as you like. + +Need help? See the following resources: +- Spago documentation: https://github.com/purescript/spago +- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html + +When creating a new Spago project, you can use +`spago init --no-comments` or `spago init -C` +to generate this file without the comments in this block. +-} +{ name = "my-project" +, dependencies = [ ] : List Text +, packages = ./packages.dhall +, sources = [ "src/**/*.purs" ] +, backend = "psdiana" +} diff --git a/imps/src/Main.purs b/imps/src/Main.purs new file mode 100644 index 0000000..e6a5466 --- /dev/null +++ b/imps/src/Main.purs @@ -0,0 +1,7 @@ +module Main where + +data Unit = Unit +foreign import log :: forall a. a -> Unit + +main :: Unit +main = log "๐Ÿ" diff --git a/imps/test/Main.purs b/imps/test/Main.purs new file mode 100644 index 0000000..f91f98c --- /dev/null +++ b/imps/test/Main.purs @@ -0,0 +1,11 @@ +module Test.Main where + +import Prelude + +import Effect (Effect) +import Effect.Class.Console (log) + +main :: Effect Unit +main = do + log "๐Ÿ" + log "You should add some tests." diff --git a/impurescript-diana.sln b/impurescript-diana.sln new file mode 100644 index 0000000..f84161b --- /dev/null +++ b/impurescript-diana.sln @@ -0,0 +1,34 @@ +๏ปฟ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Version 16 +VisualStudioVersion = 16.0.30114.105 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "impurescript-diana", "impurescript-diana\impurescript-diana.csproj", "{FACE0918-86C1-4A2C-8332-863F9AC0BD82}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Debug|x64 = Debug|x64 + Debug|x86 = Debug|x86 + Release|Any CPU = Release|Any CPU + Release|x64 = Release|x64 + Release|x86 = Release|x86 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|Any CPU.Build.0 = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|x64.ActiveCfg = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|x64.Build.0 = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|x86.ActiveCfg = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Debug|x86.Build.0 = Debug|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|Any CPU.ActiveCfg = Release|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|Any CPU.Build.0 = Release|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|x64.ActiveCfg = Release|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|x64.Build.0 = Release|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|x86.ActiveCfg = Release|Any CPU + {FACE0918-86C1-4A2C-8332-863F9AC0BD82}.Release|x86.Build.0 = Release|Any CPU + EndGlobalSection +EndGlobal diff --git a/impurescript-diana/impurescript-diana.csproj b/impurescript-diana/impurescript-diana.csproj new file mode 100644 index 0000000..ece85c3 --- /dev/null +++ b/impurescript-diana/impurescript-diana.csproj @@ -0,0 +1,10 @@ + + + Exe + net5.0 + NUNITY;CONSOLE + + + + + diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs new file mode 100644 index 0000000..f479f2f --- /dev/null +++ b/impurescript-diana/rt.cs @@ -0,0 +1,153 @@ +using Ava; +using System; +using System.IO; +using System.Collections.Generic; +using System.Linq; + +namespace Impurescript +{ + using NameSpace = Dictionary; + + public static class ImpurescriptExts + { + + public static void SetValue(this NameSpace self, string v, DObj o) + { + self[v] = o; + } + public static void SetValue(this DModule self, string v, DObj o) + { + self.fields[v] = o; + } + + public static DObj GetValue(this DModule self, string v) + { + return self.fields.TryGetValue(v, out var o) ? o : DNone.unique; + } + public static DObj GetValue(this NameSpace self, string v) + { + return self.TryGetValue(v, out var o) ? o : DNone.unique; + } + + + } + + + [Serializable] + public class Impurescript + { + public string ApplicationPath; + + public Dictionary ModuleCaches; + + static DObj poly_div(DObj l, DObj r) + { + var i = l as DInt; + if (i == null) + { + return l.__truediv__(r); + } + return l.__floordiv__(r); + } + + static DObj js_new(DObj[] args) + { + var f = args[0]; + var obj = new Dictionary(); + obj[MK.Int(0)] = f; + args[0] = MK.Dict(obj); + return f.__call__(args); + } + + DModule ExecFromPath(string appPath, string path) + { + var apis = new DianaScriptAPIs(); + var globals = apis.InitGlobals(); + var mod = new DModule(appPath); + var exported = mod.fields; + mod.fields = globals; + SetupNameSpace(mod, appPath); + + var ast = DianaScriptAPIs.Parse(path); + var code = DianaScriptAPIs.compileModule(ast, path); + + VM.execute(code, globals); + + var exports = globals.GetValue("exports"); + + mod.fields = exported; + if (exports is DDict dict) + { + foreach (var kv in dict.dict) + { + mod.fields[(string)(DString)kv.Key] = kv.Value; + } + } + return mod; + } + + void SetupNameSpace(DModule mod, string appPath) + { + mod.SetValue("new", MK.FuncN("new", js_new)); + mod.SetValue("div", MK.Func2("div", poly_div)); + mod.SetValue("__path__", MK.String(appPath)); + mod.SetValue("module", mod); + mod.SetValue("require", MK.Func1("require", x => Require(mod, (string)(DString)x))); + } + + string AbsRelativePath(string relativeToAbs, string absPath) + { + return Path.GetFullPath(absPath, Path.GetDirectoryName(relativeToAbs)); + } + + + + string resolveAbsPathFromCurrent(DModule mod, string relPath) + { + string currentAppPath = (string)(DString)mod.GetValue("__path__"); + var currentAbsPath = Path.GetFullPath(currentAppPath, ApplicationPath); + var absPath = AbsRelativePath(currentAbsPath, relPath); + return absPath; + } + + string getAppPath(string absPath) + { + return Path.GetRelativePath(ApplicationPath, absPath); + } + + DModule ExecutePathWithNewModule(string absPath) + { + var appPath = getAppPath(absPath); + if (ModuleCaches.TryGetValue(appPath, out var value)) + return value; + var content = File.ReadAllText(absPath); + return ExecFromPath(appPath, absPath); + } + + public void ExecutePath(string relPath) + { + var absPath = Path.GetFullPath(relPath); + ExecutePathWithNewModule(absPath); + } + + DModule Require(DModule oldEngine, string relPath) + { + var absPath = resolveAbsPathFromCurrent(oldEngine, relPath); + return ExecutePathWithNewModule(absPath); + } + + public Impurescript(string path = null) + { + ApplicationPath = path ?? Environment.CurrentDirectory; + ModuleCaches = new Dictionary(); + } + +#if CONSOLE + public static void Main(string[] args) + { + var imps = new Impurescript(); + args.ToList().ForEach(imps.ExecutePath); + } +#endif + } +} \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index 221849b..26ba4b1 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -309,9 +309,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = let ctorName = properToDiana ctor constructor = AST.Function Nothing (Just ctorName) [] $ AST.Block Nothing - [ AST.Throw Nothing $ - AST.App Nothing (AST.Var Nothing $ unmangle "Error") [AST.StringLiteral Nothing $ mkString ctorName] - ] + [ AST.Throw Nothing $ AST.StringLiteral Nothing $ mkString ctorName ] createFn = AST.Function Nothing Nothing ["value"] (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]) diff --git a/src/Language/PureScript/CodeGen/Diana/Common.hs b/src/Language/PureScript/CodeGen/Diana/Common.hs index dd1233a..2015cea 100644 --- a/src/Language/PureScript/CodeGen/Diana/Common.hs +++ b/src/Language/PureScript/CodeGen/Diana/Common.hs @@ -13,7 +13,6 @@ import Data.Text.Prettyprint.Doc (Doc, pretty) class SpecialName a where polyDiv :: a - zeroFillShiftRight :: a newObject :: a thisName :: a importName :: a @@ -22,24 +21,22 @@ class SpecialName a where instance SpecialName Text where polyDiv = "div" - zeroFillShiftRight = "zfsr32" newObject = "new" thisName = "this" importName = "require" - updateRecord = "update" - ranger = "range" + updateRecord = "Dict.update" + ranger = "Enum.range" prettyText :: Text -> Doc a prettyText = pretty instance SpecialName (Doc a) where - polyDiv = prettyText "div" - zeroFillShiftRight = prettyText "zfsr32" - newObject = prettyText "new" - thisName = prettyText "this" - importName = prettyText "require" - updateRecord = prettyText "update" - ranger = prettyText "range" + polyDiv = prettyText polyDiv + newObject = prettyText newObject + thisName = prettyText thisName + importName = prettyText importName + updateRecord = prettyText updateRecord + ranger = prettyText ranger unmanglePrefix :: Text diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs index 9f52ab2..4bebc00 100644 --- a/src/Language/PureScript/CodeGen/Diana/Serializer.hs +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -41,7 +41,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where ; return (pretty (escape field) <> pretty ":" <+> o) } xs <- mapM meach xs - return $ align (encloseSep (pretty "{|") (pretty "|}") comma xs) + return $ align (encloseSep (pretty "{") (pretty "}") comma xs) arrayLit xs = do xs <- sequence xs @@ -53,7 +53,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where Not -> pretty "not" <+> e BitwiseNot -> pretty "~" <> e Positive -> pretty "+" <> e - New -> error "impossible" + New -> error "fatal" binary op l r = do -- actually this will not be called in ImPureScript l <- l @@ -77,7 +77,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where BitwiseXor -> l <+> pretty "^" <+> r ShiftLeft -> l <+> pretty "<<" <+> r ShiftRight -> l <+> pretty ">>" <+> r - ZeroFillShiftRight -> zeroFillShiftRight <> tupled [l, r] + ZeroFillShiftRight -> l <+> pretty ">>" <+> r getAttr a attr = do a <- a @@ -157,7 +157,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where isa inst ty = do inst <- inst ty <- ty - return $ inst <> pretty ".TAG" <> pretty "===" <> ty + return $ inst <> pretty "[0]" <> pretty "==" <> ty comment cs exp = exp located SourceLoc {line, col, filename} isStmt term = do From ade45a7db7298e178149412f6a82bd37463cd801 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Thu, 4 Nov 2021 05:04:05 +0900 Subject: [PATCH 03/13] project arch --- DianaScript | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DianaScript b/DianaScript index 2f78b34..9feac5b 160000 --- a/DianaScript +++ b/DianaScript @@ -1 +1 @@ -Subproject commit 2f78b342662d5763f5db02bace3cc40c48baa117 +Subproject commit 9feac5b0773c6ad937dbd4e71b741e12b54224d3 From df1b3bcbe4ebf5215ecb0eab130310cee1ff560d Mon Sep 17 00:00:00 2001 From: thautwarm Date: Thu, 4 Nov 2021 05:09:12 +0900 Subject: [PATCH 04/13] fix codegen: dumplicate this --- src/Language/PureScript/CodeGen/Diana/Eval.hs | 2 +- .../PureScript/CodeGen/Diana/Serializer.hs | 101 ++++++++++-------- 2 files changed, 59 insertions(+), 44 deletions(-) diff --git a/src/Language/PureScript/CodeGen/Diana/Eval.hs b/src/Language/PureScript/CodeGen/Diana/Eval.hs index d70e385..1d5376d 100644 --- a/src/Language/PureScript/CodeGen/Diana/Eval.hs +++ b/src/Language/PureScript/CodeGen/Diana/Eval.hs @@ -100,7 +100,7 @@ finally n = loc $ case n of objLit $ map (decodeStringWithReplacement . fst &&& finally . snd) xs Function _ (Just fn) args body - | T.isPrefixOf "๐Ÿ˜˜" fn -> func (Just $ mkName (T.tail fn)) (This : map mkName args) $ finally body + | T.isPrefixOf "๐Ÿ˜˜" fn -> func (Just $ mkName (T.tail fn)) (map mkName args) $ finally body | otherwise -> func (Just $ mkName fn) (map mkName args) $ finally body Function _ Nothing args body -> diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs index 4bebc00..71f384a 100644 --- a/src/Language/PureScript/CodeGen/Diana/Serializer.hs +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -33,19 +33,18 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where none = return $ pretty "None" intLit i = return $ pretty i doubleLit f = return $ pretty f - strLit s = return $ pretty $ escape s + strLit s = return $ pretty $ escape s boolLit b = return $ pretty $ if b then "1" else "0" objLit xs = do let meach (field, o) = do - { o <- o - ; return (pretty (escape field) <> pretty ":" <+> o) - } + o <- o + return (pretty (escape field) <> pretty ":" <+> o) xs <- mapM meach xs return $ align (encloseSep (pretty "{") (pretty "}") comma xs) - + arrayLit xs = do - xs <- sequence xs - return $ list xs + xs <- sequence xs + return $ list xs unary op e = do e <- e return $ case op of @@ -55,7 +54,8 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where Positive -> pretty "+" <> e New -> error "fatal" - binary op l r = do -- actually this will not be called in ImPureScript + binary op l r = do + -- actually this will not be called in ImPureScript l <- l r <- r return $ case op of @@ -100,7 +100,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where let n = case n' of Nothing -> T.pack "" Just (MustNorm n) -> n - return $ vsep [pretty "fun" <+> pretty n <> tupled (map (pretty . forceNorm) args), align $ vsep [ body, pretty "end"]] + return $ vsep [pretty "fun" <+> pretty n <> tupled (map (pretty . forceNorm) args), align $ vsep [body, pretty "end"]] app f args = do f <- f @@ -111,37 +111,43 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where args <- sequence args return $ newObject <> tupled (f : args) block suite = do - suite <- sequence suite + suite <- sequence suite return $ indent 4 $ vsep suite var (Normal n) = return $ pretty n var This = return thisName var Import = return importName assign (MustNorm n) v = do v <- v - return $ pretty n <+> pretty "=" <+> v - intro (MustNorm n) Nothing = return $ pretty "var" <+> pretty n + return $ pretty n <+> pretty "=" <+> v + intro (MustNorm n) Nothing = return $ pretty "var" <+> pretty n intro (MustNorm n) (Just it) = do it <- it - return $ vsep [ pretty "var" <+> pretty n, pretty n <+> pretty "=" <+> it ] + return $ vsep [pretty "var" <+> pretty n, pretty n <+> pretty "=" <+> it] while cond body = do cond <- cond body <- body - return $ vsep [ - pretty "while" <+> cond <+> pretty "do", - align $ vsep[ body - , pretty "end"]] + return $ + vsep + [ pretty "while" <+> cond <+> pretty "do", + align $ + vsep + [ body, + pretty "end" + ] + ] forRange (MustNorm n) low high body = do low <- low high <- high body <- body - return $ vsep - [ pretty "for" <+> pretty "n" <+> pretty "in" <+> ranger <> tupled [low, high] <+> pretty "do" - , align $ vsep [body, pretty "end"] - ] + return $ + vsep + [ pretty "for" <+> pretty "n" <+> pretty "in" <+> ranger <> tupled [low, high] <+> pretty "do", + align $ vsep [body, pretty "end"] + ] ite cond te Nothing = do cond <- cond te <- te - return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [ te, pretty "end"]] + return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [te, pretty "end"]] ite cond te (Just fe) = do cond <- cond te <- te @@ -159,31 +165,40 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where ty <- ty return $ inst <> pretty "[0]" <> pretty "==" <> ty comment cs exp = exp - + located SourceLoc {line, col, filename} isStmt term = do m <- get - let op | Just v <- M.lookup filename m = return v - | otherwise = do - let i = M.size m - put $ M.insert filename i m - return i + let op + | Just v <- M.lookup filename m = return v + | otherwise = do + let i = M.size m + put $ M.insert filename i m + return i i <- op term <- term - if isStmt then - return $ pretty "__META" <+> pretty i - <> pretty ":" <> pretty (toInteger line) - <> pretty ":" <> pretty (toInteger col) - <+> pretty "do" <+> term - else - return $ pretty "__META" <+> pretty i - <> pretty ":" <> pretty (toInteger line) - <> pretty ":" <> pretty (toInteger col) - <+> pretty "in" <+> term - + if isStmt + then + return $ + pretty "__META" <+> pretty i + <> pretty ":" + <> pretty (toInteger line) + <> pretty ":" + <> pretty (toInteger col) + <+> pretty "do" + <+> term + else + return $ + pretty "__META" <+> pretty i + <> pretty ":" + <> pretty (toInteger line) + <> pretty ":" + <> pretty (toInteger col) + <+> pretty "in" + <+> term runDoc :: State (M.Map String Int) (Doc a) -> Doc a runDoc m = - let (a, s) = runState m M.empty - in - vsep [ pretty "__SETMETA" <+> pretty i <+> pretty s | (s, i) <- M.toList s] - <+> hardline <+> a + let (a, s) = runState m M.empty + in vsep [pretty "__SETMETA" <+> pretty i <+> pretty (escape s) | (s, i) <- M.toList s] + <+> hardline + <+> a From c77f987b18ee1dc485a39bfe70c872b5c572a950 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Thu, 4 Nov 2021 05:13:04 +0900 Subject: [PATCH 05/13] fix codegen: we don't need any foreign modules imported from dianascript, but implemented in c# --- src/Language/PureScript/CodeGen/Diana.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index 26ba4b1..5add92e 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -94,12 +94,13 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = mk . mkString . unComments $ coms | otherwise = mk "No document" where mk = AST.StringLiteral Nothing - let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ - Just $ - AST.App Nothing pyimport - [ AST.StringLiteral Nothing $ mkString $ runForeignModuleName mn ] + -- we don't need any rts from dianascript, but a C# module extension + -- let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ + -- Just $ + -- AST.App Nothing pyimport + -- [ AST.StringLiteral Nothing $ mkString $ runForeignModuleName mn ] let hasForeign = not $ null foreigns - let foreign' = [foreignImport | hasForeign] + let foreign' = [] -- [foreignImport | hasForeign] let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps From 86b91db32ffccad41453cfb62ab87825bdda94f9 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Thu, 4 Nov 2021 07:37:56 +0900 Subject: [PATCH 06/13] we don't need qualified names for foreign symbols --- DianaScript | 2 +- app/Main.hs | 11 ++++++- imps/ffi-deps | 18 +++++++++++- imps/src/Diana.purs | 3 ++ imps/src/Main.diana | 1 + imps/src/Main.purs | 21 +++++++++++--- impurescript-diana/rt.cs | 2 ++ src/Language/PureScript/CodeGen/Diana.hs | 37 ++++++++++++++---------- 8 files changed, 73 insertions(+), 22 deletions(-) create mode 100644 imps/src/Diana.purs create mode 100644 imps/src/Main.diana diff --git a/DianaScript b/DianaScript index 9feac5b..9d82cb3 160000 --- a/DianaScript +++ b/DianaScript @@ -1 +1 @@ -Subproject commit 9feac5b0773c6ad937dbd4e71b741e12b54224d3 +Subproject commit 9d82cb3de5efb935a2495630e91188b956780d6a diff --git a/app/Main.hs b/app/Main.hs index fe3089b..8d04303 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,7 @@ module Main where import System.Exit import System.Environment import System.Directory (createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), joinPath, takeFileName) +import System.FilePath ((), joinPath, takeFileName, stripExtension) import Data.Aeson hiding (Options) import Data.Aeson.Types hiding (Options) @@ -57,6 +57,9 @@ import Codec.Archive.Zip import StringEscape (escape) import Control.Monad.State (State) import Language.PureScript.CodeGen.Diana.Serializer (runDoc) +import qualified System.Directory as T +import Control.Monad (unless) +import Data.Maybe instance MonadReader Options (STEither Options MultipleErrors) where ask = STEither State.get @@ -138,6 +141,12 @@ cg baseOutDir coreFnMN = do putStrLn $ "Codegen DianaScript for " ++ qualifiedMN createDirectoryIfMissing True outDir T.writeFile (to "@main.diana") $ codePretty implCode + + -- when hasForeign $ do + let ffi_file = fromJust (stripExtension ".purs" mp) ++ ".diana" + exist_check <- T.doesFileExist ffi_file + when exist_check $ + T.copyFile ffi_file (to "@ffi.diana") return hasForeign let newModsToImport = map snd (moduleImports module') diff --git a/imps/ffi-deps b/imps/ffi-deps index e021edc..05aab78 100644 --- a/imps/ffi-deps +++ b/imps/ffi-deps @@ -1 +1,17 @@ -src/Main.purs +.spago/console/v5.0.0/src/Effect/Console.purs +.spago/effect/v3.0.0/src/Effect.purs +.spago/prelude/v5.0.1/src/Control/Apply.purs +.spago/prelude/v5.0.1/src/Control/Bind.purs +.spago/prelude/v5.0.1/src/Data/Bounded.purs +.spago/prelude/v5.0.1/src/Data/Eq.purs +.spago/prelude/v5.0.1/src/Data/EuclideanRing.purs +.spago/prelude/v5.0.1/src/Data/Functor.purs +.spago/prelude/v5.0.1/src/Data/HeytingAlgebra.purs +.spago/prelude/v5.0.1/src/Data/Ord.purs +.spago/prelude/v5.0.1/src/Data/Ring.purs +.spago/prelude/v5.0.1/src/Data/Semigroup.purs +.spago/prelude/v5.0.1/src/Data/Semiring.purs +.spago/prelude/v5.0.1/src/Data/Show.purs +.spago/prelude/v5.0.1/src/Data/Symbol.purs +.spago/prelude/v5.0.1/src/Data/Unit.purs +.spago/prelude/v5.0.1/src/Record/Unsafe.purs diff --git a/imps/src/Diana.purs b/imps/src/Diana.purs new file mode 100644 index 0000000..e10c8b3 --- /dev/null +++ b/imps/src/Diana.purs @@ -0,0 +1,3 @@ +module Diana where +foreign import require :: forall a. String -> a +foreign import __file__ :: String diff --git a/imps/src/Main.diana b/imps/src/Main.diana new file mode 100644 index 0000000..f9ee672 --- /dev/null +++ b/imps/src/Main.diana @@ -0,0 +1 @@ +exports.log = log diff --git a/imps/src/Main.purs b/imps/src/Main.purs index e6a5466..3c7dc1a 100644 --- a/imps/src/Main.purs +++ b/imps/src/Main.purs @@ -1,7 +1,20 @@ module Main where -data Unit = Unit -foreign import log :: forall a. a -> Unit +import Prelude +import Effect -main :: Unit -main = log "๐Ÿ" +import Effect.Class +import Effect.Console + +data Unit2 = Unit2 + +xxx :: Effect Int +xxx = do + log "5" + pure $ 1 + 10 + +main :: Effect Unit +main = do + log "๐Ÿ" + z <- xxx + log $ show (z * 3) diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs index f479f2f..220aeda 100644 --- a/impurescript-diana/rt.cs +++ b/impurescript-diana/rt.cs @@ -52,6 +52,8 @@ static DObj poly_div(DObj l, DObj r) static DObj js_new(DObj[] args) { + if(args.Length < 1) + throw new ArgumentException("cannot new with zero arguments."); var f = args[0]; var obj = new Dictionary(); obj[MK.Int(0)] = f; diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index 5add92e..445d18e 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -58,6 +58,7 @@ import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.CodeGen.Diana.Common (unmangle, SpecialName) import Language.PureScript.CodeGen.Diana.Naming (identToDiana, properToDiana, moduleNameToDiana) import qualified Language.PureScript.CodeGen.Diana.Common as SpecialName +import System.FilePath (pathSeparator) unComments :: [Comment] -> Text @@ -75,7 +76,7 @@ moduleToJS => Module Ann -> Text -> m (Bool, AST) -moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = +moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps @@ -94,11 +95,11 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = mk . mkString . unComments $ coms | otherwise = mk "No document" where mk = AST.StringLiteral Nothing - -- we don't need any rts from dianascript, but a C# module extension + -- let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ - -- Just $ - -- AST.App Nothing pyimport - -- [ AST.StringLiteral Nothing $ mkString $ runForeignModuleName mn ] + -- Just $ + -- AST.App Nothing pyimport + -- [ AST.StringLiteral Nothing $ mkString $ runForeignModulePath mn ] let hasForeign = not $ null foreigns let foreign' = [] -- [foreignImport | hasForeign] let moduleBody = header : foreign' ++ jsImports ++ concat optimized @@ -106,6 +107,9 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = let standardExps = exps \\ foreignExps let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToDiana) standardExps + -- although foreign symbols are now never qualified and always global + -- we still keep exports because we need to keep correct scope information + -- when accessing module from .NET side. ++ map (mkString . runIdent &&& foreignIdent) foreignExps ++ concatMap (reExportPairs mnLookup) reExps' let exportObj = [AST.Assignment Nothing (AST.Var Nothing $ unmangle "exports") exps'] @@ -116,14 +120,15 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = this = AST.Var Nothing thisName pyimport = AST.Var Nothing $ unmangle SpecialName.importName - runModuleNameImpl :: [Text] -> [Text] -> P.ModuleName -> Text - runModuleNameImpl prefix suffix (ModuleName pns) = + runModuleNameImpl :: Text -> [Text] -> [Text] -> P.ModuleName -> Text + runModuleNameImpl sep prefix suffix (ModuleName pns) = -- pns = ModuleName "a.b.c", according to -- https://github.com/purescript/purescript/pull/3843/files - T.intercalate "." (package:prefix ++ [pns] ++ suffix) + T.intercalate sep (prefix ++ [pns] ++ suffix) - runForeignModuleName = runModuleNameImpl [] ["@ffi"] - runModuleName = runModuleNameImpl [] ["@main"] + -- runForeignModulePath = runModuleNameImpl (T.pack [pathSeparator]) [".."] ["@ffi.diana"] + runModulePath = runModuleNameImpl (T.pack [pathSeparator]) [".."] ["@main.diana"] + runModuleName = runModuleNameImpl "." [] [] -- | Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] @@ -172,7 +177,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup let moduleBody = AST.App Nothing (AST.Var Nothing $ unmangle SpecialName.importName) - [AST.StringLiteral Nothing $ mkString $ runModuleName mn'] + [AST.StringLiteral Nothing $ mkString $ runModulePath mn'] withPos ss $ AST.VariableIntroduction Nothing (moduleNameToDiana mnSafe) (Just moduleBody) -- | Replaces the `ModuleName`s in the AST so that the generated code refers to @@ -293,9 +298,10 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) = - return $ if mn' == mn - then foreignIdent ident - else varToJs qi + return $ foreignIdent ident + -- return $ if mn' == mn + -- then foreignIdent ident + -- else varToJs qi valueToJs' (Var (_, _, _, Just IsForeign) ident) = internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident @@ -374,7 +380,8 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) package = qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToDiana (f a) foreignIdent :: Ident -> AST - foreignIdent ident = indexerString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "foreign") + foreignIdent ident = -- accessorString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "foreign") + AST.Var Nothing $ unmangle $ runIdent ident -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. From 8d78404ea18ac04e72e3248e72f3190151e45e93 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sat, 6 Nov 2021 23:18:24 +0900 Subject: [PATCH 07/13] remove submodule --- .gitmodules | 3 --- DianaScript | 1 - 2 files changed, 4 deletions(-) delete mode 160000 DianaScript diff --git a/.gitmodules b/.gitmodules index f0f5dda..e69de29 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule "DianaScript"] - path = DianaScript - url = ssh://git@github.com/thautwarm/DianaScript diff --git a/DianaScript b/DianaScript deleted file mode 160000 index 9d82cb3..0000000 --- a/DianaScript +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9d82cb3de5efb935a2495630e91188b956780d6a From 178e39d8b10b7b2aed9c0e0cdc65b274b5c01cff Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sat, 6 Nov 2021 23:18:45 +0900 Subject: [PATCH 08/13] up --- imps/ffi-deps | 18 +-------- imps/src/Diana.diana | 10 +++++ imps/src/Diana.purs | 32 +++++++++++++++- imps/src/Main.diana | 1 - imps/src/Main.purs | 28 +++++++------- impurescript-diana/rt.cs | 18 ++++++++- src/Language/PureScript/CodeGen/Diana/Eval.hs | 38 +++++++++++-------- .../PureScript/CodeGen/Diana/Serializer.hs | 10 +++-- 8 files changed, 102 insertions(+), 53 deletions(-) create mode 100644 imps/src/Diana.diana delete mode 100644 imps/src/Main.diana diff --git a/imps/ffi-deps b/imps/ffi-deps index 05aab78..9186df7 100644 --- a/imps/ffi-deps +++ b/imps/ffi-deps @@ -1,17 +1 @@ -.spago/console/v5.0.0/src/Effect/Console.purs -.spago/effect/v3.0.0/src/Effect.purs -.spago/prelude/v5.0.1/src/Control/Apply.purs -.spago/prelude/v5.0.1/src/Control/Bind.purs -.spago/prelude/v5.0.1/src/Data/Bounded.purs -.spago/prelude/v5.0.1/src/Data/Eq.purs -.spago/prelude/v5.0.1/src/Data/EuclideanRing.purs -.spago/prelude/v5.0.1/src/Data/Functor.purs -.spago/prelude/v5.0.1/src/Data/HeytingAlgebra.purs -.spago/prelude/v5.0.1/src/Data/Ord.purs -.spago/prelude/v5.0.1/src/Data/Ring.purs -.spago/prelude/v5.0.1/src/Data/Semigroup.purs -.spago/prelude/v5.0.1/src/Data/Semiring.purs -.spago/prelude/v5.0.1/src/Data/Show.purs -.spago/prelude/v5.0.1/src/Data/Symbol.purs -.spago/prelude/v5.0.1/src/Data/Unit.purs -.spago/prelude/v5.0.1/src/Record/Unsafe.purs +src/Diana.purs diff --git a/imps/src/Diana.diana b/imps/src/Diana.diana new file mode 100644 index 0000000..e9cbcde --- /dev/null +++ b/imps/src/Diana.diana @@ -0,0 +1,10 @@ +exports.log = log +exports.unit = None + +exports.getitem = subject -> fun (item) + subject[item] +end + +exports.setitem = subject -> item -> fun (value) + subject[item] = value +end diff --git a/imps/src/Diana.purs b/imps/src/Diana.purs index e10c8b3..91ade67 100644 --- a/imps/src/Diana.purs +++ b/imps/src/Diana.purs @@ -1,3 +1,33 @@ -module Diana where +module Diana + (Unit(..), unit, ($), call, require, __file__, log) +where + +foreign import data Unit :: Type + foreign import require :: forall a. String -> a foreign import __file__ :: String +foreign import log :: forall a . a -> Unit + + +ffiModule :: { none :: Unit, unsafe_getitem :: forall a b. a -> String -> b, unsafe_setitem :: forall a b. a -> String -> b -> Unit } +ffiModule = require("./@ffi.diana") + +unit :: Unit +unit = ffiModule.none + + +infixr 0 call as $ +call :: forall a b. (a -> b) -> a -> b +call f x = f x + +class Number a where + add :: a -> a -> a + sub :: a -> a -> a + div :: a -> a -> a + mul :: a -> a -> a + mod :: a -> a -> a + + +class Sign a where + neg :: a -> a + diff --git a/imps/src/Main.diana b/imps/src/Main.diana deleted file mode 100644 index f9ee672..0000000 --- a/imps/src/Main.diana +++ /dev/null @@ -1 +0,0 @@ -exports.log = log diff --git a/imps/src/Main.purs b/imps/src/Main.purs index 3c7dc1a..ab7c543 100644 --- a/imps/src/Main.purs +++ b/imps/src/Main.purs @@ -1,20 +1,18 @@ -module Main where +module Main(e) where -import Prelude -import Effect +import Diana (unit, Unit, log) -import Effect.Class -import Effect.Console -data Unit2 = Unit2 +e = unit +discard :: Unit -> Unit +discard _ = unit -xxx :: Effect Int -xxx = do - log "5" - pure $ 1 + 10 +ignore :: forall a. a -> Unit +ignore _ = unit + +main :: Unit +main = + let _ = ignore (log "๐Ÿ") in + let z = 1 in + log z -main :: Effect Unit -main = do - log "๐Ÿ" - z <- xxx - log $ show (z * 3) diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs index 220aeda..794bead 100644 --- a/impurescript-diana/rt.cs +++ b/impurescript-diana/rt.cs @@ -88,6 +88,17 @@ DModule ExecFromPath(string appPath, string path) return mod; } + public static List funcs = new List + { + MK.Func1("add", x => MK.Func1("add", y => x.__add__(y))), + MK.Func1("sub", x => MK.Func1("sub", y => x.__sub__(y))), + MK.Func1("idiv", x => MK.Func1("idiv", y => MK.Int(((DInt) x).value / ((DInt) y).value ))), + MK.Func1("fdiv", x => MK.Func1("fdiv", y => x.__truediv__(y))), + MK.Func1("mod", x => MK.Func1("mod", y => x.__mod__(y))), + MK.Func1("eq", x => MK.Func1("eq", y => MK.Int(x.__eq__(y)))), + MK.Func1("lt", x => MK.Func1("lt", y => MK.Int(x.__lt__(y)))), + MK.Func1("neg", x => x.__neg__()), + }; void SetupNameSpace(DModule mod, string appPath) { mod.SetValue("new", MK.FuncN("new", js_new)); @@ -95,6 +106,12 @@ void SetupNameSpace(DModule mod, string appPath) mod.SetValue("__path__", MK.String(appPath)); mod.SetValue("module", mod); mod.SetValue("require", MK.Func1("require", x => Require(mod, (string)(DString)x))); + + foreach(var func in funcs) + { + mod.SetValue("_" + func.name, func); + } + } string AbsRelativePath(string relativeToAbs, string absPath) @@ -111,7 +128,6 @@ string resolveAbsPathFromCurrent(DModule mod, string relPath) var absPath = AbsRelativePath(currentAbsPath, relPath); return absPath; } - string getAppPath(string absPath) { return Path.GetRelativePath(ApplicationPath, absPath); diff --git a/src/Language/PureScript/CodeGen/Diana/Eval.hs b/src/Language/PureScript/CodeGen/Diana/Eval.hs index 1d5376d..cf74258 100644 --- a/src/Language/PureScript/CodeGen/Diana/Eval.hs +++ b/src/Language/PureScript/CodeGen/Diana/Eval.hs @@ -47,7 +47,7 @@ class EvalJS repr where func :: Maybe BoxedName -> [BoxedName] -> repr -> repr app :: repr -> [repr] -> repr new :: repr -> [repr] -> repr -- create class - block :: [repr] -> repr + block :: Bool -> [repr] -> repr var :: BoxedName -> repr intro :: BoxedName -> Maybe repr -> repr @@ -77,6 +77,10 @@ recurIndex f ast = in (1 + j, inner') +conciseBlock :: EvalJS repr => AST -> repr +conciseBlock n = case n of + Block _ xs -> analyzeLoc n $ block False $ map finally xs + a -> finally a finally :: EvalJS repr => AST -> repr finally n = loc $ case n of @@ -100,8 +104,8 @@ finally n = loc $ case n of objLit $ map (decodeStringWithReplacement . fst &&& finally . snd) xs Function _ (Just fn) args body - | T.isPrefixOf "๐Ÿ˜˜" fn -> func (Just $ mkName (T.tail fn)) (map mkName args) $ finally body - | otherwise -> func (Just $ mkName fn) (map mkName args) $ finally body + | T.isPrefixOf "๐Ÿ˜˜" fn -> func (Just $ mkName (T.tail fn)) (map mkName args) $ conciseBlock body + | otherwise -> func (Just $ mkName fn) (map mkName args) $ conciseBlock body Function _ Nothing args body -> func Nothing (map mkName args) $ finally body @@ -128,7 +132,7 @@ finally n = loc $ case n of -- special names must in form of be `Var _` and not LHS Var _ n -> var (mkName n) - Block _ xs -> block $ map finally xs + Block _ xs -> block True $ map finally xs VariableIntroduction _ n Nothing -> intro (mkName n) Nothing @@ -137,15 +141,16 @@ finally n = loc $ case n of intro (mkName n) $ Just (finally it) While _ cond body -> - while (finally cond) (finally body) + + while (finally cond) (conciseBlock body) For _ n low high body -> -- this seems to be not allowed as well - forRange (mkName n) (finally low) (finally high) (finally body) + forRange (mkName n) (finally low) (finally high) (conciseBlock body) ForIn _ n itr body -> error "transformation for JavaScript forIn not allowed!" IfElse _ cond te fe -> - ite (finally cond) (finally te) (fmap finally fe) + ite (finally cond) (conciseBlock te) (fmap conciseBlock fe) Return _ e -> ret $ finally e @@ -164,15 +169,18 @@ finally n = loc $ case n of BlockComment x -> x in comment (map f cs) (finally exp) - where loc | Just loc <- getSourceSpan n = - let loc' = takeSourceLoc loc - in if line loc' == 0 then id - -- This is actually invalid line number, - -- and will break the support of Python 3.5. - else - located loc' (isStmt n) - | otherwise = id + where loc = analyzeLoc n + +analyzeLoc node + | Just loc <- getSourceSpan node = + let loc' = takeSourceLoc loc + in if line loc' == 0 then id + -- This is actually invalid line number, + -- and will break the support of Python 3.5. + else + located loc' (isStmt node) + | otherwise = id takeSourceLoc SourceSpan { spanName=filename diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs index 71f384a..e505a05 100644 --- a/src/Language/PureScript/CodeGen/Diana/Serializer.hs +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -110,9 +110,13 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where f <- f args <- sequence args return $ newObject <> tupled (f : args) - block suite = do - suite <- sequence suite - return $ indent 4 $ vsep suite + block useRealBlockExpr suite + | useRealBlockExpr = do + suite <- sequence suite + return $ vsep [pretty "begin", align $ vsep [indent 2 (vsep suite), pretty "end"]] + | otherwise = do + suite <- sequence suite + return $ indent 4 $ vsep suite var (Normal n) = return $ pretty n var This = return thisName var Import = return importName From e9dd26df01a896cd3ef34948eaf7b4beb176870d Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sat, 6 Nov 2021 23:45:01 +0900 Subject: [PATCH 09/13] up --- .gitignore | 1 + .gitmodules | 3 +++ DianaScript-JIT | 1 + imps/src/Diana.diana | 5 +++-- imps/src/Diana.purs | 12 ++--------- imps/src/Main.purs | 2 ++ impurescript-diana/impurescript-diana.csproj | 2 +- impurescript-diana/rt.cs | 7 +++---- src/Language/PureScript/CodeGen/Diana.hs | 22 +++++++++----------- 9 files changed, 26 insertions(+), 29 deletions(-) create mode 160000 DianaScript-JIT diff --git a/.gitignore b/.gitignore index b8a2c00..8c55e2a 100644 --- a/.gitignore +++ b/.gitignore @@ -41,6 +41,7 @@ passing/**.src.py *.tokens *.interp *.ran +.spago # generated Python code codegen/*_raw.py diff --git a/.gitmodules b/.gitmodules index e69de29..d4d8051 100644 --- a/.gitmodules +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "DianaScript-JIT"] + path = DianaScript-JIT + url = ssh://git@github.com/thautwarm/DianaScript-JIT diff --git a/DianaScript-JIT b/DianaScript-JIT new file mode 160000 index 0000000..6df6896 --- /dev/null +++ b/DianaScript-JIT @@ -0,0 +1 @@ +Subproject commit 6df6896c3515d26841d847a0bfd455bf7ec223b2 diff --git a/imps/src/Diana.diana b/imps/src/Diana.diana index e9cbcde..c2f17ea 100644 --- a/imps/src/Diana.diana +++ b/imps/src/Diana.diana @@ -1,10 +1,11 @@ +exports = {} exports.log = log exports.unit = None exports.getitem = subject -> fun (item) - subject[item] + subject.[item] end exports.setitem = subject -> item -> fun (value) - subject[item] = value + subject.[item] = value end diff --git a/imps/src/Diana.purs b/imps/src/Diana.purs index 91ade67..98a96bc 100644 --- a/imps/src/Diana.purs +++ b/imps/src/Diana.purs @@ -1,21 +1,13 @@ module Diana - (Unit(..), unit, ($), call, require, __file__, log) + (Unit(..), unit, ($), call, log) where foreign import data Unit :: Type - foreign import require :: forall a. String -> a -foreign import __file__ :: String +foreign import unit :: Unit foreign import log :: forall a . a -> Unit -ffiModule :: { none :: Unit, unsafe_getitem :: forall a b. a -> String -> b, unsafe_setitem :: forall a b. a -> String -> b -> Unit } -ffiModule = require("./@ffi.diana") - -unit :: Unit -unit = ffiModule.none - - infixr 0 call as $ call :: forall a b. (a -> b) -> a -> b call f x = f x diff --git a/imps/src/Main.purs b/imps/src/Main.purs index ab7c543..2628f33 100644 --- a/imps/src/Main.purs +++ b/imps/src/Main.purs @@ -3,7 +3,9 @@ module Main(e) where import Diana (unit, Unit, log) +e :: Unit e = unit + discard :: Unit -> Unit discard _ = unit diff --git a/impurescript-diana/impurescript-diana.csproj b/impurescript-diana/impurescript-diana.csproj index ece85c3..95c6764 100644 --- a/impurescript-diana/impurescript-diana.csproj +++ b/impurescript-diana/impurescript-diana.csproj @@ -5,6 +5,6 @@ NUNITY;CONSOLE - + diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs index 794bead..ed613c0 100644 --- a/impurescript-diana/rt.cs +++ b/impurescript-diana/rt.cs @@ -1,4 +1,4 @@ -using Ava; +using Diana; using System; using System.IO; using System.Collections.Generic; @@ -71,9 +71,8 @@ DModule ExecFromPath(string appPath, string path) SetupNameSpace(mod, appPath); var ast = DianaScriptAPIs.Parse(path); - var code = DianaScriptAPIs.compileModule(ast, path); - - VM.execute(code, globals); + var exec = DianaScriptAPIs.compileModule(ast, path); + exec(globals); var exports = globals.GetValue("exports"); diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index 445d18e..a79fb5e 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -96,12 +96,12 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = | otherwise = mk "No document" where mk = AST.StringLiteral Nothing - -- let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ - -- Just $ - -- AST.App Nothing pyimport - -- [ AST.StringLiteral Nothing $ mkString $ runForeignModulePath mn ] + let foreignImport = AST.VariableIntroduction Nothing (unmangle "foreign") $ + Just $ + AST.App Nothing pyimport + [ AST.StringLiteral Nothing $ mkString $ runForeignModulePath mn ] let hasForeign = not $ null foreigns - let foreign' = [] -- [foreignImport | hasForeign] + let foreign' = [foreignImport | hasForeign] let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps @@ -126,7 +126,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = -- https://github.com/purescript/purescript/pull/3843/files T.intercalate sep (prefix ++ [pns] ++ suffix) - -- runForeignModulePath = runModuleNameImpl (T.pack [pathSeparator]) [".."] ["@ffi.diana"] + runForeignModulePath = runModuleNameImpl (T.pack [pathSeparator]) [".."] ["@ffi.diana"] runModulePath = runModuleNameImpl (T.pack [pathSeparator]) [".."] ["@main.diana"] runModuleName = runModuleNameImpl "." [] [] @@ -298,10 +298,9 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) = - return $ foreignIdent ident - -- return $ if mn' == mn - -- then foreignIdent ident - -- else varToJs qi + return $ if mn' == mn + then foreignIdent ident + else varToJs qi valueToJs' (Var (_, _, _, Just IsForeign) ident) = internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident @@ -380,8 +379,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToDiana (f a) foreignIdent :: Ident -> AST - foreignIdent ident = -- accessorString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "foreign") - AST.Var Nothing $ unmangle $ runIdent ident + foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing $ unmangle "foreign") -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. From 550b0f138f1fde61c829ee34bbd5036e44f91035 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sun, 7 Nov 2021 13:24:37 +0900 Subject: [PATCH 10/13] up --- DianaScript-JIT | 2 +- imps/ffi-deps | 1 - imps/packages.dhall | 90 ------------------- imps/spago.dhall | 18 ---- imps/src/Diana.diana | 11 --- imps/src/Diana.purs | 25 ------ imps/src/Main.purs | 20 ----- imps/test/Main.purs | 11 --- impurescript-diana/rt.cs | 31 ++++--- impurescript-diana/rundiana | 3 + src/Language/PureScript/CodeGen/Diana.hs | 4 + src/Language/PureScript/CodeGen/Diana/Eval.hs | 2 +- .../PureScript/CodeGen/Diana/Serializer.hs | 7 +- 13 files changed, 30 insertions(+), 195 deletions(-) delete mode 100644 imps/ffi-deps delete mode 100644 imps/packages.dhall delete mode 100644 imps/spago.dhall delete mode 100644 imps/src/Diana.diana delete mode 100644 imps/src/Diana.purs delete mode 100644 imps/src/Main.purs delete mode 100644 imps/test/Main.purs create mode 100755 impurescript-diana/rundiana diff --git a/DianaScript-JIT b/DianaScript-JIT index 6df6896..439f234 160000 --- a/DianaScript-JIT +++ b/DianaScript-JIT @@ -1 +1 @@ -Subproject commit 6df6896c3515d26841d847a0bfd455bf7ec223b2 +Subproject commit 439f2341abe13c4df643161decc90efc7765192b diff --git a/imps/ffi-deps b/imps/ffi-deps deleted file mode 100644 index 9186df7..0000000 --- a/imps/ffi-deps +++ /dev/null @@ -1 +0,0 @@ -src/Diana.purs diff --git a/imps/packages.dhall b/imps/packages.dhall deleted file mode 100644 index afde803..0000000 --- a/imps/packages.dhall +++ /dev/null @@ -1,90 +0,0 @@ -{- -Welcome to your new Dhall package-set! - -Below are instructions for how to edit this file for most use -cases, so that you don't need to know Dhall to use it. - -## Use Cases - -Most will want to do one or both of these options: -1. Override/Patch a package's dependency -2. Add a package not already in the default package set - -This file will continue to work whether you use one or both options. -Instructions for each option are explained below. - -### Overriding/Patching a package - -Purpose: -- Change a package's dependency to a newer/older release than the - default package set's release -- Use your own modified version of some dependency that may - include new API, changed API, removed API by - using your custom git repo of the library rather than - the package set's repo - -Syntax: -where `entityName` is one of the following: -- dependencies -- repo -- version -------------------------------- -let upstream = -- -in upstream - with packageName.entityName = "new value" -------------------------------- - -Example: -------------------------------- -let upstream = -- -in upstream - with halogen.version = "master" - with halogen.repo = "https://example.com/path/to/git/repo.git" - - with halogen-vdom.version = "v4.0.0" - with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies -------------------------------- - -### Additions - -Purpose: -- Add packages that aren't already included in the default package set - -Syntax: -where `` is: -- a tag (i.e. "v4.0.0") -- a branch (i.e. "master") -- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") -------------------------------- -let upstream = -- -in upstream - with new-package-name = - { dependencies = - [ "dependency1" - , "dependency2" - ] - , repo = - "https://example.com/path/to/git/repo.git" - , version = - "" - } -------------------------------- - -Example: -------------------------------- -let upstream = -- -in upstream - with benchotron = - { dependencies = - [ ] - , repo = - "https://github.com/hdgarrood/purescript-benchotron.git" - , version = - "v7.0.0" - } -------------------------------- --} -let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211030/packages.dhall sha256:5cd7c5696feea3d3f84505d311348b9e90a76c4ce3684930a0ff29606d2d816c - -in upstream diff --git a/imps/spago.dhall b/imps/spago.dhall deleted file mode 100644 index baa6f75..0000000 --- a/imps/spago.dhall +++ /dev/null @@ -1,18 +0,0 @@ -{- -Welcome to a Spago project! -You can edit this file as you like. - -Need help? See the following resources: -- Spago documentation: https://github.com/purescript/spago -- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html - -When creating a new Spago project, you can use -`spago init --no-comments` or `spago init -C` -to generate this file without the comments in this block. --} -{ name = "my-project" -, dependencies = [ ] : List Text -, packages = ./packages.dhall -, sources = [ "src/**/*.purs" ] -, backend = "psdiana" -} diff --git a/imps/src/Diana.diana b/imps/src/Diana.diana deleted file mode 100644 index c2f17ea..0000000 --- a/imps/src/Diana.diana +++ /dev/null @@ -1,11 +0,0 @@ -exports = {} -exports.log = log -exports.unit = None - -exports.getitem = subject -> fun (item) - subject.[item] -end - -exports.setitem = subject -> item -> fun (value) - subject.[item] = value -end diff --git a/imps/src/Diana.purs b/imps/src/Diana.purs deleted file mode 100644 index 98a96bc..0000000 --- a/imps/src/Diana.purs +++ /dev/null @@ -1,25 +0,0 @@ -module Diana - (Unit(..), unit, ($), call, log) -where - -foreign import data Unit :: Type -foreign import require :: forall a. String -> a -foreign import unit :: Unit -foreign import log :: forall a . a -> Unit - - -infixr 0 call as $ -call :: forall a b. (a -> b) -> a -> b -call f x = f x - -class Number a where - add :: a -> a -> a - sub :: a -> a -> a - div :: a -> a -> a - mul :: a -> a -> a - mod :: a -> a -> a - - -class Sign a where - neg :: a -> a - diff --git a/imps/src/Main.purs b/imps/src/Main.purs deleted file mode 100644 index 2628f33..0000000 --- a/imps/src/Main.purs +++ /dev/null @@ -1,20 +0,0 @@ -module Main(e) where - -import Diana (unit, Unit, log) - - -e :: Unit -e = unit - -discard :: Unit -> Unit -discard _ = unit - -ignore :: forall a. a -> Unit -ignore _ = unit - -main :: Unit -main = - let _ = ignore (log "๐Ÿ") in - let z = 1 in - log z - diff --git a/imps/test/Main.purs b/imps/test/Main.purs deleted file mode 100644 index f91f98c..0000000 --- a/imps/test/Main.purs +++ /dev/null @@ -1,11 +0,0 @@ -module Test.Main where - -import Prelude - -import Effect (Effect) -import Effect.Class.Console (log) - -main :: Effect Unit -main = do - log "๐Ÿ" - log "You should add some tests." diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs index ed613c0..e3ed8b4 100644 --- a/impurescript-diana/rt.cs +++ b/impurescript-diana/rt.cs @@ -29,7 +29,6 @@ public static DObj GetValue(this NameSpace self, string v) return self.TryGetValue(v, out var o) ? o : DNone.unique; } - } @@ -38,6 +37,14 @@ public class Impurescript { public string ApplicationPath; + public Impurescript(string path = null) + { + ApplicationPath = path ?? Environment.CurrentDirectory; + ModuleCaches = new Dictionary(); + main_calls = new List(); + } + static List main_calls; + public Dictionary ModuleCaches; static DObj poly_div(DObj l, DObj r) @@ -50,13 +57,14 @@ static DObj poly_div(DObj l, DObj r) return l.__floordiv__(r); } + static InternString tag = "tag".toIntern(); static DObj js_new(DObj[] args) { if(args.Length < 1) throw new ArgumentException("cannot new with zero arguments."); var f = args[0]; var obj = new Dictionary(); - obj[MK.Int(0)] = f; + obj[tag] = f; args[0] = MK.Dict(obj); return f.__call__(args); } @@ -74,6 +82,13 @@ DModule ExecFromPath(string appPath, string path) var exec = DianaScriptAPIs.compileModule(ast, path); exec(globals); + var main = globals.GetValue("x_main"); + if (main is DStaticFunc f) + { + + main_calls.Add(() => f.__call__(DNone.unique)); + } + var exports = globals.GetValue("exports"); mod.fields = exported; @@ -89,14 +104,8 @@ DModule ExecFromPath(string appPath, string path) public static List funcs = new List { - MK.Func1("add", x => MK.Func1("add", y => x.__add__(y))), - MK.Func1("sub", x => MK.Func1("sub", y => x.__sub__(y))), MK.Func1("idiv", x => MK.Func1("idiv", y => MK.Int(((DInt) x).value / ((DInt) y).value ))), MK.Func1("fdiv", x => MK.Func1("fdiv", y => x.__truediv__(y))), - MK.Func1("mod", x => MK.Func1("mod", y => x.__mod__(y))), - MK.Func1("eq", x => MK.Func1("eq", y => MK.Int(x.__eq__(y)))), - MK.Func1("lt", x => MK.Func1("lt", y => MK.Int(x.__lt__(y)))), - MK.Func1("neg", x => x.__neg__()), }; void SetupNameSpace(DModule mod, string appPath) { @@ -153,17 +162,13 @@ DModule Require(DModule oldEngine, string relPath) return ExecutePathWithNewModule(absPath); } - public Impurescript(string path = null) - { - ApplicationPath = path ?? Environment.CurrentDirectory; - ModuleCaches = new Dictionary(); - } #if CONSOLE public static void Main(string[] args) { var imps = new Impurescript(); args.ToList().ForEach(imps.ExecutePath); + main_calls.ForEach(runmain => runmain()); } #endif } diff --git a/impurescript-diana/rundiana b/impurescript-diana/rundiana new file mode 100755 index 0000000..a78cde1 --- /dev/null +++ b/impurescript-diana/rundiana @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +SCRIPT_PARENT=${0%/*} +dotnet run --project "${SCRIPT_PARENT}/impurescript-diana.csproj" "$@" --no-build diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index a79fb5e..53ac7c3 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -289,6 +289,10 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = let (f, args) = unApp e [] args' <- mapM valueToJs args case f of + Var (s, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "and")) | length args == 2 -> + return $ AST.Binary (Just s) AST.And (head args') (args'!!1) + Var (s, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "or")) | length args == 2 -> + return $ AST.Binary (Just s) AST.Or (head args') (args'!!1) Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' diff --git a/src/Language/PureScript/CodeGen/Diana/Eval.hs b/src/Language/PureScript/CodeGen/Diana/Eval.hs index cf74258..2329368 100644 --- a/src/Language/PureScript/CodeGen/Diana/Eval.hs +++ b/src/Language/PureScript/CodeGen/Diana/Eval.hs @@ -23,7 +23,6 @@ import Control.Monad.State import Control.Applicative import Control.Arrow ((&&&)) - pattern Attr ps <- ArrayLiteral _ [StringLiteral _ ps] class EvalJS repr where @@ -79,6 +78,7 @@ recurIndex f ast = conciseBlock :: EvalJS repr => AST -> repr conciseBlock n = case n of + Block _ [Block _ xs] -> analyzeLoc n $ block False $ map finally xs Block _ xs -> analyzeLoc n $ block False $ map finally xs a -> finally a diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs index e505a05..a6bc1a4 100644 --- a/src/Language/PureScript/CodeGen/Diana/Serializer.hs +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -55,7 +55,6 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where New -> error "fatal" binary op l r = do - -- actually this will not be called in ImPureScript l <- l r <- r return $ case op of @@ -70,8 +69,8 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where LessThanOrEqualTo -> l <+> pretty "<=" <+> r GreaterThan -> l <+> pretty ">" <+> r GreaterThanOrEqualTo -> l <+> pretty ">=" <+> r - And -> l <+> pretty "and" <+> r - Or -> l <+> pretty "or" <+> r + And -> pretty "(" <> l <+> softline <> pretty "and" <+> r <> pretty ")" + Or -> pretty "(" <> l <+> softline <> pretty "or" <+> r <> pretty ")" BitwiseAnd -> l <+> pretty "&" <+> r BitwiseOr -> l <+> pretty "|" <+> r BitwiseXor -> l <+> pretty "^" <+> r @@ -167,7 +166,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where isa inst ty = do inst <- inst ty <- ty - return $ inst <> pretty "[0]" <> pretty "==" <> ty + return $ inst <> pretty "[:tag]" <> pretty "==" <> ty comment cs exp = exp located SourceLoc {line, col, filename} isStmt term = do From b5c6174fff541b27010af10640a000af113dab8b Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sun, 7 Nov 2021 13:36:47 +0900 Subject: [PATCH 11/13] add readme --- README.md | 27 ++++++++++++++++++++++++++ impurescript-diana/rt.cs | 42 ++++++++++++++++++++++++---------------- 2 files changed, 52 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index 60303eb..4a8aa59 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,30 @@ # ImpureScript for Diana Type-safe Scripting for Unity without startup time. + +## Installation + + +### PureScript-to-Diana Compiler + +```bash +stack build +export DIST_FILE="`stack path --dist-dir`/build/psdiana/psdiana" +cp $DIST_FILE +``` + +### Unity Diana Support + + +1. Install https://github.com/thautwarm/DianaScript-JIT: paste `Diana` and `Diana.*` directories into your Unity `Assets/` folder. + +2. Paste `impurescript-diana/rt.cs` into your Unity `Assets/` folder. + +3. Load Diana modules generated by (im)PuresSript: + + ```c# + string path = "$path-to-ps-project/output/Main/@main.diana"; + var loader = new Impurescript(); + loader.Exec(path)๏ผ› + ``` + diff --git a/impurescript-diana/rt.cs b/impurescript-diana/rt.cs index e3ed8b4..cb4e8a1 100644 --- a/impurescript-diana/rt.cs +++ b/impurescript-diana/rt.cs @@ -35,7 +35,20 @@ public static DObj GetValue(this NameSpace self, string v) [Serializable] public class Impurescript { + +#if CONSOLE + public static void Main(string[] args) + { + var imps = new Impurescript(); + args.ToList().ForEach(imps.LoadFromPath); + main_calls.ForEach(runmain => runmain()); + main_calls.Clear(); + } +#endif + public string ApplicationPath; + static List main_calls; + public Dictionary ModuleCaches; public Impurescript(string path = null) { @@ -43,9 +56,14 @@ public Impurescript(string path = null) ModuleCaches = new Dictionary(); main_calls = new List(); } - static List main_calls; + - public Dictionary ModuleCaches; + public void Exec(string path) + { + LoadFromPath(path); + main_calls.ForEach(runmain => runmain()); + main_calls.Clear(); + } static DObj poly_div(DObj l, DObj r) { @@ -60,7 +78,7 @@ static DObj poly_div(DObj l, DObj r) static InternString tag = "tag".toIntern(); static DObj js_new(DObj[] args) { - if(args.Length < 1) + if (args.Length < 1) throw new ArgumentException("cannot new with zero arguments."); var f = args[0]; var obj = new Dictionary(); @@ -85,7 +103,7 @@ DModule ExecFromPath(string appPath, string path) var main = globals.GetValue("x_main"); if (main is DStaticFunc f) { - + main_calls.Add(() => f.__call__(DNone.unique)); } @@ -115,11 +133,11 @@ void SetupNameSpace(DModule mod, string appPath) mod.SetValue("module", mod); mod.SetValue("require", MK.Func1("require", x => Require(mod, (string)(DString)x))); - foreach(var func in funcs) + foreach (var func in funcs) { mod.SetValue("_" + func.name, func); } - + } string AbsRelativePath(string relativeToAbs, string absPath) @@ -150,7 +168,7 @@ DModule ExecutePathWithNewModule(string absPath) return ExecFromPath(appPath, absPath); } - public void ExecutePath(string relPath) + public void LoadFromPath(string relPath) { var absPath = Path.GetFullPath(relPath); ExecutePathWithNewModule(absPath); @@ -161,15 +179,5 @@ DModule Require(DModule oldEngine, string relPath) var absPath = resolveAbsPathFromCurrent(oldEngine, relPath); return ExecutePathWithNewModule(absPath); } - - -#if CONSOLE - public static void Main(string[] args) - { - var imps = new Impurescript(); - args.ToList().ForEach(imps.ExecutePath); - main_calls.ForEach(runmain => runmain()); - } -#endif } } \ No newline at end of file From 53253ad8558fcc5e30e564128d410734eca6b3e5 Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sun, 7 Nov 2021 13:38:05 +0900 Subject: [PATCH 12/13] update readme --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4a8aa59..e34a419 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ cp $DIST_FILE 1. Install https://github.com/thautwarm/DianaScript-JIT: paste `Diana` and `Diana.*` directories into your Unity `Assets/` folder. -2. Paste `impurescript-diana/rt.cs` into your Unity `Assets/` folder. +2. Paste [impurescript-diana/rt.cs](https://github.com/thautwarm/impurescript-diana/tree/main/impurescript-diana) into your Unity `Assets/` folder. 3. Load Diana modules generated by (im)PuresSript: From dafce75f4c9f077ec801136b7de0cdf47fe6827e Mon Sep 17 00:00:00 2001 From: thautwarm Date: Sun, 7 Nov 2021 18:13:12 +0900 Subject: [PATCH 13/13] tco --- DianaScript-JIT | 2 +- src/Language/PureScript/CodeGen/Diana.hs | 23 ++++++------- src/Language/PureScript/CodeGen/Diana/Eval.hs | 6 ++-- .../PureScript/CodeGen/Diana/Serializer.hs | 34 ++++++++++++------- 4 files changed, 37 insertions(+), 28 deletions(-) diff --git a/DianaScript-JIT b/DianaScript-JIT index 439f234..bc0c7e3 160000 --- a/DianaScript-JIT +++ b/DianaScript-JIT @@ -1 +1 @@ -Subproject commit 439f2341abe13c4df643161decc90efc7765192b +Subproject commit bc0c7e3085fb974649f138ef46527cf1a259e4f8 diff --git a/src/Language/PureScript/CodeGen/Diana.hs b/src/Language/PureScript/CodeGen/Diana.hs index 53ac7c3..8a51ddc 100644 --- a/src/Language/PureScript/CodeGen/Diana.hs +++ b/src/Language/PureScript/CodeGen/Diana.hs @@ -282,21 +282,22 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = valueToJs' (Abs _ arg val) = do ret <- valueToJs val let jsArg = case arg of - UnusedIdent -> [] - _ -> [identToDiana arg] + UnusedIdent -> [] + Ident "$__unused" -> [] + _ -> [identToDiana arg] return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret]) - valueToJs' e@App{} = do + valueToJs' e@(App (s, _, _, _) _ _) = do let (f, args) = unApp e [] args' <- mapM valueToJs args case f of - Var (s, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "and")) | length args == 2 -> + Var (_, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "and")) | length args == 2 -> return $ AST.Binary (Just s) AST.And (head args') (args'!!1) - Var (s, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "or")) | length args == 2 -> + Var (_, _, _, _) (Qualified (Just (ModuleName "Diana")) (Ident "or")) | length args == 2 -> return $ AST.Binary (Just s) AST.Or (head args') (args'!!1) Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> - return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' - _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f + return $ AST.Unary (Just s) AST.New $ AST.App (Just s) (qualifiedToJS id name) args' + _ -> flip (foldl (\fn a -> AST.App (Just s) fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) @@ -406,12 +407,10 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = failedPatternError :: [Text] -> AST failedPatternError names = - let joinStr = accessorString "join" (AST.StringLiteral Nothing "str") - in AST.App Nothing (AST.Var Nothing $ unmangle "Error") - [ AST.Binary Nothing AST.Add + let joinStr = accessorString "join" (AST.Var Nothing $ unmangle "Str") + in AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) $ AST.App Nothing joinStr [AST.StringLiteral Nothing ",", AST.ArrayLiteral Nothing $ zipWith valueError names vals] - ] failedPatternMessage :: Text failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": " @@ -422,7 +421,7 @@ moduleToJS (Module _ coms mn _ imps exps reExps foreigns decls) _ = valueError _ l@(AST.BooleanLiteral _ _) = l -- Newing an object produces such a Python programs -- `new A(b, c) -> tmp = {".t" : A}; A(b, c, this=tmp); return tmp - valueError s _ = indexerString "class" $ AST.Var Nothing s + valueError s _ = AST.Indexer Nothing (AST.Var Nothing $ unmangle ":tag") $ AST.Var Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST] guardsToJs (Left gs) = traverse genGuard gs where diff --git a/src/Language/PureScript/CodeGen/Diana/Eval.hs b/src/Language/PureScript/CodeGen/Diana/Eval.hs index 2329368..17aae11 100644 --- a/src/Language/PureScript/CodeGen/Diana/Eval.hs +++ b/src/Language/PureScript/CodeGen/Diana/Eval.hs @@ -78,7 +78,7 @@ recurIndex f ast = conciseBlock :: EvalJS repr => AST -> repr conciseBlock n = case n of - Block _ [Block _ xs] -> analyzeLoc n $ block False $ map finally xs + Block _ [x] -> analyzeLoc n $ conciseBlock x Block _ xs -> analyzeLoc n $ block False $ map finally xs a -> finally a @@ -108,7 +108,7 @@ finally n = loc $ case n of | otherwise -> func (Just $ mkName fn) (map mkName args) $ conciseBlock body Function _ Nothing args body -> - func Nothing (map mkName args) $ finally body + func Nothing (map mkName args) $ conciseBlock body Indexer _ (Attr ps) base -> getAttr (finally base) (decodeStringWithReplacement ps) @@ -132,6 +132,7 @@ finally n = loc $ case n of -- special names must in form of be `Var _` and not LHS Var _ n -> var (mkName n) + Block _ [x] -> finally x Block _ xs -> block True $ map finally xs VariableIntroduction _ n Nothing -> @@ -204,5 +205,4 @@ isStmt a = case a of For {} -> True VariableIntroduction {} -> True Assignment {} -> True - Block _ _ -> True _ -> False \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/Diana/Serializer.hs b/src/Language/PureScript/CodeGen/Diana/Serializer.hs index a6bc1a4..e029b2c 100644 --- a/src/Language/PureScript/CodeGen/Diana/Serializer.hs +++ b/src/Language/PureScript/CodeGen/Diana/Serializer.hs @@ -13,7 +13,7 @@ import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (fromJust) import qualified Data.Text as T -import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc hiding (tupled, encloseSep) import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.Diana.Common import Language.PureScript.CodeGen.Diana.Eval @@ -29,6 +29,16 @@ optional Nothing = pretty "None" pattern Optional a <- (optional -> a) + +encloseSep l r sep xs = + l <+> encloseSepImpl sep xs <+> r + where + encloseSepImpl sep [] = emptyDoc + encloseSepImpl sep [x] = x + encloseSepImpl sep (x:xs) = x <+> sep <> softline <+> encloseSepImpl sep xs + +tupled = encloseSep (pretty "(") (pretty ")") comma + instance EvalJS (State (M.Map String Int) (Doc a)) where none = return $ pretty "None" intLit i = return $ pretty i @@ -40,7 +50,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where o <- o return (pretty (escape field) <> pretty ":" <+> o) xs <- mapM meach xs - return $ align (encloseSep (pretty "{") (pretty "}") comma xs) + return $ encloseSep (pretty "{") (pretty "}") comma xs arrayLit xs = do xs <- sequence xs @@ -99,7 +109,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where let n = case n' of Nothing -> T.pack "" Just (MustNorm n) -> n - return $ vsep [pretty "fun" <+> pretty n <> tupled (map (pretty . forceNorm) args), align $ vsep [body, pretty "end"]] + return $ vsep [pretty "fun" <+> pretty n <> tupled (map (pretty . forceNorm) args), indent 4 body, pretty "end"] app f args = do f <- f @@ -112,7 +122,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where block useRealBlockExpr suite | useRealBlockExpr = do suite <- sequence suite - return $ vsep [pretty "begin", align $ vsep [indent 2 (vsep suite), pretty "end"]] + return $ vsep [pretty "begin", indent 2 (vsep suite), pretty "end"] | otherwise = do suite <- sequence suite return $ indent 4 $ vsep suite @@ -132,11 +142,8 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where return $ vsep [ pretty "while" <+> cond <+> pretty "do", - align $ - vsep - [ body, - pretty "end" - ] + indent 4 body, + pretty "end" ] forRange (MustNorm n) low high body = do low <- low @@ -145,17 +152,18 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where return $ vsep [ pretty "for" <+> pretty "n" <+> pretty "in" <+> ranger <> tupled [low, high] <+> pretty "do", - align $ vsep [body, pretty "end"] + indent 4 body, + pretty "end" ] ite cond te Nothing = do cond <- cond te <- te - return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [te, pretty "end"]] + return $ vsep [pretty "if" <+> cond <+> pretty "then", indent 4 te, pretty "end"] ite cond te (Just fe) = do cond <- cond te <- te fe <- fe - return $ vsep [pretty "if" <+> cond <+> pretty "then", align $ vsep [te, pretty "else", indent (-4) fe, pretty "end"]] + return $ vsep [pretty "if" <+> cond <+> pretty "then", indent 4 te, pretty "else", fe, pretty "end"] ret v = do v <- v return $ pretty "return" <+> v @@ -191,6 +199,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where <+> term else return $ + pretty "(" <> pretty "__META" <+> pretty i <> pretty ":" <> pretty (toInteger line) @@ -198,6 +207,7 @@ instance EvalJS (State (M.Map String Int) (Doc a)) where <> pretty (toInteger col) <+> pretty "in" <+> term + <> pretty ")" runDoc :: State (M.Map String Int) (Doc a) -> Doc a runDoc m =