diff --git a/.github/workflows/ghcjs-base.yml b/.github/workflows/ghcjs-base.yml deleted file mode 100644 index e9cd6a7..0000000 --- a/.github/workflows/ghcjs-base.yml +++ /dev/null @@ -1,43 +0,0 @@ -name: ghcjs-base - -on: - pull_request: - -jobs: - build: - runs-on: ubuntu-latest - - defaults: - run: - shell: devx {0} - - steps: - - uses: actions/checkout@v3 - # - uses: mymindstorm/setup-emsdk@v11 - # - uses: cachix/install-nix-action@v22 - # - uses: haskell/actions/setup@v2 - - # - name: Install GHC - # run: nix develop github:input-output-hk/devx#ghc962-js - - - name: Install GHC - uses: input-output-hk/actions/devx@latest - with: - platform: x86_64-linux - target-platform: "-js" - minimal: true - compiler-nix-name: ghc98 - - - name: Cabal - run: file $(which cabal) - - - name: Info - run: javascript-unknown-ghcjs-ghc --info - - - name: Build - run: | - cabal update - cabal build all - - - name: Test - run: cabal test test:tests diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml new file mode 100644 index 0000000..08458fd --- /dev/null +++ b/.github/workflows/main.yml @@ -0,0 +1,28 @@ +name: Build + +on: + push: + branches: master + pull_request: + +permissions: + contents: read + pages: write + id-token: write + +jobs: + build: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: cachix/install-nix-action@v31 + with: + github_access_token: ${{ secrets.GITHUB_TOKEN }} + + - name: Build using 9.12.2 JS backend + run: nix develop .#ghcjs --command bash -c "make js" + + - name: Build using 9.12.2 WASM backend + run: nix develop .#wasm --command bash -c "make" diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..9690ac5 --- /dev/null +++ b/Makefile @@ -0,0 +1,20 @@ +.PHONY= update build clean buildjs + +all: update build + +js: clean buildjs + +update: + wasm32-wasi-cabal update + +build: + wasm32-wasi-cabal build + +clean: + cabal clean + +buildjs: + cabal build ghcjs-base --with-compiler=javascript-unknown-ghcjs-ghc --with-hc-pkg=javascript-unknown-ghcjs-ghc-pkg + +testjs: + cabal build exe:tests --with-compiler=javascript-unknown-ghcjs-ghc --with-hc-pkg=javascript-unknown-ghcjs-ghc-pkg --with-hsc2hs=javascript-unknown-ghcjs-hsc2hs diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..039268c --- /dev/null +++ b/flake.lock @@ -0,0 +1,849 @@ +{ + "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_2": { + "inputs": { + "systems": "systems_2" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_3": { + "inputs": { + "systems": "systems_3" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_4": { + "inputs": { + "systems": "systems_4" + }, + "locked": { + "lastModified": 1726560853, + "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "ghc-wasm-meta": { + "inputs": { + "flake-utils": "flake-utils_2", + "nixpkgs": "nixpkgs" + }, + "locked": { + "host": "gitlab.haskell.org", + "lastModified": 1756685280, + "narHash": "sha256-XXi1OmL9SeS4a+dwtjr9waBf1rwQNRpi2RcBp4sNSTc=", + "owner": "haskell-wasm", + "repo": "ghc-wasm-meta", + "rev": "a3d155c399021c8bf387f52c8f902f3c6633fb30", + "type": "gitlab" + }, + "original": { + "host": "gitlab.haskell.org", + "owner": "haskell-wasm", + "repo": "ghc-wasm-meta", + "type": "gitlab" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1745454330, + "narHash": "sha256-MA9xYIHwc1JcffoUx1toBCpcmmx1MYqi4Ds9n+iP8Ig=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "989ae6c63d1f2fcee69aa7f126010ac5844e1637", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage-for-stackage": { + "flake": false, + "locked": { + "lastModified": 1745454319, + "narHash": "sha256-SCBdlrFg1TmVqrrM6UWLuE+dhfDV5cKrNgdFTaR91gE=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "cfa745733399e92f1214d94e26e22f9f721702ba", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "for-stackage", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskell-ci": { + "flake": false, + "locked": { + "lastModified": 1743351534, + "narHash": "sha256-oowOok6+RLk7n6vHWwYufxyUmUpun/VMo8hXpfm1+d8=", + "owner": "haskell-CI", + "repo": "haskell-ci", + "rev": "f0fd898ab14070fa46e9fd542a2b487a8146d88e", + "type": "github" + }, + "original": { + "owner": "haskell-CI", + "repo": "haskell-ci", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "hackage": "hackage", + "hackage-for-stackage": "hackage-for-stackage", + "hls": "hls", + "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.10": "hls-2.10", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hls-2.7": "hls-2.7", + "hls-2.8": "hls-2.8", + "hls-2.9": "hls-2.9", + "hpc-coveralls": "hpc-coveralls", + "iserv-proxy": "iserv-proxy", + "nixpkgs": [ + "miso", + "jsaddle", + "haskellNix", + "nixpkgs-unstable" + ], + "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-2405": "nixpkgs-2405", + "nixpkgs-2411": "nixpkgs-2411", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1745455900, + "narHash": "sha256-H2EyIfyi9PsTARBzsjwfyPgniFgPOQLAX8nkrvKMQOU=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "cafa5223a5411fa7545f21d76e9b8743f4d00c29", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hls": { + "flake": false, + "locked": { + "lastModified": 1741604408, + "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "682d6894c94087da5e566771f25311c47e145359", + "type": "github" + }, + "original": { + "owner": "haskell", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-1.10": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.10": { + "flake": false, + "locked": { + "lastModified": 1743069404, + "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.7": { + "flake": false, + "locked": { + "lastModified": 1708965829, + "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.7.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.8": { + "flake": false, + "locked": { + "lastModified": 1715153580, + "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.8.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.9": { + "flake": false, + "locked": { + "lastModified": 1719993701, + "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.9.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1742121966, + "narHash": "sha256-x4bg4OoKAPnayom0nWc0BmlxgRMMHk6lEPvbiyFBq1s=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "e9dc86ed6ad71f0368c16672081c8f26406c3a7e", + "type": "github" + }, + "original": { + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", + "type": "github" + } + }, + "jsaddle": { + "inputs": { + "flake-utils": "flake-utils_3", + "haskell-ci": "haskell-ci", + "haskellNix": "haskellNix", + "nixpkgs": [ + "miso", + "jsaddle", + "haskellNix", + "nixpkgs-unstable" + ] + }, + "locked": { + "lastModified": 1756701389, + "narHash": "sha256-WUXl+5QfhsZKf6V+h0qhl6Jgy6SzR3HzMQsfbWL0jkE=", + "owner": "ghcjs", + "repo": "jsaddle", + "rev": "0fb7260ad02592546c9f180078d770256fb1f0f6", + "type": "github" + }, + "original": { + "owner": "ghcjs", + "repo": "jsaddle", + "rev": "0fb7260ad02592546c9f180078d770256fb1f0f6", + "type": "github" + } + }, + "miso": { + "inputs": { + "flake-utils": "flake-utils", + "ghc-wasm-meta": "ghc-wasm-meta", + "jsaddle": "jsaddle", + "nixpkgs": "nixpkgs_2", + "servant": "servant" + }, + "locked": { + "lastModified": 1758149815, + "narHash": "sha256-lpO3NJhFzopCShz1McIHdB5i3/ukhXmLtpiw773vPEk=", + "owner": "dmjio", + "repo": "miso", + "rev": "fe06431b7bad39a99282119b85ad42fa86809867", + "type": "github" + }, + "original": { + "owner": "dmjio", + "repo": "miso", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1755767206, + "narHash": "sha256-yi+50PemAF64H5sA4Bl3RYzz3Yniw0538SPLl3DxGU0=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "f90bda01c396f058bfe42d0cecb4ba776160a953", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1705033721, + "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1719957072, + "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2405": { + "locked": { + "lastModified": 1735564410, + "narHash": "sha256-HB/FA0+1gpSs8+/boEavrGJH+Eq08/R2wWNph1sM1Dg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1e7a8f391f1a490460760065fa0630b5520f9cf8", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2411": { + "locked": { + "lastModified": 1739151041, + "narHash": "sha256-uNszcul7y++oBiyYXjHEDw/AHeLNp8B6pyWOB+RLA/4=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "94792ab2a6beaec81424445bf917ca2556fbeade", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-unstable": { + "locked": { + "lastModified": 1737110817, + "narHash": "sha256-DSenga8XjPaUV5KUFW/i3rNkN7jm9XmguW+qQ1ZJTR4=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "041c867bad68dfe34b78b2813028a2e2ea70a23c", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1751996040, + "narHash": "sha256-DOjNE+DYZ/YZo1UkXcJNlvSKEBowWATX6o4s0WuAzuA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "9e2e8a7878573d312db421d69e071690ec34e98c", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "9e2e8a7878573d312db421d69e071690ec34e98c", + "type": "github" + } + }, + "nixpkgs_3": { + "locked": { + "lastModified": 1728940272, + "narHash": "sha256-zVl25LPDCt1l34AS7Ba4MPTxHQ8tkFL2hxVGEntmngI=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "8eec6bbcf05c919b19ce8dfb3f96cc4585d30cce", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "root": { + "inputs": { + "miso": "miso" + } + }, + "servant": { + "inputs": { + "flake-utils": "flake-utils_4", + "nixpkgs": "nixpkgs_3" + }, + "locked": { + "lastModified": 1747753492, + "narHash": "sha256-zWlU6/7MU0J/amOSZHEgVltMN9K4luNK1JV6irM9ozM=", + "owner": "haskell-servant", + "repo": "servant", + "rev": "e07e92abd62641fc0f199a33e5131de273140cb0", + "type": "github" + }, + "original": { + "owner": "haskell-servant", + "repo": "servant", + "rev": "e07e92abd62641fc0f199a33e5131de273140cb0", + "type": "github" + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1745453555, + "narHash": "sha256-UdWBshU4hyz5Q76yqxvkhbc+ywAYeQtrigyUnOGTaV4=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "077ab84d76fdcd96ba879b135f35c1edb853fcd2", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_2": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_3": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_4": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..2268501 --- /dev/null +++ b/flake.nix @@ -0,0 +1,15 @@ +{ + + inputs = { + miso.url = "github:dmjio/miso"; + }; + + outputs = inputs: + inputs.miso.inputs.flake-utils.lib.eachDefaultSystem (system: { + devShell = inputs.miso.outputs.devShells.${system}.default; + devShells.wasm = inputs.miso.outputs.devShells.${system}.wasm; + devShells.ghcjs = inputs.miso.outputs.devShells.${system}.ghcjs; + }); + +} + diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index 19d101e..8437ec6 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -14,150 +14,202 @@ source-repository head type: git location: https://github.com/ghcjs/ghcjs-base +common wasm + if arch(wasm32) + hs-source-dirs: src-wasm + +common js + if arch(javascript) + hs-source-dirs: + src-js + js-sources: + jsbits/array.js + jsbits/animationFrame.js + jsbits/buffer.js + jsbits/export.js + jsbits/jsstring.js + jsbits/jsstringRaw.js + jsbits/foreign.js + jsbits/text.js + jsbits/utils.js + jsbits/xhr.js + jsbits/websocket.js + library - js-sources: jsbits/array.js - jsbits/animationFrame.js - jsbits/buffer.js - jsbits/export.js - jsbits/jsstring.js - jsbits/jsstringRaw.js - jsbits/foreign.js - jsbits/text.js - jsbits/utils.js - jsbits/xhr.js - jsbits/websocket.js - other-extensions: DeriveDataTypeable - DeriveGeneric - ForeignFunctionInterface - GHCForeignImportPrim - MagicHash - UnboxedTuples - TypeFamilies - CPP - UnliftedFFITypes - BangPatterns - ScopedTypeVariables - FlexibleInstances - TypeSynonymInstances - ViewPatterns --- NegativeLiterals --- fixme do we need negativeliterals? - DefaultSignatures - EmptyDataDecls - OverloadedStrings - Rank2Types - ExistentialQuantification - GeneralizedNewtypeDeriving - ScopedTypeVariables - TypeOperators + import: + wasm, js + default-language: + Haskell2010 + build-depends: + base >= 4.18 && < 5, + binary >= 0.8 && < 0.11, + bytestring >= 0.10 && < 0.13, + text >= 2.0 && < 2.2, + aeson >= 0.8 && < 2.3, + scientific >= 0.3.7 && < 0.4, + vector >= 0.10 && < 0.14, + containers >= 0.5 && < 0.9, + time >= 1.5 && < 1.15, + hashable >= 1.2 && < 1.6, + unordered-containers >= 0.2 && < 0.3, + attoparsec >= 0.11 && < 0.15, + transformers >= 0.3 && < 0.7, + primitive >= 0.5 && < 0.10, + deepseq >= 1.3 && < 1.6, + dlist >= 0.7 && < 1.1, + ghc-experimental, + ghc-prim - exposed-modules: Data.JSString - Data.JSString.Int - Data.JSString.Raw - Data.JSString.Read - Data.JSString.RealFloat - Data.JSString.RegExp - Data.JSString.Internal - Data.JSString.Text - Data.JSString.Internal.Fusion - Data.JSString.Internal.Fusion.Types - Data.JSString.Internal.Fusion.Common - Data.JSString.Internal.Fusion.CaseMapping - Data.JSString.Internal.Search - GHCJS.Buffer - GHCJS.Buffer.Types - GHCJS.Concurrent - GHCJS.Foreign - GHCJS.Foreign.Export - GHCJS.Foreign.Internal - GHCJS.Marshal - GHCJS.Marshal.Internal - GHCJS.Marshal.Pure - GHCJS.Nullable - GHCJS.Types - JavaScript.Array - JavaScript.Array.Internal - JavaScript.Array.ST - JavaScript.Cast - JavaScript.JSON - JavaScript.JSON.Types - JavaScript.JSON.Types.Class - JavaScript.JSON.Types.Generic - JavaScript.JSON.Types.Instances - JavaScript.JSON.Types.Internal - JavaScript.Number - JavaScript.Object - JavaScript.Object.Internal - JavaScript.RegExp - JavaScript.TypedArray - JavaScript.TypedArray.ArrayBuffer - JavaScript.TypedArray.ArrayBuffer.ST - JavaScript.TypedArray.DataView - JavaScript.TypedArray.DataView.ST - JavaScript.TypedArray.Internal - JavaScript.TypedArray.ST - JavaScript.Web.AnimationFrame - JavaScript.Web.Blob - JavaScript.Web.Blob.Internal - JavaScript.Web.Canvas - JavaScript.Web.Canvas.ImageData - JavaScript.Web.Canvas.Internal - JavaScript.Web.Canvas.TextMetrics - JavaScript.Web.CloseEvent - JavaScript.Web.CloseEvent.Internal - JavaScript.Web.ErrorEvent - JavaScript.Web.ErrorEvent.Internal - JavaScript.Web.File - JavaScript.Web.History - JavaScript.Web.Location - JavaScript.Web.MessageEvent - JavaScript.Web.MessageEvent.Internal - JavaScript.Web.Performance - JavaScript.Web.Storage - JavaScript.Web.Storage.Internal - JavaScript.Web.StorageEvent - JavaScript.Web.XMLHttpRequest - JavaScript.Web.WebSocket - JavaScript.Web.Worker - other-modules: GHCJS.Internal.Types - Data.JSString.Internal.Type - JavaScript.TypedArray.Internal.Types - JavaScript.TypedArray.ArrayBuffer.Internal - JavaScript.TypedArray.DataView.Internal - build-depends: base >= 4.18 && < 5, - ghc-prim, - binary >= 0.8 && < 0.11, - bytestring >= 0.10 && < 0.13, - -- text internals need to be utf8 (text <2.0 is utf16) - text >= 2.0 && < 2.2, - aeson >= 0.8 && < 2.3, - scientific >= 0.3.7 && < 0.4, - vector >= 0.10 && < 0.14, - containers >= 0.5 && < 0.9, - time >= 1.5 && < 1.15, - hashable >= 1.2 && < 1.6, - unordered-containers >= 0.2 && < 0.3, - attoparsec >= 0.11 && < 0.15, - transformers >= 0.3 && < 0.7, - primitive >= 0.5 && < 0.10, - deepseq >= 1.3 && < 1.6, - dlist >= 0.7 && < 1.1 - default-language: Haskell2010 - if !arch(javascript) + if arch(wasm32) + exposed-modules: + Data.JSString + Data.JSString.Internal + Data.JSString.Internal.Fusion + Data.JSString.Internal.Fusion.CaseMapping + Data.JSString.Internal.Fusion.Common + Data.JSString.Internal.Fusion.Types + Data.JSString.Internal.Search + Data.JSString.Text + GHCJS.Buffer + GHCJS.Buffer.Types + GHCJS.Concurrent + GHCJS.Foreign + GHCJS.Foreign.Internal + GHCJS.Marshal + GHCJS.Marshal.Internal + GHCJS.Marshal.Pure + GHCJS.Types + JavaScript.Array + JavaScript.Array.Internal + JavaScript.Object + JavaScript.Object.Internal + JavaScript.TypedArray + JavaScript.TypedArray.ArrayBuffer + JavaScript.TypedArray.Internal + other-modules: + GHCJS.Internal.Types + Data.JSString.Internal.Type + JavaScript.TypedArray.Internal.Types + JavaScript.TypedArray.ArrayBuffer.Internal + + if arch(javascript) + exposed-modules: + Data.JSString + Data.JSString.Int + Data.JSString.Raw + Data.JSString.Read + Data.JSString.RealFloat + Data.JSString.RegExp + Data.JSString.Internal + Data.JSString.Text + Data.JSString.Internal.Fusion + Data.JSString.Internal.Fusion.Types + Data.JSString.Internal.Fusion.Common + Data.JSString.Internal.Fusion.CaseMapping + Data.JSString.Internal.Search + GHCJS.Buffer + GHCJS.Buffer.Types + GHCJS.Concurrent + GHCJS.Foreign + GHCJS.Foreign.Export + GHCJS.Foreign.Internal + GHCJS.Marshal + GHCJS.Marshal.Internal + GHCJS.Marshal.Pure + GHCJS.Nullable + GHCJS.Types + JavaScript.Array + JavaScript.Array.Internal + JavaScript.Array.ST + JavaScript.Cast + JavaScript.JSON + JavaScript.JSON.Types + JavaScript.JSON.Types.Class + JavaScript.JSON.Types.Generic + JavaScript.JSON.Types.Instances + JavaScript.JSON.Types.Internal + JavaScript.Number + JavaScript.Object + JavaScript.Object.Internal + JavaScript.RegExp + JavaScript.TypedArray + JavaScript.TypedArray.ArrayBuffer + JavaScript.TypedArray.ArrayBuffer.ST + JavaScript.TypedArray.DataView + JavaScript.TypedArray.DataView.ST + JavaScript.TypedArray.Internal + JavaScript.TypedArray.ST + JavaScript.Web.AnimationFrame + JavaScript.Web.Blob + JavaScript.Web.Blob.Internal + JavaScript.Web.Canvas + JavaScript.Web.Canvas.ImageData + JavaScript.Web.Canvas.Internal + JavaScript.Web.Canvas.TextMetrics + JavaScript.Web.CloseEvent + JavaScript.Web.CloseEvent.Internal + JavaScript.Web.ErrorEvent + JavaScript.Web.ErrorEvent.Internal + JavaScript.Web.File + JavaScript.Web.History + JavaScript.Web.Location + JavaScript.Web.MessageEvent + JavaScript.Web.MessageEvent.Internal + JavaScript.Web.Performance + JavaScript.Web.Storage + JavaScript.Web.Storage.Internal + JavaScript.Web.StorageEvent + JavaScript.Web.XMLHttpRequest + JavaScript.Web.WebSocket + JavaScript.Web.Worker + other-modules: + GHCJS.Internal.Types + Data.JSString.Internal.Type + JavaScript.TypedArray.Internal.Types + JavaScript.TypedArray.ArrayBuffer.Internal + JavaScript.TypedArray.DataView.Internal + + other-extensions: + DeriveDataTypeable + DeriveGeneric + ForeignFunctionInterface + GHCForeignImportPrim + MagicHash + UnboxedTuples + TypeFamilies + CPP + UnliftedFFITypes + BangPatterns + ScopedTypeVariables + FlexibleInstances + TypeSynonymInstances + ViewPatterns + DefaultSignatures + EmptyDataDecls + OverloadedStrings + Rank2Types + ExistentialQuantification + GeneralizedNewtypeDeriving + ScopedTypeVariables + TypeOperators + + if !arch(javascript) && !arch(wasm32) buildable: False -test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Tests.hs - other-modules: Tests.Marshal - Tests.Properties - Tests.Properties.Numeric - Tests.SlowFunctions - Tests.QuickCheckUtils - Tests.Regressions - Tests.Utils - Tests.Buffer +executable tests + hs-source-dirs: + test + main-is: + Tests.hs + other-modules: + Tests.Marshal + Tests.Properties + Tests.Properties.Numeric + Tests.SlowFunctions + Tests.QuickCheckUtils + Tests.Regressions + Tests.Utils + Tests.Buffer ghc-options: -Wall -rtsopts test/compat.js build-depends: @@ -177,6 +229,9 @@ test-suite tests test-framework >= 0.4, test-framework-hunit >= 0.2, test-framework-quickcheck2 >= 0.2 - default-language: Haskell2010 + + default-language: + Haskell2010 + if !arch(javascript) buildable: False diff --git a/Data/JSString.hs b/src-js/Data/JSString.hs similarity index 100% rename from Data/JSString.hs rename to src-js/Data/JSString.hs diff --git a/Data/JSString/Int.hs b/src-js/Data/JSString/Int.hs similarity index 100% rename from Data/JSString/Int.hs rename to src-js/Data/JSString/Int.hs diff --git a/Data/JSString/Internal.hs b/src-js/Data/JSString/Internal.hs similarity index 100% rename from Data/JSString/Internal.hs rename to src-js/Data/JSString/Internal.hs diff --git a/Data/JSString/Internal/Fusion.hs b/src-js/Data/JSString/Internal/Fusion.hs similarity index 100% rename from Data/JSString/Internal/Fusion.hs rename to src-js/Data/JSString/Internal/Fusion.hs diff --git a/Data/JSString/Internal/Fusion/CaseMapping.hs b/src-js/Data/JSString/Internal/Fusion/CaseMapping.hs similarity index 100% rename from Data/JSString/Internal/Fusion/CaseMapping.hs rename to src-js/Data/JSString/Internal/Fusion/CaseMapping.hs diff --git a/Data/JSString/Internal/Fusion/Common.hs b/src-js/Data/JSString/Internal/Fusion/Common.hs similarity index 100% rename from Data/JSString/Internal/Fusion/Common.hs rename to src-js/Data/JSString/Internal/Fusion/Common.hs diff --git a/Data/JSString/Internal/Fusion/Types.hs b/src-js/Data/JSString/Internal/Fusion/Types.hs similarity index 100% rename from Data/JSString/Internal/Fusion/Types.hs rename to src-js/Data/JSString/Internal/Fusion/Types.hs diff --git a/Data/JSString/Internal/Search.hs b/src-js/Data/JSString/Internal/Search.hs similarity index 100% rename from Data/JSString/Internal/Search.hs rename to src-js/Data/JSString/Internal/Search.hs diff --git a/Data/JSString/Internal/Type.hs b/src-js/Data/JSString/Internal/Type.hs similarity index 100% rename from Data/JSString/Internal/Type.hs rename to src-js/Data/JSString/Internal/Type.hs diff --git a/Data/JSString/Raw.hs b/src-js/Data/JSString/Raw.hs similarity index 100% rename from Data/JSString/Raw.hs rename to src-js/Data/JSString/Raw.hs diff --git a/Data/JSString/Read.hs b/src-js/Data/JSString/Read.hs similarity index 100% rename from Data/JSString/Read.hs rename to src-js/Data/JSString/Read.hs diff --git a/Data/JSString/RealFloat.hs b/src-js/Data/JSString/RealFloat.hs similarity index 100% rename from Data/JSString/RealFloat.hs rename to src-js/Data/JSString/RealFloat.hs diff --git a/Data/JSString/RegExp.hs b/src-js/Data/JSString/RegExp.hs similarity index 100% rename from Data/JSString/RegExp.hs rename to src-js/Data/JSString/RegExp.hs diff --git a/Data/JSString/Text.hs b/src-js/Data/JSString/Text.hs similarity index 100% rename from Data/JSString/Text.hs rename to src-js/Data/JSString/Text.hs diff --git a/GHCJS/Buffer.hs b/src-js/GHCJS/Buffer.hs similarity index 100% rename from GHCJS/Buffer.hs rename to src-js/GHCJS/Buffer.hs diff --git a/GHCJS/Buffer/Types.hs b/src-js/GHCJS/Buffer/Types.hs similarity index 100% rename from GHCJS/Buffer/Types.hs rename to src-js/GHCJS/Buffer/Types.hs diff --git a/GHCJS/Concurrent.hs b/src-js/GHCJS/Concurrent.hs similarity index 100% rename from GHCJS/Concurrent.hs rename to src-js/GHCJS/Concurrent.hs diff --git a/GHCJS/Foreign.hs b/src-js/GHCJS/Foreign.hs similarity index 100% rename from GHCJS/Foreign.hs rename to src-js/GHCJS/Foreign.hs diff --git a/GHCJS/Foreign/Export.hs b/src-js/GHCJS/Foreign/Export.hs similarity index 100% rename from GHCJS/Foreign/Export.hs rename to src-js/GHCJS/Foreign/Export.hs diff --git a/GHCJS/Foreign/Internal.hs b/src-js/GHCJS/Foreign/Internal.hs similarity index 100% rename from GHCJS/Foreign/Internal.hs rename to src-js/GHCJS/Foreign/Internal.hs diff --git a/GHCJS/Internal/Types.hs b/src-js/GHCJS/Internal/Types.hs similarity index 100% rename from GHCJS/Internal/Types.hs rename to src-js/GHCJS/Internal/Types.hs diff --git a/GHCJS/Marshal.hs b/src-js/GHCJS/Marshal.hs similarity index 100% rename from GHCJS/Marshal.hs rename to src-js/GHCJS/Marshal.hs diff --git a/GHCJS/Marshal/Internal.hs b/src-js/GHCJS/Marshal/Internal.hs similarity index 100% rename from GHCJS/Marshal/Internal.hs rename to src-js/GHCJS/Marshal/Internal.hs diff --git a/GHCJS/Marshal/Pure.hs b/src-js/GHCJS/Marshal/Pure.hs similarity index 100% rename from GHCJS/Marshal/Pure.hs rename to src-js/GHCJS/Marshal/Pure.hs diff --git a/GHCJS/Nullable.hs b/src-js/GHCJS/Nullable.hs similarity index 100% rename from GHCJS/Nullable.hs rename to src-js/GHCJS/Nullable.hs diff --git a/GHCJS/Types.hs b/src-js/GHCJS/Types.hs similarity index 100% rename from GHCJS/Types.hs rename to src-js/GHCJS/Types.hs diff --git a/JavaScript/Array.hs b/src-js/JavaScript/Array.hs similarity index 100% rename from JavaScript/Array.hs rename to src-js/JavaScript/Array.hs diff --git a/JavaScript/Array/Immutable.hs b/src-js/JavaScript/Array/Immutable.hs similarity index 100% rename from JavaScript/Array/Immutable.hs rename to src-js/JavaScript/Array/Immutable.hs diff --git a/JavaScript/Array/Internal.hs b/src-js/JavaScript/Array/Internal.hs similarity index 100% rename from JavaScript/Array/Internal.hs rename to src-js/JavaScript/Array/Internal.hs diff --git a/JavaScript/Array/ST.hs b/src-js/JavaScript/Array/ST.hs similarity index 100% rename from JavaScript/Array/ST.hs rename to src-js/JavaScript/Array/ST.hs diff --git a/JavaScript/Cast.hs b/src-js/JavaScript/Cast.hs similarity index 100% rename from JavaScript/Cast.hs rename to src-js/JavaScript/Cast.hs diff --git a/JavaScript/JSON.hs b/src-js/JavaScript/JSON.hs similarity index 100% rename from JavaScript/JSON.hs rename to src-js/JavaScript/JSON.hs diff --git a/JavaScript/JSON/Types.hs b/src-js/JavaScript/JSON/Types.hs similarity index 100% rename from JavaScript/JSON/Types.hs rename to src-js/JavaScript/JSON/Types.hs diff --git a/JavaScript/JSON/Types/Class.hs b/src-js/JavaScript/JSON/Types/Class.hs similarity index 100% rename from JavaScript/JSON/Types/Class.hs rename to src-js/JavaScript/JSON/Types/Class.hs diff --git a/JavaScript/JSON/Types/Generic.hs b/src-js/JavaScript/JSON/Types/Generic.hs similarity index 100% rename from JavaScript/JSON/Types/Generic.hs rename to src-js/JavaScript/JSON/Types/Generic.hs diff --git a/JavaScript/JSON/Types/Instances.hs b/src-js/JavaScript/JSON/Types/Instances.hs similarity index 100% rename from JavaScript/JSON/Types/Instances.hs rename to src-js/JavaScript/JSON/Types/Instances.hs diff --git a/JavaScript/JSON/Types/Internal.hs b/src-js/JavaScript/JSON/Types/Internal.hs similarity index 100% rename from JavaScript/JSON/Types/Internal.hs rename to src-js/JavaScript/JSON/Types/Internal.hs diff --git a/JavaScript/Number.hs b/src-js/JavaScript/Number.hs similarity index 100% rename from JavaScript/Number.hs rename to src-js/JavaScript/Number.hs diff --git a/JavaScript/Object.hs b/src-js/JavaScript/Object.hs similarity index 100% rename from JavaScript/Object.hs rename to src-js/JavaScript/Object.hs diff --git a/JavaScript/Object/Internal.hs b/src-js/JavaScript/Object/Internal.hs similarity index 100% rename from JavaScript/Object/Internal.hs rename to src-js/JavaScript/Object/Internal.hs diff --git a/JavaScript/RegExp.hs b/src-js/JavaScript/RegExp.hs similarity index 100% rename from JavaScript/RegExp.hs rename to src-js/JavaScript/RegExp.hs diff --git a/JavaScript/String.hs b/src-js/JavaScript/String.hs similarity index 100% rename from JavaScript/String.hs rename to src-js/JavaScript/String.hs diff --git a/JavaScript/TypedArray.hs b/src-js/JavaScript/TypedArray.hs similarity index 100% rename from JavaScript/TypedArray.hs rename to src-js/JavaScript/TypedArray.hs diff --git a/JavaScript/TypedArray/ArrayBuffer.hs b/src-js/JavaScript/TypedArray/ArrayBuffer.hs similarity index 100% rename from JavaScript/TypedArray/ArrayBuffer.hs rename to src-js/JavaScript/TypedArray/ArrayBuffer.hs diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/src-js/JavaScript/TypedArray/ArrayBuffer/Internal.hs similarity index 100% rename from JavaScript/TypedArray/ArrayBuffer/Internal.hs rename to src-js/JavaScript/TypedArray/ArrayBuffer/Internal.hs diff --git a/JavaScript/TypedArray/ArrayBuffer/ST.hs b/src-js/JavaScript/TypedArray/ArrayBuffer/ST.hs similarity index 100% rename from JavaScript/TypedArray/ArrayBuffer/ST.hs rename to src-js/JavaScript/TypedArray/ArrayBuffer/ST.hs diff --git a/JavaScript/TypedArray/ArrayBuffer/Type.hs b/src-js/JavaScript/TypedArray/ArrayBuffer/Type.hs similarity index 100% rename from JavaScript/TypedArray/ArrayBuffer/Type.hs rename to src-js/JavaScript/TypedArray/ArrayBuffer/Type.hs diff --git a/JavaScript/TypedArray/DataView.hs b/src-js/JavaScript/TypedArray/DataView.hs similarity index 100% rename from JavaScript/TypedArray/DataView.hs rename to src-js/JavaScript/TypedArray/DataView.hs diff --git a/JavaScript/TypedArray/DataView/Internal.hs b/src-js/JavaScript/TypedArray/DataView/Internal.hs similarity index 100% rename from JavaScript/TypedArray/DataView/Internal.hs rename to src-js/JavaScript/TypedArray/DataView/Internal.hs diff --git a/JavaScript/TypedArray/DataView/ST.hs b/src-js/JavaScript/TypedArray/DataView/ST.hs similarity index 100% rename from JavaScript/TypedArray/DataView/ST.hs rename to src-js/JavaScript/TypedArray/DataView/ST.hs diff --git a/JavaScript/TypedArray/Immutable.hs b/src-js/JavaScript/TypedArray/Immutable.hs similarity index 100% rename from JavaScript/TypedArray/Immutable.hs rename to src-js/JavaScript/TypedArray/Immutable.hs diff --git a/JavaScript/TypedArray/Internal.hs b/src-js/JavaScript/TypedArray/Internal.hs similarity index 100% rename from JavaScript/TypedArray/Internal.hs rename to src-js/JavaScript/TypedArray/Internal.hs diff --git a/JavaScript/TypedArray/Internal/Types.hs b/src-js/JavaScript/TypedArray/Internal/Types.hs similarity index 100% rename from JavaScript/TypedArray/Internal/Types.hs rename to src-js/JavaScript/TypedArray/Internal/Types.hs diff --git a/JavaScript/TypedArray/ST.hs b/src-js/JavaScript/TypedArray/ST.hs similarity index 100% rename from JavaScript/TypedArray/ST.hs rename to src-js/JavaScript/TypedArray/ST.hs diff --git a/JavaScript/Web/AnimationFrame.hs b/src-js/JavaScript/Web/AnimationFrame.hs similarity index 100% rename from JavaScript/Web/AnimationFrame.hs rename to src-js/JavaScript/Web/AnimationFrame.hs diff --git a/JavaScript/Web/Blob.hs b/src-js/JavaScript/Web/Blob.hs similarity index 100% rename from JavaScript/Web/Blob.hs rename to src-js/JavaScript/Web/Blob.hs diff --git a/JavaScript/Web/Blob/Internal.hs b/src-js/JavaScript/Web/Blob/Internal.hs similarity index 100% rename from JavaScript/Web/Blob/Internal.hs rename to src-js/JavaScript/Web/Blob/Internal.hs diff --git a/JavaScript/Web/Canvas.hs b/src-js/JavaScript/Web/Canvas.hs similarity index 100% rename from JavaScript/Web/Canvas.hs rename to src-js/JavaScript/Web/Canvas.hs diff --git a/JavaScript/Web/Canvas/ImageData.hs b/src-js/JavaScript/Web/Canvas/ImageData.hs similarity index 100% rename from JavaScript/Web/Canvas/ImageData.hs rename to src-js/JavaScript/Web/Canvas/ImageData.hs diff --git a/JavaScript/Web/Canvas/Internal.hs b/src-js/JavaScript/Web/Canvas/Internal.hs similarity index 100% rename from JavaScript/Web/Canvas/Internal.hs rename to src-js/JavaScript/Web/Canvas/Internal.hs diff --git a/JavaScript/Web/Canvas/Pattern.hs b/src-js/JavaScript/Web/Canvas/Pattern.hs similarity index 100% rename from JavaScript/Web/Canvas/Pattern.hs rename to src-js/JavaScript/Web/Canvas/Pattern.hs diff --git a/JavaScript/Web/Canvas/TextMetrics.hs b/src-js/JavaScript/Web/Canvas/TextMetrics.hs similarity index 100% rename from JavaScript/Web/Canvas/TextMetrics.hs rename to src-js/JavaScript/Web/Canvas/TextMetrics.hs diff --git a/JavaScript/Web/Canvas/Types.hs b/src-js/JavaScript/Web/Canvas/Types.hs similarity index 100% rename from JavaScript/Web/Canvas/Types.hs rename to src-js/JavaScript/Web/Canvas/Types.hs diff --git a/JavaScript/Web/CloseEvent.hs b/src-js/JavaScript/Web/CloseEvent.hs similarity index 100% rename from JavaScript/Web/CloseEvent.hs rename to src-js/JavaScript/Web/CloseEvent.hs diff --git a/JavaScript/Web/CloseEvent/Internal.hs b/src-js/JavaScript/Web/CloseEvent/Internal.hs similarity index 100% rename from JavaScript/Web/CloseEvent/Internal.hs rename to src-js/JavaScript/Web/CloseEvent/Internal.hs diff --git a/JavaScript/Web/ErrorEvent.hs b/src-js/JavaScript/Web/ErrorEvent.hs similarity index 100% rename from JavaScript/Web/ErrorEvent.hs rename to src-js/JavaScript/Web/ErrorEvent.hs diff --git a/JavaScript/Web/ErrorEvent/Internal.hs b/src-js/JavaScript/Web/ErrorEvent/Internal.hs similarity index 100% rename from JavaScript/Web/ErrorEvent/Internal.hs rename to src-js/JavaScript/Web/ErrorEvent/Internal.hs diff --git a/JavaScript/Web/File.hs b/src-js/JavaScript/Web/File.hs similarity index 100% rename from JavaScript/Web/File.hs rename to src-js/JavaScript/Web/File.hs diff --git a/JavaScript/Web/FileReader.hs b/src-js/JavaScript/Web/FileReader.hs similarity index 100% rename from JavaScript/Web/FileReader.hs rename to src-js/JavaScript/Web/FileReader.hs diff --git a/JavaScript/Web/History.hs b/src-js/JavaScript/Web/History.hs similarity index 100% rename from JavaScript/Web/History.hs rename to src-js/JavaScript/Web/History.hs diff --git a/JavaScript/Web/Location.hs b/src-js/JavaScript/Web/Location.hs similarity index 100% rename from JavaScript/Web/Location.hs rename to src-js/JavaScript/Web/Location.hs diff --git a/JavaScript/Web/MessageEvent.hs b/src-js/JavaScript/Web/MessageEvent.hs similarity index 100% rename from JavaScript/Web/MessageEvent.hs rename to src-js/JavaScript/Web/MessageEvent.hs diff --git a/JavaScript/Web/MessageEvent/Internal.hs b/src-js/JavaScript/Web/MessageEvent/Internal.hs similarity index 100% rename from JavaScript/Web/MessageEvent/Internal.hs rename to src-js/JavaScript/Web/MessageEvent/Internal.hs diff --git a/JavaScript/Web/Performance.hs b/src-js/JavaScript/Web/Performance.hs similarity index 100% rename from JavaScript/Web/Performance.hs rename to src-js/JavaScript/Web/Performance.hs diff --git a/JavaScript/Web/Storage.hs b/src-js/JavaScript/Web/Storage.hs similarity index 100% rename from JavaScript/Web/Storage.hs rename to src-js/JavaScript/Web/Storage.hs diff --git a/JavaScript/Web/Storage/Internal.hs b/src-js/JavaScript/Web/Storage/Internal.hs similarity index 100% rename from JavaScript/Web/Storage/Internal.hs rename to src-js/JavaScript/Web/Storage/Internal.hs diff --git a/JavaScript/Web/StorageEvent.hs b/src-js/JavaScript/Web/StorageEvent.hs similarity index 100% rename from JavaScript/Web/StorageEvent.hs rename to src-js/JavaScript/Web/StorageEvent.hs diff --git a/JavaScript/Web/WebSocket.hs b/src-js/JavaScript/Web/WebSocket.hs similarity index 100% rename from JavaScript/Web/WebSocket.hs rename to src-js/JavaScript/Web/WebSocket.hs diff --git a/JavaScript/Web/Worker.hs b/src-js/JavaScript/Web/Worker.hs similarity index 100% rename from JavaScript/Web/Worker.hs rename to src-js/JavaScript/Web/Worker.hs diff --git a/JavaScript/Web/Worker/Haskell.hs b/src-js/JavaScript/Web/Worker/Haskell.hs similarity index 100% rename from JavaScript/Web/Worker/Haskell.hs rename to src-js/JavaScript/Web/Worker/Haskell.hs diff --git a/JavaScript/Web/XMLHttpRequest.hs b/src-js/JavaScript/Web/XMLHttpRequest.hs similarity index 100% rename from JavaScript/Web/XMLHttpRequest.hs rename to src-js/JavaScript/Web/XMLHttpRequest.hs diff --git a/src-wasm/Data/JSString.hs b/src-wasm/Data/JSString.hs new file mode 100644 index 0000000..776bfcd --- /dev/null +++ b/src-wasm/Data/JSString.hs @@ -0,0 +1,1965 @@ +{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies, + ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, + GHCForeignImportPrim, CPP + #-} +{-| Manipulation of JavaScript strings, API and fusion implementation + based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a. + -} +module Data.JSString ( JSString + + -- * Creation and elimination + , pack + , unpack, unpack' + , singleton + , empty + + -- * Basic interface + , cons + , snoc + , append + , uncons + , unsnoc + , head + , last + , tail + , init + , null + , length + , compareLength + + -- * Transformations + , map + , intercalate + , intersperse + , transpose + , reverse + , replace + + -- ** Case conversion + , toCaseFold + , toLower + , toUpper + , toTitle + + -- ** Justification + , justifyLeft + , justifyRight + , center + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + + -- ** Scans + , scanl + , scanl1 + , scanr + , scanr1 + + -- ** Accumulating maps + , mapAccumL + , mapAccumR + + -- ** Generation and unfolding + , replicate + , unfoldr + , unfoldrN + + -- * Substrings + + -- ** Breaking strings + , take + , takeEnd + , drop + , dropEnd + , takeWhile + , takeWhileEnd + , dropWhile + , dropWhileEnd + , dropAround + , strip + , stripStart + , stripEnd + , splitAt + , breakOn + , breakOnEnd + , break + , span + , group + , group' + , groupBy + , inits + , tails + + -- ** Breaking into many substrings + , splitOn, splitOn' + , split + , chunksOf, chunksOf' + + -- ** Breaking into lines and words + , lines, lines' + , words, words' + , unlines + , unwords + + -- * Predicates + , isPrefixOf + , isSuffixOf + , isInfixOf + + -- ** View patterns + , stripPrefix + , stripSuffix + , commonPrefixes + + -- * Searching + , filter + , breakOnAll, breakOnAll' + , find + , partition + + -- * Indexing + , index + , findIndex + , count + + -- * Zipping + , zip + , zipWith + ) where + +import Prelude + ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++) + , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>) + , not, seq, return, otherwise, quot) +import qualified Prelude as P + +import Control.DeepSeq (NFData(..)) +import Data.Binary (Binary(..)) +import Data.Char (isSpace) +import qualified Data.List as L +import Data.Data + +import GHC.Exts + ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..) + , Int(..), Addr#, tagToEnum#) +import qualified GHC.Exts as Exts +import qualified GHC.CString as GHC +import qualified GHC.Base as GHC + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#endif + +import Unsafe.Coerce + +import GHC.Wasm.Prim (JSVal) +import qualified GHC.Wasm.Prim as Prim + +import Data.JSString.Internal.Type +import Data.JSString.Internal.Fusion (stream, unstream) +import qualified Data.JSString.Internal.Fusion as S +import qualified Data.JSString.Internal.Fusion.Common as S + +import Text.Printf (PrintfArg(..), formatString) + +getJSVal :: JSString -> JSVal +getJSVal (JSString x) = x +{-# INLINE getJSVal #-} + +instance Exts.IsString JSString where + fromString = pack + +instance Exts.IsList JSString where + type Item JSString = Char + fromList = pack + toList = unpack + +#if MIN_VERSION_base(4,9,0) +instance Semigroup JSString where + (<>) = append +#endif + +instance P.Monoid JSString where + mempty = empty +#if MIN_VERSION_base(4,9,0) + mappend = (<>) -- future-proof definition +#else + mappend = append +#endif + mconcat = concat + +instance Eq JSString where + x == y = js_eq x y + +{- +instance Binary JSString where + put jss = put (encodeUtf8 jss) + get = do + bs <- get + case decodeUtf8' bs of + P.Left exn -> P.fail (P.show exn) + P.Right a -> P.pure a +-} + +#if MIN_VERSION_base(4,7,0) +instance PrintfArg JSString where + formatArg txt = formatString $ unpack txt +#endif + +instance Ord JSString where + compare x y = compareStrings x y + +equals :: JSString -> JSString -> Bool +equals x y = js_eq x y +{-# INLINE equals #-} + +compareStrings :: JSString -> JSString -> Ordering +compareStrings x y = tagToEnum# (js_compare x y +# 1#) +{-# INLINE compareStrings #-} + +-- | This instance preserves data abstraction at the cost of inefficiency. +-- See Data.Text for more information +instance Data JSString where + gfoldl f z txt = z pack `f` (unpack txt) + toConstr _ = packConstr + gunfold k z c = case constrIndex c of + 1 -> k (z pack) + _ -> P.error "gunfold" + dataTypeOf _ = jsstringDataType + +packConstr :: Constr +packConstr = mkConstr jsstringDataType "pack" [] Prefix + +jsstringDataType :: DataType +jsstringDataType = mkDataType "Data.JSString.JSString" [packConstr] + +instance Show JSString where + showsPrec p ps r = showsPrec p (unpack ps) r + +instance Read JSString where + readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] + +-- ----------------------------------------------------------------------------- +-- * Conversion to/from 'JSString' + +-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to +-- fusion. +pack :: String -> JSString +pack x = rnf x `seq` js_pack (unsafeCoerce x) +{-# INLINE [1] pack #-} + +{-# RULES +"JSSTRING pack -> fused" [~1] forall x. + pack x = unstream (S.map safe (S.streamList x)) +"JSSTRING pack -> unfused" [1] forall x. + unstream (S.map safe (S.streamList x)) = pack x + #-} + +-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion. +unpack :: JSString -> String +unpack = S.unstreamList . stream +{-# INLINE [1] unpack #-} + +unpack' :: JSString -> String +unpack' x = unsafeCoerce (js_unpack x) +{-# INLINE unpack' #-} + +-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion. +unpackCString# :: Addr# -> JSString +unpackCString# addr# = unstream (S.streamCString# addr#) +{-# NOINLINE unpackCString# #-} + +{-# RULES "JSSTRING literal" forall a. + unstream (S.map safe (S.streamList (GHC.unpackCString# a))) + = unpackCString# a #-} + +{-# RULES "JSSTRING literal UTF8" forall a. + unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a))) + = unpackCString# a #-} + +{-# RULES "JSSTRING empty literal" + unstream (S.map safe (S.streamList [])) + = empty_ #-} + +{-# RULES "JSSTRING singleton literal" forall a. + unstream (S.map safe (S.streamList [a])) + = singleton a #-} + +#ifdef MIN_VERSION_ghcjs_prim +#if MIN_VERSION_ghcjs_prim(0,1,1) +{-# RULES "JSSTRING literal prim" [0] forall a. + unpackCString# a = JSString (Prim.unsafeUnpackJSStringUtf8# a) + #-} +#endif +#endif + +-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion. +-- Performs replacement on invalid scalar values. +singleton :: Char -> JSString +singleton c = js_singleton c -- unstream . S.singleton . safe +{-# INLINE [1] singleton #-} + +{-# RULES +"JSSTRING singleton -> fused" [~1] forall a. + singleton a = unstream (S.singleton (safe a)) +"JSSTRING singleton -> unfused" [1] forall a. + unstream (S.singleton (safe a)) = singleton a + #-} + +-- This is intended to reduce inlining bloat. +-- singleton_ :: Char -> Text +-- singleton_ c = js_singleton c + +-- Text (A.run x) 0 len +-- where x :: ST s (A.MArray s) +-- x = do arr <- A.new len +-- _ <- unsafeWrite arr 0 d +-- return arr +-- len | d < '\x10000' = 1 +-- x | otherwise = 2 +-- d = safe c +-- {-# NOINLINE singleton_ #-} + +-- ----------------------------------------------------------------------------- +-- * Basic functions + +-- | /O(n)/ Adds a character to the front of a 'JSString'. This function +-- is more costly than its 'List' counterpart because it requires +-- copying a new array. Subject to fusion. Performs replacement on +-- invalid scalar values. +cons :: Char -> JSString -> JSString +cons c x = js_cons c x +{-# INLINE [1] cons #-} + +{-# RULES +"JSSTRING cons -> fused" [~1] forall c x. + cons c x = unstream (S.cons (safe c) (stream x)) +"JSSTRING cons -> unfused" [1] forall c x. + unstream (S.cons (safe c) (stream x)) = cons c x + #-} + +infixr 5 `cons` + +-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the +-- entire array in the process, unless fused. Subject to fusion. +-- Performs replacement on invalid scalar values. +snoc :: JSString -> Char -> JSString +snoc x c = js_snoc x c + -- unstream (S.snoc (stream t) (safe c)) +{-# INLINE [1] snoc #-} + +{-# RULES +"JSSTRING snoc -> fused" [~1] forall x c. + snoc x c = unstream (S.snoc (stream x) (safe c)) +"JSSTRING snoc -> unfused" [1] forall x c. + unstream (S.snoc (stream x) (safe c)) = snoc x c + #-} + +-- | /O(n)/ Appends one 'JSString' to the other by copying both of them +-- into a new 'JSString'. Subject to fusion. +append :: JSString -> JSString -> JSString +append x y = js_append x y +{-# INLINE [1] append #-} + +{-# RULES +"JSSTRING append -> fused" [~1] forall x1 x2. + append x1 x2 = unstream (S.append (stream x1) (stream x2)) +"JSSTRING append -> unfused" [1] forall x1 x2. + unstream (S.append (stream x1) (stream x2)) = append x1 x2 + #-} + +-- | /O(1)/ Returns the first character of a 'JSString', which must be +-- non-empty. Subject to fusion. +head :: JSString -> Char +head x = case js_head x of + -1# -> emptyError "head" + ch -> C# (chr# ch) +{-# INLINE [1] head #-} + +{-# RULES +"JSSTRING head -> fused" [~1] forall x. + head x = S.head (stream x) +"JSSTRING head -> unfused" [1] forall x. + S.head (stream x) = head x + #-} + + +-- | /O(1)/ Returns the first character and rest of a 'JSString', or +-- 'Nothing' if empty. Subject to fusion. +uncons :: JSString -> Maybe (Char, JSString) +uncons x = case js_uncons x of + (# -1#, _ #) -> Nothing + (# cp, t #) -> Just (C# (chr# cp), t) +{-# INLINE [1] uncons #-} + +unsnoc :: JSString -> Maybe (JSString, Char) +unsnoc x = case js_unsnoc x of + (# -1#, _ #) -> Nothing + (# cp, t #) -> Just (t, C# (chr# cp)) +{-# INLINE [1] unsnoc #-} + +-- | Lifted from Control.Arrow and specialized. +second :: (b -> c) -> (a,b) -> (a,c) +second f (a, b) = (a, f b) + +-- | /O(1)/ Returns the last character of a 'JSString', which must be +-- non-empty. Subject to fusion. +last :: JSString -> Char +last x = case js_last x of + -1# -> emptyError "last" + c -> (C# (chr# c)) +{-# INLINE [1] last #-} + +{-# RULES +"JSSTRING last -> fused" [~1] forall x. + last x = S.last (stream x) +"JSSTRING last -> unfused" [1] forall x. + S.last (stream x) = last x + #-} + +-- | /O(1)/ Returns all characters after the head of a 'JSString', which +-- must be non-empty. Subject to fusion. +tail :: JSString -> JSString +tail x = + let r = js_tail x + in if js_isNull r + then emptyError "tail" + else JSString r +{-# INLINE [1] tail #-} + +{-# RULES +"JSSTRING tail -> fused" [~1] forall x. + tail x = unstream (S.tail (stream x)) +"JSSTRING tail -> unfused" [1] forall x. + unstream (S.tail (stream x)) = tail x + #-} + +-- | /O(1)/ Returns all but the last character of a 'JSString', which must +-- be non-empty. Subject to fusion. +init :: JSString -> JSString +init x = + let r = js_init x + in if js_isNull r + then emptyError "init" + else JSString r +{-# INLINE [1] init #-} + +{-# RULES +"JSSTRING init -> fused" [~1] forall t. + init t = unstream (S.init (stream t)) +"JSSTRING init -> unfused" [1] forall t. + unstream (S.init (stream t)) = init t + #-} + +-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to +-- fusion. +null :: JSString -> Bool +null x = js_null x +{-# INLINE [1] null #-} + +{-# RULES +"JSSTRING null -> fused" [~1] forall t. + null t = S.null (stream t) +"JSSTRING null -> unfused" [1] forall t. + S.null (stream t) = null t + #-} + +-- | /O(1)/ Tests whether a 'JSString' contains exactly one character. +-- Subject to fusion. +isSingleton :: JSString -> Bool +isSingleton x = js_isSingleton x +{-# INLINE [1] isSingleton #-} + +{-# RULES +"JSSTRING isSingleton -> fused" [~1] forall x. + isSingleton x = S.isSingleton (stream x) +"JSSTRING isSingleton -> unfused" [1] forall x. + S.isSingleton (stream x) = isSingleton x + #-} + +-- | /O(n)/ Returns the number of characters in a 'JSString'. +-- Subject to fusion. +length :: JSString -> Int +length x = S.length (stream x) +{-# INLINE [0] length #-} +-- length needs to be phased after the compareN/length rules otherwise +-- it may inline before the rules have an opportunity to fire. + +-- | /O(n)/ Compare the count of characters in a 'JSString' to a number. +-- Subject to fusion. +-- +-- This function gives the same answer as comparing against the result +-- of 'length', but can short circuit if the count of characters is +-- greater than the number, and hence be more efficient. +compareLength :: JSString -> Int -> Ordering +compareLength t n = S.compareLengthI (stream t) n +{-# INLINE [1] compareLength #-} + +{-# RULES +"JSSTRING compareN/length -> compareLength" [~1] forall t n. + compare (length t) n = compareLength t n + #-} + +{-# RULES +"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n. + GHC.eqInt (length t) n = compareLength t n == EQ + #-} + +{-# RULES +"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n. + GHC.neInt (length t) n = compareLength t n /= EQ + #-} + +{-# RULES +"JSSTRING compareLength/==LT" [~1] forall t n. + GHC.ltInt (length t) n = compareLength t n == LT + #-} + +{-# RULES +"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n. + GHC.leInt (length t) n = compareLength t n /= GT + #-} + +{-# RULES +"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n. + GHC.gtInt (length t) n = compareLength t n == GT + #-} + +{-# RULES +"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n. + GHC.geInt (length t) n = compareLength t n /= LT + #-} + +-- ----------------------------------------------------------------------------- +-- * Transformations +-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to +-- each element of @t@. +-- +-- Example: +-- +-- >>> let message = pack "I am not angry. Not at all." +-- >>> T.map (\c -> if c == '.' then '!' else c) message +-- "I am not angry! Not at all!" +-- +-- Subject to fusion. Performs replacement on invalid scalar values. +map :: (Char -> Char) -> JSString -> JSString +map f t = unstream (S.map (safe . f) (stream t)) +{-# INLINE [1] map #-} + +-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of +-- 'JSString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: JSString -> [JSString] -> JSString +intercalate i xs = rnf xs `seq` js_intercalate i (unsafeCoerce xs) +{-# INLINE [1] intercalate #-} + +-- | /O(n)/ The 'intersperse' function takes a character and places it +-- between the characters of a 'JSString'. +-- +-- Example: +-- +-- >>> T.intersperse '.' "SHIELD" +-- "S.H.I.E.L.D" +-- +-- Subject to fusion. Performs replacement on invalid scalar values. +intersperse :: Char -> JSString -> JSString +intersperse c x = js_intersperse c x +{-# INLINE [1] intersperse #-} + +{-# RULES +"JSSTRING intersperse -> fused" [~1] forall c x. + intersperse c x = unstream (S.intersperse (safe c) (stream x)) +"JSSTRING intersperse -> unfused" [1] forall c x. + unstream (S.intersperse (safe c) (stream x)) = intersperse c x + #-} + +-- | /O(n)/ Reverse the characters of a string. +-- +-- Example: +-- +-- >>> T.reverse "desrever" +-- "reversed" +-- +-- Subject to fusion. +reverse :: JSString -> JSString +reverse x = js_reverse x -- S.reverse (stream x) +{-# INLINE [1] reverse #-} + +{-# RULES +"JSSTRING reverse -> fused" [~1] forall x. + reverse x = S.reverse (stream x) +"JSSTRING reverse -> unfused" [1] forall x. + S.reverse (stream x) = reverse x + #-} + +-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in +-- @haystack@ with @replacement@. +-- +-- This function behaves as though it was defined as follows: +-- +-- @ +-- replace needle replacement haystack = +-- 'intercalate' replacement ('splitOn' needle haystack) +-- @ +-- +-- As this suggests, each occurrence is replaced exactly once. So if +-- @needle@ occurs in @replacement@, that occurrence will /not/ itself +-- be replaced recursively: +-- +-- >>> replace "oo" "foo" "oo" +-- "foo" +-- +-- In cases where several instances of @needle@ overlap, only the +-- first one will be replaced: +-- +-- >>> replace "ofo" "bar" "ofofo" +-- "barfo" +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +replace :: JSString + -- ^ @needle@ to search for. If this string is empty, an + -- error will occur. + -> JSString + -- ^ @replacement@ to replace @needle@ with. + -> JSString + -- ^ @haystack@ in which to search. + -> JSString +replace needle replacement haystack + | js_null needle = emptyError "replace" + | otherwise = js_replace needle replacement haystack +{-# INLINE replace #-} + +-- ---------------------------------------------------------------------------- +-- ** Case conversions (folds) + +-- $case +-- +-- When case converting 'JSString' values, do not use combinators like +-- @map toUpper@ to case convert each character of a string +-- individually, as this gives incorrect results according to the +-- rules of some writing systems. The whole-string case conversion +-- functions from this module, such as @toUpper@, obey the correct +-- case conversion rules. As a result, these functions may map one +-- input character to two or three output characters. For examples, +-- see the documentation of each function. +-- +-- /Note/: In some languages, case conversion is a locale- and +-- context-dependent operation. The case conversion functions in this +-- module are /not/ locale sensitive. Programs that require locale +-- sensitivity should use appropriate versions of the +-- . + +-- | /O(n)/ Convert a string to folded case. Subject to fusion. +-- +-- This function is mainly useful for performing caseless (also known +-- as case insensitive) string comparisons. +-- +-- A string @x@ is a caseless match for a string @y@ if and only if: +-- +-- @toCaseFold x == toCaseFold y@ +-- +-- The result string may be longer than the input string, and may +-- differ from applying 'toLower' to the input string. For instance, +-- the Armenian small ligature \"ﬓ\" (men now, U+FB13) is case +-- folded to the sequence \"մ\" (men, U+0574) followed by +-- \"ն\" (now, U+0576), while the Greek \"µ\" (micro sign, +-- U+00B5) is case folded to \"μ\" (small letter mu, U+03BC) +-- instead of itself. +toCaseFold :: JSString -> JSString +toCaseFold t = unstream (S.toCaseFold (stream t)) +{-# INLINE toCaseFold #-} + +-- | /O(n)/ Convert a string to lower case, using simple case +-- conversion. Subject to fusion. +-- +-- The result string may be longer than the input string. For +-- instance, \"İ\" (Latin capital letter I with dot above, +-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) +-- followed by \" ̇\" (combining dot above, U+0307). +toLower :: JSString -> JSString +toLower x = js_toLower x +{-# INLINE [1] toLower #-} + +{-# RULES +"JSSTRING toLower -> fused" [~1] forall x. + toLower x = unstream (S.toLower (stream x)) +"JSSTRING toLower -> unfused" [1] forall x. + unstream (S.toLower (stream x)) = toLower x + #-} + +-- | /O(n)/ Convert a string to upper case, using simple case +-- conversion. Subject to fusion. +-- +-- The result string may be longer than the input string. For +-- instance, the German \"ß\" (eszett, U+00DF) maps to the +-- two-letter sequence \"SS\". +toUpper :: JSString -> JSString +toUpper x = js_toUpper x +{-# INLINE [1] toUpper #-} + +{-# RULES +"JSSTRING toUpper -> fused" [~1] forall x. + toUpper x = unstream (S.toUpper(stream x)) +"JSSTRING toUpper -> unfused" [1] forall x. + unstream (S.toUpper (stream x)) = toUpper x + #-} + +-- | /O(n)/ Convert a string to title case, using simple case +-- conversion. Subject to fusion. +-- +-- The first letter of the input is converted to title case, as is +-- every subsequent letter that immediately follows a non-letter. +-- Every letter that immediately follows another letter is converted +-- to lower case. +-- +-- The result string may be longer than the input string. For example, +-- the Latin small ligature fl (U+FB02) is converted to the +-- sequence Latin capital letter F (U+0046) followed by Latin small +-- letter l (U+006C). +-- +-- /Note/: this function does not take language or culture specific +-- rules into account. For instance, in English, different style +-- guides disagree on whether the book name \"The Hill of the Red +-- Fox\" is correctly title cased—but this function will +-- capitalize /every/ word. +toTitle :: JSString -> JSString +toTitle t = unstream (S.toTitle (stream t)) +{-# INLINE toTitle #-} + +-- | /O(n)/ Left-justify a string to the given length, using the +-- specified fill character on the right. Subject to fusion. +-- Performs replacement on invalid scalar values. +-- +-- Examples: +-- +-- >>> justifyLeft 7 'x' "foo" +-- "fooxxxx" +-- +-- >>> justifyLeft 3 'x' "foobar" +-- "foobar" +justifyLeft :: Int -> Char -> JSString -> JSString +justifyLeft k c t + | len >= k = t + | otherwise = t `append` replicateChar (k-len) c + where len = length t +{-# INLINE [1] justifyLeft #-} + +{-# RULES +"JSSTRING justifyLeft -> fused" [~1] forall k c t. + justifyLeft k c t = unstream (S.justifyLeftI k c (stream t)) +"JSSTRING justifyLeft -> unfused" [1] forall k c t. + unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t + #-} + +-- | /O(n)/ Right-justify a string to the given length, using the +-- specified fill character on the left. Performs replacement on +-- invalid scalar values. +-- +-- Examples: +-- +-- >>> justifyRight 7 'x' "bar" +-- "xxxxbar" +-- +-- >>> justifyRight 3 'x' "foobar" +-- "foobar" +justifyRight :: Int -> Char -> JSString -> JSString +justifyRight k c t + | len >= k = t + | otherwise = replicateChar (k-len) c `append` t + where len = length t +{-# INLINE justifyRight #-} + +-- | /O(n)/ Center a string to the given length, using the specified +-- fill character on either side. Performs replacement on invalid +-- scalar values. +-- +-- Examples: +-- +-- >>> center 8 'x' "HS" +-- "xxxHSxxx" +center :: Int -> Char -> JSString -> JSString +center k c t + | len >= k = t + | otherwise = replicateChar l c `append` t `append` replicateChar r c + where len = length t + d = k - len + r = d `quot` 2 + l = d - r +{-# INLINE center #-} + +-- | /O(n)/ The 'transpose' function transposes the rows and columns +-- of its 'JSString' argument. Note that this function uses 'pack', +-- 'unpack', and the list version of transpose, and is thus not very +-- efficient. +-- +-- Examples: +-- +-- >>> transpose ["green","orange"] +-- ["go","rr","ea","en","ng","e"] +-- +-- >>> transpose ["blue","red"] +-- ["br","le","ud","e"] +transpose :: [JSString] -> [JSString] +transpose ts = P.map pack (L.transpose (P.map unpack ts)) + +-- ----------------------------------------------------------------------------- +-- * Reducing 'JSString's (folds) + +-- | /O(n)/ 'foldl', applied to a binary operator, a starting value +-- (typically the left-identity of the operator), and a 'JSString', +-- reduces the 'JSString' using the binary operator, from left to right. +-- Subject to fusion. +foldl :: (a -> Char -> a) -> a -> JSString -> a +foldl f z t = S.foldl f z (stream t) +{-# INLINE foldl #-} + +-- | /O(n)/ A strict version of 'foldl'. Subject to fusion. +foldl' :: (a -> Char -> a) -> a -> JSString -> a +foldl' f z t = S.foldl' f z (stream t) +{-# INLINE foldl' #-} + +-- | /O(n)/ A variant of 'foldl' that has no starting value argument, +-- and thus must be applied to a non-empty 'JSString'. Subject to fusion. +foldl1 :: (Char -> Char -> Char) -> JSString -> Char +foldl1 f t = S.foldl1 f (stream t) +{-# INLINE foldl1 #-} + +-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion. +foldl1' :: (Char -> Char -> Char) -> JSString -> Char +foldl1' f t = S.foldl1' f (stream t) +{-# INLINE foldl1' #-} + +-- | /O(n)/ 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'JSString', +-- reduces the 'JSString' using the binary operator, from right to left. +-- Subject to fusion. +foldr :: (Char -> a -> a) -> a -> JSString -> a +foldr f z t = S.foldr f z (stream t) +{-# INLINE foldr #-} + +-- | /O(n)/ A variant of 'foldr' that has no starting value argument, +-- and thus must be applied to a non-empty 'JSString'. Subject to +-- fusion. +foldr1 :: (Char -> Char -> Char) -> JSString -> Char +foldr1 f t = S.foldr1 f (stream t) +{-# INLINE foldr1 #-} + +-- ----------------------------------------------------------------------------- +-- ** Special folds + +-- | /O(n)/ Concatenate a list of 'JSString's. +concat :: [JSString] -> JSString +concat xs = rnf xs `seq` js_concat (unsafeCoerce xs) +{- case ts' of + [] -> empty + [t] -> t + _ -> Text (A.run go) 0 len + where + ts' = L.filter (not . null) ts + len = sumP "concat" $ L.map lengthWord16 ts' + go :: ST s (A.MArray s) + go = do + arr <- A.new len + let step i (Text a o l) = + let !j = i + l in A.copyI arr i a o j >> return j + foldM step 0 ts' >> return arr +-} + +-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and +-- concatenate the results. +concatMap :: (Char -> JSString) -> JSString -> JSString +concatMap f = concat . foldr ((:) . f) [] +{-# INLINE concatMap #-} + +-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the +-- 'JSString' @t@ satisfies the predicate @p@. Subject to fusion. +any :: (Char -> Bool) -> JSString -> Bool +any p t = S.any p (stream t) +{-# INLINE any #-} + +-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the +-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion. +all :: (Char -> Bool) -> JSString -> Bool +all p t = S.all p (stream t) +{-# INLINE all #-} + +-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which +-- must be non-empty. Subject to fusion. +maximum :: JSString -> Char +maximum t = S.maximum (stream t) +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which +-- must be non-empty. Subject to fusion. +minimum :: JSString -> Char +minimum t = S.minimum (stream t) +{-# INLINE minimum #-} + +-- ----------------------------------------------------------------------------- +-- * Building 'JSString's + +-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of +-- successive reduced values from the left. Subject to fusion. +-- Performs replacement on invalid scalar values. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString +scanl f z t = unstream (S.scanl g z (stream t)) + where g a b = safe (f a b) +{-# INLINE scanl #-} + +-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting +-- value argument. Subject to fusion. Performs replacement on +-- invalid scalar values. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Char -> Char -> Char) -> JSString -> JSString +scanl1 f x = case uncons x of + Just (h, t) -> scanl f h t + Nothing -> empty +{-# INLINE scanl1 #-} + +-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs +-- replacement on invalid scalar values. +-- +-- > scanr f v == reverse . scanl (flip f) v . reverse +scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString +scanr f z = S.reverse . S.reverseScanr g z . S.reverseStream + where g a b = safe (f a b) +{-# INLINE scanr #-} + +-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting +-- value argument. Subject to fusion. Performs replacement on +-- invalid scalar values. +scanr1 :: (Char -> Char -> Char) -> JSString -> JSString +scanr1 f t | null t = empty + | otherwise = scanr f (last t) (init t) +{-# INLINE scanr1 #-} + +-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a +-- function to each element of a 'JSString', passing an accumulating +-- parameter from left to right, and returns a final 'JSString'. Performs +-- replacement on invalid scalar values. +mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString) +mapAccumL f z0 = S.mapAccumL g z0 . stream + where g a b = second safe (f a b) +{-# INLINE mapAccumL #-} + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- a strict 'foldr'; it applies a function to each element of a +-- 'JSString', passing an accumulating parameter from right to left, and +-- returning a final value of this accumulator together with the new +-- 'JSString'. +-- Performs replacement on invalid scalar values. +mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString) +mapAccumR f z0 = second reverse . S.mapAccumL g z0 . S.reverseStream + where g a b = second safe (f a b) +{-# INLINE mapAccumR #-} + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding 'JSString's + +-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input +-- @t@ repeated @n@ times. +replicate :: Int -> JSString -> JSString +replicate (I# n) t = js_replicate n t +{- t@(Text a o l) + | n <= 0 || l <= 0 = empty + | n == 1 = t + | isSingleton t = replicateChar n (unsafeHead t) + | otherwise = Text (A.run x) 0 len + where + len = l `mul` n + x :: ST s (A.MArray s) + x = do + arr <- A.new len + let loop !d !i | i >= n = return arr + | otherwise = let m = d + l + in A.copyI arr d a o m >> loop m (i+1) + loop 0 0 -} +{-# INLINE [1] replicate #-} + +{-# RULES +"JSSTRING replicate/singleton -> replicateChar" [~1] forall n c. + replicate n (singleton c) = replicateChar n c + #-} + +-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'JSString' of length @n@ with @c@ the +-- value of every element. Subject to fusion. +replicateChar :: Int -> Char -> JSString +replicateChar n c = js_replicateChar n c +{-# INLINE [1] replicateChar #-} + +{-# RULES +"JSSTRING replicateChar -> fused" [~1] forall n c. + replicateChar n c = unstream (S.replicateCharI n (safe c)) +"JSSTRING replicateChar -> unfused" [1] forall n c. + unstream (S.replicateCharI n (safe c)) = replicateChar n c + #-} + +-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr' +-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a +-- 'JSString' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'JSString', otherwise +-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the +-- string, and @b@ is the seed value for further production. Subject +-- to fusion. Performs replacement on invalid scalar values. +unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString +unfoldr f s = unstream (S.unfoldr (firstf safe . f) s) +{-# INLINE unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed +-- value. However, the length of the result should be limited by the +-- first argument to 'unfoldrN'. This function is more efficient than +-- 'unfoldr' when the maximum length of the result is known and +-- correct, otherwise its performance is similar to 'unfoldr'. Subject +-- to fusion. Performs replacement on invalid scalar values. +unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString +unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s) +{-# INLINE unfoldrN #-} + +-- ----------------------------------------------------------------------------- +-- * Substrings + +-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the +-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than +-- the length of the JSString. Subject to fusion. +take :: Int -> JSString -> JSString +take (I# n) t = js_take n t +{- t@(Text arr off len) + | n <= 0 = empty + | n >= len = t + | otherwise = text arr off (iterN n t) -} +{-# INLINE [1] take #-} +{- +iterN :: Int -> JSString -> Int +iterN n t@(Text _arr _off len) = loop 0 0 + where loop !i !cnt + | i >= len || cnt >= n = i + | otherwise = loop (i+d) (cnt+1) + where d = iter_ t i +-} +{-# RULES +"JSSTRING take -> fused" [~1] forall n t. + take n t = unstream (S.take n (stream t)) +"JSSTRING take -> unfused" [1] forall n t. + unstream (S.take n (stream t)) = take n t + #-} + +-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after +-- taking @n@ characters from the end of @t@. +-- +-- Examples: +-- +-- >>> takeEnd 3 "foobar" +-- "bar" +-- +takeEnd :: Int -> JSString -> JSString +takeEnd (I# n) x = js_takeEnd n x +{- +iterNEnd :: Int -> JSString -> Int +iterNEnd n t@(Text _arr _off len) = loop (len-1) n + where loop i !m + | i <= 0 = 0 + | m <= 1 = i + | otherwise = loop (i+d) (m-1) + where d = reverseIter_ t i +-} +-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the +-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@ +-- is greater than the length of the 'JSString'. Subject to fusion. +drop :: Int -> JSString -> JSString +drop (I# n) x = js_drop n x +{-# INLINE [1] drop #-} + +{-# RULES +"JSSTRING drop -> fused" [~1] forall n t. + drop n t = unstream (S.drop n (stream t)) +"JSSTRING drop -> unfused" [1] forall n t. + unstream (S.drop n (stream t)) = drop n t + #-} + +-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after +-- dropping @n@ characters from the end of @t@. +-- +-- Examples: +-- +-- >>> dropEnd 3 "foobar" +-- "foo" +-- +dropEnd :: Int -> JSString -> JSString +dropEnd n x = js_dropEnd n x + +-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString', +-- returns the longest prefix (possibly empty) of elements that +-- satisfy @p@. Subject to fusion. +takeWhile :: (Char -> Bool) -> JSString -> JSString +takeWhile p x = loop 0# (js_length x) + where loop i l | isTrue# (i >=# l) = x + | otherwise = + case js_index i x of + c | p (C# (chr# c)) -> loop (i +# charWidth c) l + _ -> js_substr 0# i x +{-# INLINE [1] takeWhile #-} + +{-# RULES +"TEXT takeWhile -> fused" [~1] forall p t. + takeWhile p t = unstream (S.takeWhile p (stream t)) +"TEXT takeWhile -> unfused" [1] forall p t. + unstream (S.takeWhile p (stream t)) = takeWhile p t + #-} + +-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text', +-- returns the longest suffix (possibly empty) of elements that +-- satisfy @p@. +-- Examples: +-- +-- >>> takeWhileEnd (=='o') "foo" +-- "oo" +-- +takeWhileEnd :: (Char -> Bool) -> JSString -> JSString +takeWhileEnd p x = loop (js_length x -# 1#) + where loop -1# = empty + loop i = case js_uncheckedIndexR i x of + c | p (C# (chr# c)) -> loop (i -# charWidth c) + _ -> js_substr1 (i +# 1#) x +{-# INLINE takeWhileEnd #-} + +-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after +-- 'takeWhile' @p@ @t@. Subject to fusion. +dropWhile :: (Char -> Bool) -> JSString -> JSString +dropWhile p x = loop 0# (js_length x) + where loop i l | isTrue# (i >=# l) = empty + | otherwise = + case js_uncheckedIndex i x of + c | p (C# (chr# c)) -> loop (i +# charWidth c) l + _ -> js_substr1 i x +{-# INLINE [1] dropWhile #-} + +{-# RULES +"TEXT dropWhile -> fused" [~1] forall p t. + dropWhile p t = unstream (S.dropWhile p (stream t)) +"TEXT dropWhile -> unfused" [1] forall p t. + unstream (S.dropWhile p (stream t)) = dropWhile p t + #-} + +-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after +-- dropping characters that satisfy the predicate @p@ from the end of +-- @t@. Subject to fusion. +-- Examples: +-- +-- >>> dropWhileEnd (=='.') "foo..." +-- "foo" +dropWhileEnd :: (Char -> Bool) -> JSString -> JSString +dropWhileEnd p x = loop (js_length x -# 1#) + where loop -1# = empty + loop i = case js_uncheckedIndexR i x of + c | p (C# (chr# c)) -> loop (i -# charWidth c) + _ -> js_substr 0# (i +# 1#) x +{-# INLINE [1] dropWhileEnd #-} + +{-# RULES +"TEXT dropWhileEnd -> fused" [~1] forall p t. + dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t)) +"TEXT dropWhileEnd -> unfused" [1] forall p t. + S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t + #-} + +-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after +-- dropping characters that satisfy the predicate @p@ from both the +-- beginning and end of @t@. Subject to fusion. +dropAround :: (Char -> Bool) -> JSString -> JSString +dropAround p = dropWhile p . dropWhileEnd p +{-# INLINE [1] dropAround #-} + +-- | /O(n)/ Remove leading white space from a string. Equivalent to: +-- +-- > dropWhile isSpace +stripStart :: JSString -> JSString +stripStart = dropWhile isSpace +{-# INLINE [1] stripStart #-} + +-- | /O(n)/ Remove trailing white space from a string. Equivalent to: +-- +-- > dropWhileEnd isSpace +stripEnd :: JSString -> JSString +stripEnd = dropWhileEnd isSpace +{-# INLINE [1] stripEnd #-} + +-- | /O(n)/ Remove leading and trailing white space from a string. +-- Equivalent to: +-- +-- > dropAround isSpace +strip :: JSString -> JSString +strip = dropAround isSpace +{-# INLINE [1] strip #-} + +-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a +-- prefix of @t@ of length @n@, and whose second is the remainder of +-- the string. It is equivalent to @('take' n t, 'drop' n t)@. +splitAt :: Int -> JSString -> (JSString, JSString) +splitAt (I# n) x = case js_splitAt n x of (# y, z #) -> (y, z) +{-# INLINE splitAt #-} + +-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns +-- a pair whose first element is the longest prefix (possibly empty) +-- of @t@ of elements that satisfy @p@, and whose second is the +-- remainder of the list. +span :: (Char -> Bool) -> JSString -> (JSString, JSString) +span p x = case js_length x of + 0# -> (empty, empty) + l -> let c0 = js_uncheckedIndex 0# x + in if p (C# (chr# c0)) then loop 0# l else (empty, x) + where + loop i l + | isTrue# (i >=# l) = (x, empty) + | otherwise = + let c = js_uncheckedIndex i x + in if p (C# (chr# c)) + then loop (i +# charWidth c) l + else (js_substr 0# i x, js_substr1 i x) +{-# INLINE span #-} + +-- | /O(n)/ 'break' is like 'span', but the prefix returned is +-- over elements that fail the predicate @p@. +break :: (Char -> Bool) -> JSString -> (JSString, JSString) +break p = span (not . p) +{-# INLINE break #-} + +-- | /O(n)/ Group characters in a string according to a predicate. +groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString] +groupBy p x = + case js_length x of + 0# -> [] + l -> let c0 = js_uncheckedIndex 0# x + in loop (C# (chr# c0)) 0# (charWidth c0) l + where + loop b s i l + | isTrue# (i >=# l) = + if isTrue# (i ># s) then [js_substr1 s x] else [] + | otherwise = + let c = js_uncheckedIndex i x + c' = C# (chr# c) + i' = i +# charWidth c + in if p b c' + then loop b s i' l + else js_substring s i x : loop c' i i' l + +{- +-- | Returns the /array/ index (in units of 'Word16') at which a +-- character may be found. This is /not/ the same as the logical +-- index returned by e.g. 'findIndex'. +findAIndexOrEnd :: (Char -> Bool) -> JSString -> Int +findAIndexOrEnd q t@(Text _arr _off len) = go 0 + where go !i | i >= len || q c = i + | otherwise = go (i+d) + where Iter c d = iter t i +-} + +-- | /O(n)/ Group characters in a string by equality. +group :: JSString -> [JSString] +group x = group' x -- fixme, implement lazier version +{-# INLINE group #-} + +group' :: JSString -> [JSString] +group' x = unsafeCoerce (js_group x) +{-# INLINE group' #-} + +-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest +-- first. +inits :: JSString -> [JSString] +inits x = empty : case js_length x of + 0# -> [] + l -> loop (js_charWidthAt 0# x) l + where + loop i l + | isTrue# (i >=# l) = [x] + | otherwise = + js_substr 0# i x : loop (i +# js_charWidthAt i x) l + +-- | /O(n^2)/ Return all final segments of the given 'JSString', longest +-- first. +tails :: JSString -> [JSString] +tails x = + case js_length x of -- this could be less strict + 0# -> [empty] + l -> loop 0# l + where + loop i l + | isTrue# (i >=# l) = [empty] + | otherwise = + js_substr1 i x : loop (i +# js_charWidthAt i x) l + +-- $split +-- +-- Splitting functions in this library do not perform character-wise +-- copies to create substrings; they just construct new 'JSString's that +-- are slices of the original. + +-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString' +-- argument (which cannot be empty), consuming the delimiter. An empty +-- delimiter is invalid, and will cause an error to be raised. +-- +-- Examples: +-- +-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne" +-- ["a","b","d","e"] +-- +-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa" +-- ["","X","X","X",""] +-- +-- >>> splitOn "x" "x" +-- ["",""] +-- +-- and +-- +-- > intercalate s . splitOn s == id +-- > splitOn (singleton c) == split (==c) +-- +-- (Note: the string @s@ to split on above cannot be empty.) +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +splitOn :: JSString + -- ^ String to split on. If this string is empty, an error + -- will occur. + -> JSString + -- ^ Input text. + -> [JSString] +splitOn = splitOn' -- fixme +{- +splitOn pat src + | null pat = emptyError "splitOn" + | otherwise = go 0# + where + go i = case js_splitOn1 i pat src of + (# n, h #) -> case n of + -1# -> [] + n' -> h : go n' +-} +{-# INLINE [1] splitOn #-} + +-- RULES +-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t. +-- splitOn (singleton c) t = split (==c) t +-- + +splitOn' :: JSString + -- ^ String to split on. If this string is empty, an error + -- will occur. + -> JSString + -- ^ Input text. + -> [JSString] +splitOn' pat src + | null pat = emptyError "splitOn'" + | otherwise = unsafeCoerce (js_splitOn pat src) +{-# NOINLINE splitOn' #-} +--- {-# INLINE [1] splitOn' #-} + +-- | /O(n)/ Splits a 'JSString' into components delimited by separators, +-- where the predicate returns True for a separator element. The +-- resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- >>> split (=='a') "aabbaca" +-- ["","","bb","c",""] +-- +-- >>> split (=='a') "" +-- [""] +split :: (Char -> Bool) -> JSString -> [JSString] +split p x = case js_length x of + 0# -> [empty] + l -> loop 0# 0# l + where + loop s i l + | isTrue# (i >=# l) = [js_substr s i x] + | otherwise = + let ch = js_uncheckedIndex i x + i' = i +# charWidth ch + in if p (C# (chr# ch)) + then js_substr s (i -# s) x : loop i' i' l + else loop s i' l +{-# INLINE split #-} + +-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last +-- element may be shorter than the other chunks, depending on the +-- length of the input. Examples: +-- +-- >>> chunksOf 3 "foobarbaz" +-- ["foo","bar","baz"] +-- +-- >>> chunksOf 4 "haskell.org" +-- ["hask","ell.","org"] +chunksOf :: Int -> JSString -> [JSString] +chunksOf (I# k) p = go 0# + where + go i = case js_chunksOf1 k i p of + (# n, c #) -> case n of + -1# -> [] + _ -> c : go n +{-# INLINE chunksOf #-} + +-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last +-- element may be shorter than the other chunks, depending on the +-- length of the input. Examples: +-- +-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"] +-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"] +chunksOf' :: Int -> JSString -> [JSString] +chunksOf' (I# k) p = unsafeCoerce (js_chunksOf k p) +{-# INLINE chunksOf' #-} + +-- ---------------------------------------------------------------------------- +-- * Searching + +------------------------------------------------------------------------------- +-- ** Searching with a predicate + +-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and +-- returns the first element matching the predicate, or 'Nothing' if +-- there is no such element. +find :: (Char -> Bool) -> JSString -> Maybe Char +find p t = S.findBy p (stream t) +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString', +-- and returns the pair of 'JSString's with elements which do and do not +-- satisfy the predicate, respectively; i.e. +-- +-- > partition p t == (filter p t, filter (not . p) t) +partition :: (Char -> Bool) -> JSString -> (JSString, JSString) +partition p t = (filter p t, filter (not . p) t) +{-# INLINE partition #-} + +-- | /O(n)/ 'filter', applied to a predicate and a 'JSString', +-- returns a 'JSString' containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> JSString -> JSString +filter p t = unstream (S.filter p (stream t)) +{-# INLINE filter #-} + +-- | /O(n+m)/ Find the first instance of @needle@ (which must be +-- non-'null') in @haystack@. The first element of the returned tuple +-- is the prefix of @haystack@ before @needle@ is matched. The second +-- is the remainder of @haystack@, starting with the match. +-- +-- Examples: +-- +-- >>> breakOn "::" "a::b::c" +-- ("a","::b::c") +-- +-- >>> breakOn "/" "foobar" +-- ("foobar","") +-- +-- Laws: +-- +-- > append prefix match == haystack +-- > where (prefix, match) = breakOn needle haystack +-- +-- If you need to break a string by a substring repeatedly (e.g. you +-- want to break on every instance of a substring), use 'breakOnAll' +-- instead, as it has lower startup overhead. +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +breakOn :: JSString -> JSString -> (JSString, JSString) +breakOn pat src + | null pat = emptyError "breakOn" + | otherwise = case js_breakOn pat src of (# y, z #) -> (y, z) +{-# INLINE breakOn #-} + +-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the +-- string. +-- +-- The first element of the returned tuple is the prefix of @haystack@ +-- up to and including the last match of @needle@. The second is the +-- remainder of @haystack@, following the match. +-- +-- >>> breakOnEnd "::" "a::b::c" +-- ("a::b::","c") +breakOnEnd :: JSString -> JSString -> (JSString, JSString) +breakOnEnd pat src + | null pat = emptyError "breakOnEnd" + | otherwise = case js_breakOnEnd pat src of (# y, z #) -> (y, z) +{-# INLINE breakOnEnd #-} + +-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in +-- @haystack@. Each element of the returned list consists of a pair: +-- +-- * The entire string prior to the /k/th match (i.e. the prefix) +-- +-- * The /k/th match, followed by the remainder of the string +-- +-- Examples: +-- +-- >>> breakOnAll "::" "" +-- [] +-- +-- >>> breakOnAll "/" "a/b/c/" +-- [("a","/b/c/"),("a/b","/c/"),("a/b/c","/")] +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +-- +-- The @needle@ parameter may not be empty. +breakOnAll :: JSString -- ^ @needle@ to search for + -> JSString -- ^ @haystack@ in which to search + -> [(JSString, JSString)] +breakOnAll pat src + | null pat = emptyError "breakOnAll" + | otherwise = go 0# + where + go i = case js_breakOnAll1 i pat src of + (# n, x, y #) -> case n of + -1# -> [] + _ -> (x,y) : go n +{-# INLINE breakOnAll #-} + +breakOnAll' :: JSString -- ^ @needle@ to search for + -> JSString -- ^ @haystack@ in which to search + -> [(JSString, JSString)] +breakOnAll' pat src + | null pat = emptyError "breakOnAll'" + | otherwise = unsafeCoerce (js_breakOnAll pat src) +{-# INLINE breakOnAll' #-} + +------------------------------------------------------------------------------- +-- ** Indexing 'JSString's + +-- $index +-- +-- If you think of a 'JSString' value as an array of 'Char' values (which +-- it is not), you run the risk of writing inefficient code. +-- +-- An idiom that is common in some languages is to find the numeric +-- offset of a character or substring, then use that number to split +-- or trim the searched string. With a 'JSString' value, this approach +-- would require two /O(n)/ operations: one to perform the search, and +-- one to operate from wherever the search ended. +-- +-- For example, suppose you have a string that you want to split on +-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of +-- searching for the index of @\"::\"@ and taking the substrings +-- before and after that index, you would instead use @breakOnAll \"::\"@. + +-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0. +index :: JSString -> Int -> Char +index t n = S.index (stream t) n +{-# INLINE index #-} + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString' +-- and returns the index of the first element in the 'JSString' satisfying +-- the predicate. Subject to fusion. +findIndex :: (Char -> Bool) -> JSString -> Maybe Int +findIndex p t = S.findIndex p (stream t) +{-# INLINE findIndex #-} + +-- | /O(n+m)/ The 'count' function returns the number of times the +-- query string appears in the given 'JSString'. An empty query string is +-- invalid, and will cause an error to be raised. +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +count :: JSString -> JSString -> Int +count pat src + | null pat = emptyError "count" + | otherwise = I# (js_count pat src) +{-# INLINE [1] count #-} + +-- RULES +-- "JSSTRING count/singleton -> countChar" [~1] forall c t. +-- count (singleton c) t = countChar c t +-- + +-- | /O(n)/ The 'countChar' function returns the number of times the +-- query element appears in the given 'JSString'. Subject to fusion. +countChar :: Char -> JSString -> Int +countChar c t = S.countChar c (stream t) +{-# INLINE countChar #-} + +------------------------------------------------------------------------------- +-- * Zipping + +-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of +-- corresponding pairs of bytes. If one input 'JSString' is short, +-- excess elements of the longer 'JSString' are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: JSString -> JSString -> [(Char,Char)] +zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b) +{-# INLINE zip #-} + +-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function +-- given as the first argument, instead of a tupling function. +-- Performs replacement on invalid scalar values. +zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString +zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2)) + where g a b = safe (f a b) +{-# INLINE zipWith #-} + +-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's +-- representing white space. +words :: JSString -> [JSString] +words x = loop 0# -- js_words x {- t@(Text arr off len) = loop 0 0 + where + loop i = case js_words1 i x of + (# n, w #) -> case n of + -1# -> [] + _ -> w : loop n +{-# INLINE words #-} + +-- fixme: strict words' that allocates the whole list in one go +words' :: JSString -> [JSString] +words' x = unsafeCoerce (js_words x) +{-# INLINE words' #-} + +-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at +-- newline 'Char's. The resulting strings do not contain newlines. +lines :: JSString -> [JSString] +lines ps = loop 0# + where + loop i = case js_lines1 i ps of + (# n, l #) -> case n of + -1# -> [] + _ -> l : loop n +{-# INLINE lines #-} + +lines' :: JSString -> [JSString] +lines' ps = unsafeCoerce (js_lines ps) +{-# INLINE lines' #-} + +{- +-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line +-- boundaries. +-- +-- A line boundary is considered to be either a line feed, a carriage +-- return immediately followed by a line feed, or a carriage return. +-- This accounts for both Unix and Windows line ending conventions, +-- and for the old convention used on Mac OS 9 and earlier. +lines' :: Text -> [Text] +lines' ps | null ps = [] + | otherwise = h : case uncons t of + Nothing -> [] + Just (c,t') + | c == '\n' -> lines t' + | c == '\r' -> case uncons t' of + Just ('\n',t'') -> lines t'' + _ -> lines t' + where (h,t) = span notEOL ps + notEOL c = c /= '\n' && c /= '\r' + +-} + +-- | /O(n)/ Joins lines, after appending a terminating newline to +-- each. +unlines :: [JSString] -> JSString +unlines xs = rnf xs `seq` js_unlines (unsafeCoerce xs) +{-# INLINE unlines #-} + +-- | /O(n)/ Joins words using single space characters. +unwords :: [JSString] -> JSString +unwords xs = rnf xs `seq` js_unwords (unsafeCoerce xs) +{-# INLINE unwords #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns +-- 'True' iff the first is a prefix of the second. Subject to fusion. +isPrefixOf :: JSString -> JSString -> Bool +isPrefixOf x y = js_isPrefixOf x y +{-# INLINE [1] isPrefixOf #-} + +{-# RULES +"JSSTRING isPrefixOf -> fused" [~1] forall x y. + isPrefixOf x y = S.isPrefixOf (stream x) (stream y) +"JSSTRING isPrefixOf -> unfused" [1] forall x y. + S.isPrefixOf (stream x) (stream y) = isPrefixOf x y + #-} + +-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns +-- 'True' iff the first is a suffix of the second. +isSuffixOf :: JSString -> JSString -> Bool +isSuffixOf x y = js_isSuffixOf x y +{-# INLINE isSuffixOf #-} + +-- | The 'isInfixOf' function takes two 'JSString's and returns +-- 'True' iff the first is contained, wholly and intact, anywhere +-- within the second. +-- +-- Complexity depends on how the JavaScript engine implements +-- String.prototype.find. +isInfixOf :: JSString -> JSString -> Bool +isInfixOf needle haystack = js_isInfixOf needle haystack +{-# INLINE [1] isInfixOf #-} + +{-# RULES +"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h. + isInfixOf (singleton n) h = S.elem n (S.stream h) + #-} + +------------------------------------------------------------------------------- +-- * View patterns + +-- | /O(n)/ Return the suffix of the second string if its prefix +-- matches the entire first string. +-- +-- Examples: +-- +-- >>> stripPrefix "foo" "foobar" +-- Just "bar" +-- +-- >>> stripPrefix "" "baz" +-- Just "baz" +-- +-- >>> stripPrefix "foo" "quux" +-- Nothing +-- +-- This is particularly useful with the @ViewPatterns@ extension to +-- GHC, as follows: +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > import Data.Text as T +-- > +-- > fnordLength :: JSString -> Int +-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf +-- > fnordLength _ = -1 +stripPrefix :: JSString -> JSString -> Maybe JSString +stripPrefix x y = unsafeCoerce (js_stripPrefix x y) +{-# INLINE stripPrefix #-} + +-- | /O(n)/ Find the longest non-empty common prefix of two strings +-- and return it, along with the suffixes of each string at which they +-- no longer match. +-- +-- If the strings do not have a common prefix or either one is empty, +-- this function returns 'Nothing'. +-- +-- Examples: +-- +-- >>> commonPrefixes "foobar" "fooquux" +-- Just ("foo","bar","quux") +-- +-- >>> commonPrefixes "veeble" "fetzer" +-- Nothing +-- +-- >>> commonPrefixes "" "baz" +-- Nothing +commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString) +commonPrefixes x y = unsafeCoerce (js_commonPrefixes x y) +{-# INLINE commonPrefixes #-} + +-- | /O(n)/ Return the prefix of the second string if its suffix +-- matches the entire first string. +-- +-- Examples: +-- +-- >>> stripSuffix "bar" "foobar" +-- Just "foo" +-- +-- >>> stripSuffix "" "baz" +-- Just "baz" +-- +-- >>> stripSuffix "foo" "quux" +-- Nothing +-- +-- This is particularly useful with the @ViewPatterns@ extension to +-- GHC, as follows: +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > import Data.Text as T +-- > +-- > quuxLength :: Text -> Int +-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre +-- > quuxLength _ = -1 +stripSuffix :: JSString -> JSString -> Maybe JSString +stripSuffix x y = unsafeCoerce (js_stripSuffix x y) +{-# INLINE stripSuffix #-} + +-- | Add a list of non-negative numbers. Errors out on overflow. +sumP :: String -> [Int] -> Int +sumP fun = go 0 + where go !a (x:xs) + | ax >= 0 = go ax xs + | otherwise = overflowError fun + where ax = a + x + go a _ = a + +emptyError :: String -> a +emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input" + +overflowError :: String -> a +overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow" + +charWidth :: Int# -> Int# +charWidth cp | isTrue# (cp >=# 0x10000#) = 2# + | otherwise = 1# +{-# INLINE charWidth #-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe + "h$jsstringPack" js_pack :: Exts.Any -> JSString +foreign import javascript unsafe + "((x) => { return x === ''; })" js_null :: JSString -> Bool +foreign import javascript unsafe + "((x) => { return x === null; })" js_isNull :: JSVal -> Bool +foreign import javascript unsafe + "((x,y) => { return x === y; })" js_eq :: JSString -> JSString -> Bool +foreign import javascript unsafe +-- "h$jsstringAppend" js_append :: JSString -> JSString -> JSString -- debug + "((x,y) => { return x + y; })" js_append :: JSString -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringCompare" js_compare :: JSString -> JSString -> Int# +-- "($1<$2)?-1:(($1>$2)?1:0)" js_compare :: JSString -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringSingleton" js_singleton :: Char -> JSString +foreign import javascript unsafe + "h$jsstringUnpack" js_unpack :: JSString -> Exts.Any -- String +foreign import javascript unsafe + "h$jsstringCons" js_cons :: Char -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringSnoc" js_snoc :: JSString -> Char -> JSString +foreign import javascript unsafe + "h$jsstringUncons" js_uncons :: JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringUnsnoc" js_unsnoc :: JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "((x,y,z) => { return z.substr(x,y); })" js_substr :: Int# -> Int# -> JSString -> JSString +foreign import javascript unsafe + "((x,y) => { return y.substr(x); })" js_substr1 :: Int# -> JSString -> JSString +foreign import javascript unsafe + "((x,y,z) => { return z.substring(x,y); })" js_substring :: Int# -> Int# -> JSString -> JSString +foreign import javascript unsafe + "((x) => { return x.length; })" js_length :: JSString -> Int# +foreign import javascript unsafe + "((x,y) => { return ((y.charCodeAt(x)|1023)===0xDBFF)?2:1; })" js_charWidthAt + :: Int# -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringIndex" js_index :: Int# -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringIndexR" js_indexR :: Int# -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringUncheckedIndex" js_uncheckedIndex :: Int# -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringIndexR" js_uncheckedIndexR :: Int# -> JSString -> Int# + +-- js_head and js_last return -1 for empty string +foreign import javascript unsafe + "h$jsstringHead" js_head :: JSString -> Int# +foreign import javascript unsafe + "h$jsstringLast" js_last :: JSString -> Int# + +foreign import javascript unsafe + "h$jsstringInit" js_init :: JSString -> JSVal -- null for empty string +foreign import javascript unsafe + "h$jsstringTail" js_tail :: JSString -> JSVal -- null for empty string +foreign import javascript unsafe + "h$jsstringReverse" js_reverse :: JSString -> JSString +foreign import javascript unsafe + "h$jsstringGroup" js_group :: JSString -> Exts.Any {- [JSString] -} +--foreign import javascript unsafe +-- "h$jsstringGroup1" js_group1 +-- :: Int# -> Bool -> JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringConcat" js_concat :: Exts.Any {- [JSString] -} -> JSString +-- debug this below! +foreign import javascript unsafe + "h$jsstringReplace" js_replace :: JSString -> JSString -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringCount" js_count :: JSString -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringWords1" js_words1 :: Int# -> JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringWords" js_words :: JSString -> Exts.Any -- [JSString] +foreign import javascript unsafe + "h$jsstringLines1" js_lines1 :: Int# -> JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringLines" js_lines :: JSString -> Exts.Any -- [JSString] +foreign import javascript unsafe + "h$jsstringUnlines" js_unlines :: Exts.Any {- [JSString] -} -> JSString +foreign import javascript unsafe + "h$jsstringUnwords" js_unwords :: Exts.Any {- [JSString] -} -> JSString +foreign import javascript unsafe + "h$jsstringIsPrefixOf" js_isPrefixOf :: JSString -> JSString -> Bool +foreign import javascript unsafe + "h$jsstringIsSuffixOf" js_isSuffixOf :: JSString -> JSString -> Bool +foreign import javascript unsafe + "h$jsstringIsInfixOf" js_isInfixOf :: JSString -> JSString -> Bool +foreign import javascript unsafe + "h$jsstringStripPrefix" js_stripPrefix + :: JSString -> JSString -> Exts.Any -- Maybe JSString +foreign import javascript unsafe + "h$jsstringStripSuffix" js_stripSuffix + :: JSString -> JSString -> Exts.Any -- Maybe JSString +foreign import javascript unsafe + "h$jsstringCommonPrefixes" js_commonPrefixes + :: JSString -> JSString -> Exts.Any -- Maybe (JSString, JSString, JSString) +foreign import javascript unsafe + "h$jsstringChunksOf" js_chunksOf + :: Int# -> JSString -> Exts.Any -- [JSString] +foreign import javascript unsafe + "h$jsstringChunksOf1" js_chunksOf1 + :: Int# -> Int# -> JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringSplitAt" js_splitAt + :: Int# -> JSString -> (# JSString, JSString #) +foreign import javascript unsafe + "h$jsstringSplitOn" js_splitOn + :: JSString -> JSString -> Exts.Any -- [JSString] +foreign import javascript unsafe + "h$jsstringSplitOn1" js_splitOn1 + :: Int# -> JSString -> JSString -> (# Int#, JSString #) +foreign import javascript unsafe + "h$jsstringBreakOn" js_breakOn + :: JSString -> JSString -> (# JSString, JSString #) +foreign import javascript unsafe + "h$jsstringBreakOnEnd" js_breakOnEnd + :: JSString -> JSString -> (# JSString, JSString #) +foreign import javascript unsafe + "h$jsstringBreakOnAll" js_breakOnAll + :: JSString -> JSString -> Exts.Any -- [(JSString, JSString)] +foreign import javascript unsafe + "h$jsstringBreakOnAll1" js_breakOnAll1 + :: Int# -> JSString -> JSString -> (# Int#, JSString, JSString #) +foreign import javascript unsafe + "h$jsstringDrop" js_drop :: Int# -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringDropEnd" js_dropEnd :: Int -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringTake" js_take :: Int# -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringTakeEnd" js_takeEnd :: Int# -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringReplicate" js_replicate :: Int# -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringReplicateChar" js_replicateChar :: Int -> Char -> JSString +foreign import javascript unsafe + "((x) => { var l = x.length; return l==1 || (l==2 && (x.charCodeAt(0)|1023) == 0xDFFF); })" + js_isSingleton :: JSString -> Bool +foreign import javascript unsafe + "h$jsstringIntersperse" + js_intersperse :: Char -> JSString -> JSString +foreign import javascript unsafe + "h$jsstringIntercalate" + js_intercalate :: JSString -> Exts.Any {- [JSString] -} -> JSString +foreign import javascript unsafe + "((x) => { return x.toUpperCase(); })" js_toUpper :: JSString -> JSString +foreign import javascript unsafe + "((x) => { return x.toLowerCase(); })" js_toLower :: JSString -> JSString diff --git a/src-wasm/Data/JSString/Internal.hs b/src-wasm/Data/JSString/Internal.hs new file mode 100644 index 0000000..16c1395 --- /dev/null +++ b/src-wasm/Data/JSString/Internal.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE MagicHash, NegativeLiterals, BangPatterns, + ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes + #-} + +module Data.JSString.Internal where +{- +import Prelude ( Eq(..), Ord(..), Show(..), Read(..), Bool(..) + , seq, Ordering(..)) +import Data.Data (Data(..)) +import Data.Monoid (Monoid(..)) +import Control.DeepSeq (NFData(..)) +import qualified GHC.Exts as Exts + +import Unsafe.Coerce + +newtype JSString = JSString (JSVal ()) + +instance Monoid JSString where + mempty = empty + mappend = append + mconcat = concat + +instance Eq JSString where + (==) = eqJSString + +instance Ord JSString where + compare = compareJSString + +instance NFData JSString where rnf !_ = () + +compareJSString :: JSString -> JSString -> Ordering +compareJSString x y = Exts.tagToEnum# (js_compare x y Exts.+# 2#) +{-# INLINE compareJSString #-} + +eqJSString :: JSString -> JSString -> Bool +eqJSString x y = js_eq +{-# INLINE eqJSString #-} + +-- | /O(n)/ Appends one 'JSString' to the other by copying both of them +-- into a new 'JSString'. Subject to fusion. +append :: JSString -> JSString -> JSString +append x y = js_append x y +{-# INLINE append #-} + +{-# RULES +"JSSTRING append -> fused" [~1] forall t1 t2. + append t1 t2 = unstream (S.append (stream t1) (stream t2)) +"JSSTRING append -> unfused" [1] forall t1 t2. + unstream (S.append (stream t1) (stream t2)) = append t1 t2 + #-} + +-- | /O(n)/ Concatenate a list of 'JSString's. +concat :: [JSString] -> JSString +concat ts = rnf ts `seq` js_concat (unsafeCoerce ts) +{-# INLINE concat #-} + +empty :: JSString +empty = js_empty +{-# INLINE empty #-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe + "$r='';" js_empty :: JSString +foreign import javascript unsafe + "$1+$2" js_append :: JSString -> JSString -> JSString +foreign import javascript unsafe + "$1===$2" js_eq :: JSString -> JSString -> Bool +foreign import javascript unsafe + "$1.localeCompare($2)" js_compare :: JSString -> JSString -> Exts.Int# +foreign import javascript unsafe + "h$jsstringConcat" js_concat :: Exts.Any -> JSString +-} diff --git a/src-wasm/Data/JSString/Internal/Fusion.hs b/src-wasm/Data/JSString/Internal/Fusion.hs new file mode 100644 index 0000000..0651551 --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Fusion.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns, MagicHash, ForeignFunctionInterface, JavaScriptFFI, + UnliftedFFITypes + #-} +module Data.JSString.Internal.Fusion ( -- * Types + Stream(..) + , Step(..) + + -- * Creation and elimination + , stream + , unstream + , reverseStream + + , length + + -- * Transformations + , reverse + + -- * Construction + -- ** Scans + , reverseScanr + + -- ** Accumulating maps + , mapAccumL + + -- ** Generation and unfolding + , unfoldrN + + -- * Indexing + , index + , findIndex + , countChar + ) where + +import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#)) + +import Prelude hiding (length, reverse) +import Data.Char + +import Data.JSString.Internal.Type (JSString(..)) +import qualified Data.JSString.Internal.Type as I +import Data.JSString.Internal.Fusion.Types +import qualified Data.JSString.Internal.Fusion.Common as S + +import System.IO.Unsafe + +import GHC.Wasm.Prim (JSVal) + +default (Int) + +-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'. +stream :: JSString -> Stream Char +stream x = + let next i = case js_index i x of + -1# -> Done + ch -> let !i' = i + if isTrue# (ch >=# 0x10000#) + then 2 + else 1 + in Yield (C# (chr# ch)) i' + in Stream next 0 +{-# INLINE [0] stream #-} + +-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate +-- backwards. +reverseStream :: JSString -> Stream Char +reverseStream x = + let l = js_length x + {-# INLINE next #-} + next i = case js_indexR i x of + -1# -> Done + ch -> let !i' = i - if isTrue# (ch >=# 0x10000#) + then 2 + else 1 + in Yield (C# (chr# ch)) i' + in Stream next (I# (l -# 1#)) +{-# INLINE [0] reverseStream #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'. +unstream :: Stream Char -> JSString +unstream (Stream next s) = runJSString $ \done -> + let go !s0 = case next s0 of + Done -> done I.empty + Skip s1 -> go s1 + Yield x s1 -> js_newSingletonArray x >>= loop 1 s1 + loop !i !s0 a = case next s0 of + Done -> js_packString a >>= done + Skip s1 -> loop i s1 a + Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a + in go s +{-# INLINE [0] unstream #-} +{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} + + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +runJSString :: ((a -> IO a) -> IO a) -> a +runJSString f = unsafePerformIO (f pure) + +length :: Stream Char -> Int +length = S.lengthI +{-# INLINE[0] length #-} + +-- | /O(n)/ Reverse the characters of a string. +reverse :: Stream Char -> JSString +reverse (Stream next s) = runJSString $ \done -> + let go !s0 = case next s0 of + Done -> done I.empty + Skip s1 -> go s1 + Yield x s1 -> js_newSingletonArray x >>= loop 1 s1 + loop !i !s0 a = case next s0 of + Done -> js_packReverse a >>= done + Skip s1 -> loop i s1 a + Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a + in go s +{-# INLINE [0] reverse #-} + +-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with +-- the input and result reversed. +reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char +reverseScanr f z0 (Stream next0 s0) = Stream next (S1 :*: z0 :*: s0) + where + {-# INLINE next #-} + next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) + next (S2 :*: z :*: s) = case next0 s of + Yield x s' -> let !x' = f x z + in Yield x' (S2 :*: x' :*: s') + Skip s' -> Skip (S2 :*: z :*: s') + Done -> Done +{-# INLINE reverseScanr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed +-- value. However, the length of the result is limited by the +-- first argument to 'unfoldrN'. This function is more efficient than +-- 'unfoldr' when the length of the result is known. +unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldrN n = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} + +------------------------------------------------------------------------------- +-- ** Indexing streams + +-- | /O(n)/ stream index (subscript) operator, starting from 0. +index :: Stream Char -> Int -> Char +index = S.indexI +{-# INLINE [0] index #-} + +-- | The 'findIndex' function takes a predicate and a stream and +-- returns the index of the first element in the stream +-- satisfying the predicate. +findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int +findIndex = S.findIndexI +{-# INLINE [0] findIndex #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +countChar :: Char -> Stream Char -> Int +countChar = S.countCharI +{-# INLINE [0] countChar #-} + +-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a +-- function to each element of a 'Text', passing an accumulating +-- parameter from left to right, and returns a final 'JSString'. +mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString) +mapAccumL f z0 (Stream next s0) = runJSString $ \done -> + let go !s1 = case next s1 of + Done -> done (z0, I.empty) + Skip s2 -> go s2 + Yield ch s2 -> let (z1, ch1) = f z0 ch + in js_newSingletonArray ch1 >>= loop 1 s2 z1 + loop !i !s1 !z1 a = case next s1 of + Done -> js_packString a >>= \s -> done (z1, s) + Skip s2 -> loop i s2 z1 a + Yield ch1 s2 -> let (z2, ch2) = f z1 ch1 + in js_writeArray ch2 i a >> loop (i+1) s2 z2 a + in go s0 +{-# INLINE [0] mapAccumL #-} + +------------------------------------------------------------------------------- + +-- returns -1 for end of stream +foreign import javascript unsafe + "h$jsstringIndex" js_index :: Int -> JSString -> Int# +foreign import javascript unsafe + "h$jsstringIndexR" js_indexR :: Int -> JSString -> Int# +foreign import javascript unsafe + "((x) => { return x.length; })" js_length :: JSString -> Int# +foreign import javascript unsafe + "((x) => { return [x]; })" js_newSingletonArray :: Char -> IO JSVal +foreign import javascript unsafe + "((x,y,z) => { z[y] = x; })" js_writeArray :: Char -> Int -> JSVal -> IO () +foreign import javascript unsafe + "h$jsstringPackArray" js_packString :: JSVal -> IO JSString +foreign import javascript unsafe + "h$jsstringPackArrayReverse" js_packReverse :: JSVal -> IO JSString diff --git a/src-wasm/Data/JSString/Internal/Fusion/CaseMapping.hs b/src-wasm/Data/JSString/Internal/Fusion/CaseMapping.hs new file mode 100644 index 0000000..4a111e9 --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Fusion/CaseMapping.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE Rank2Types #-} +-- AUTOMATICALLY GENERATED - DO NOT EDIT +-- Generated by scripts/SpecialCasing.hs +-- CaseFolding-6.3.0.txt +-- Date: 2012-12-20, 22:14:35 GMT [MD] +-- SpecialCasing-6.3.0.txt +-- Date: 2013-05-08, 13:54:51 GMT [MD] + +module Data.JSString.Internal.Fusion.CaseMapping where +import Data.Char +import Data.JSString.Internal.Fusion.Types + +upperMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE upperMapping #-} +-- LATIN SMALL LETTER SHARP S +upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000') +-- LATIN SMALL LIGATURE FF +upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000') +-- LATIN SMALL LIGATURE FI +upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000') +-- LATIN SMALL LIGATURE FL +upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000') +-- LATIN SMALL LIGATURE FFI +upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049') +-- LATIN SMALL LIGATURE FFL +upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c') +-- LATIN SMALL LIGATURE LONG S T +upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- LATIN SMALL LIGATURE ST +upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399') +upperMapping c s = Yield (toUpper c) (CC s '\0' '\0') +lowerMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE lowerMapping #-} +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +lowerMapping c s = Yield (toLower c) (CC s '\0' '\0') +titleMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE titleMapping #-} +-- LATIN SMALL LETTER SHARP S +titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000') +-- LATIN SMALL LIGATURE FF +titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345') +titleMapping c s = Yield (toTitle c) (CC s '\0' '\0') +foldMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE foldMapping #-} +-- MICRO SIGN +foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER SHARP S +foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000') +-- LATIN SMALL LETTER LONG S +foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER J WITH CARON +foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000') +-- COMBINING GREEK YPOGEGRAMMENI +foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER FINAL SIGMA +foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000') +-- GREEK BETA SYMBOL +foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000') +-- GREEK THETA SYMBOL +foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000') +-- GREEK PHI SYMBOL +foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000') +-- GREEK PI SYMBOL +foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000') +-- GREEK KAPPA SYMBOL +foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000') +-- GREEK RHO SYMBOL +foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000') +-- GREEK LUNATE EPSILON SYMBOL +foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000') +-- GEORGIAN CAPITAL LETTER YN +foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000') +-- GEORGIAN CAPITAL LETTER AEN +foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000') +-- LATIN SMALL LETTER LONG S WITH DOT ABOVE +foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER SHARP S +foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK PROSGEGRAMMENI +foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- COPTIC CAPITAL LETTER BOHAIRIC KHEI +foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER C WITH BAR +foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER H WITH HOOK +foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000') +-- LATIN SMALL LIGATURE FF +foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000') +foldMapping c s = Yield (toLower c) (CC s '\0' '\0') diff --git a/src-wasm/Data/JSString/Internal/Fusion/Common.hs b/src-wasm/Data/JSString/Internal/Fusion/Common.hs new file mode 100644 index 0000000..4f906de --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Fusion/Common.hs @@ -0,0 +1,936 @@ +{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-} + +module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination + singleton + , streamList + , unstreamList + , streamCString# + + -- * Basic interface + , cons + , snoc + , append + , head + , uncons + , last + , tail + , init + , null + , lengthI + , compareLengthI + , isSingleton + + -- * Transformations + , map + , intercalate + , intersperse + + -- ** Case conversion + -- $case + , toCaseFold + , toLower + , toTitle + , toUpper + + -- ** Justification + , justifyLeftI + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + -- ** Scans + , scanl + + -- ** Accumulating maps + -- , mapAccumL + + -- ** Generation and unfolding + , replicateCharI + , replicateI + , unfoldr + , unfoldrNI + + -- * Substrings + -- ** Breaking strings + , take + , drop + , takeWhile + , dropWhile + + -- * Predicates + , isPrefixOf + + -- * Searching + , elem + , filter + + -- * Indexing + , findBy + , indexI + , findIndexI + , countCharI + + -- * Zipping and unzipping + , zipWith + ) where + + +import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..), + Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++), + (&&), fromIntegral, otherwise) +import qualified Data.List as L +import qualified Prelude as P +import Data.Bits (shiftL) +import Data.Char (isLetter, isSpace) +import Data.Int (Int64) +import Data.JSString.Internal.Fusion.CaseMapping + (foldMapping, lowerMapping, titleMapping, upperMapping) +import Data.JSString.Internal.Fusion.Types +import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#) +import GHC.Types (Char(..), Int(..)) + +singleton :: Char -> Stream Char +singleton c = Stream next False + where next False = Yield c True + next True = Done +{-# INLINE [0] singleton #-} + +streamList :: [a] -> Stream a +{-# INLINE [0] streamList #-} +streamList s = Stream next s + where next [] = Done + next (x:xs) = Yield x xs + +unstreamList :: Stream a -> [a] +unstreamList (Stream next s0) = unfold s0 + where unfold !s = case next s of + Done -> [] + Skip s' -> unfold s' + Yield x s' -> x : unfold s' +{-# INLINE [0] unstreamList #-} + +{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-} + +-- | Stream the UTF-8-like packed encoding used by GHC to represent +-- constant strings in generated code. +-- +-- This encoding uses the byte sequence "\xc0\x80" to represent NUL, +-- and the string is NUL-terminated. +streamCString# :: Addr# -> Stream Char +streamCString# addr = Stream step 0 -- unknownSize + where + step !i + | b == 0 = Done + | b <= 0x7f = Yield (C# b#) (i+1) + | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1 + in Yield c (i+2) + | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) + + (next 1 `shiftL` 6) + + next 2 + in Yield c (i+3) + | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) + + (next 1 `shiftL` 12) + + (next 2 `shiftL` 6) + + next 3 + in Yield c (i+4) + where b = I# (ord# b#) + next n = I# (ord# (at# (i+n))) - 0x80 + !b# = at# i + at# (I# i#) = indexCharOffAddr# addr i# + chr (I# i#) = C# (chr# i#) +{-# INLINE [0] streamCString# #-} + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +data C s = C0 !s + | C1 !s + +-- | /O(n)/ Adds a character to the front of a Stream Char. +cons :: Char -> Stream Char -> Stream Char +cons !w (Stream next0 s0) = Stream next (C1 s0) + where + next (C1 s) = Yield w (C0 s) + next (C0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (C0 s') + Yield x s' -> Yield x (C0 s') +{-# INLINE [0] cons #-} + +-- | /O(n)/ Adds a character to the end of a stream. +snoc :: Stream Char -> Char -> Stream Char +snoc (Stream next0 xs0) w = Stream next (J xs0) + where + next (J xs) = case next0 xs of + Done -> Yield w N + Skip xs' -> Skip (J xs') + Yield x xs' -> Yield x (J xs') + next N = Done +{-# INLINE [0] snoc #-} + +data E l r = L !l + | R !r + +-- | /O(n)/ Appends one Stream to the other. +append :: Stream Char -> Stream Char -> Stream Char +append (Stream next0 s01) (Stream next1 s02) = + Stream next (L s01) + where + next (L s1) = case next0 s1 of + Done -> Skip (R s02) + Skip s1' -> Skip (L s1') + Yield x s1' -> Yield x (L s1') + next (R s2) = case next1 s2 of + Done -> Done + Skip s2' -> Skip (R s2') + Yield x s2' -> Yield x (R s2') +{-# INLINE [0] append #-} + +-- | /O(1)/ Returns the first character of a Text, which must be non-empty. +-- Subject to array fusion. +head :: Stream Char -> Char +head (Stream next s0) = loop_head s0 + where + loop_head !s = case next s of + Yield x _ -> x + Skip s' -> loop_head s' + Done -> head_empty +{-# INLINE [0] head #-} + +head_empty :: a +head_empty = streamError "head" "Empty stream" +{-# NOINLINE head_empty #-} + +-- | /O(1)/ Returns the first character and remainder of a 'Stream +-- Char', or 'Nothing' if empty. Subject to array fusion. +uncons :: Stream Char -> Maybe (Char, Stream Char) +uncons (Stream next s0) = loop_uncons s0 + where + loop_uncons !s = case next s of + Yield x s1 -> Just (x, Stream next s1) + Skip s' -> loop_uncons s' + Done -> Nothing +{-# INLINE [0] uncons #-} + +-- | /O(n)/ Returns the last character of a 'Stream Char', which must +-- be non-empty. +last :: Stream Char -> Char +last (Stream next s0) = loop0_last s0 + where + loop0_last !s = case next s of + Done -> emptyError "last" + Skip s' -> loop0_last s' + Yield x s' -> loop_last x s' + loop_last !x !s = case next s of + Done -> x + Skip s' -> loop_last x s' + Yield x' s' -> loop_last x' s' +{-# INLINE[0] last #-} + +-- | /O(1)/ Returns all characters after the head of a Stream Char, which must +-- be non-empty. +tail :: Stream Char -> Stream Char +tail (Stream next0 s0) = Stream next (C0 s0) + where + next (C0 s) = case next0 s of + Done -> emptyError "tail" + Skip s' -> Skip (C0 s') + Yield _ s' -> Skip (C1 s') + next (C1 s) = case next0 s of + Done -> Done + Skip s' -> Skip (C1 s') + Yield x s' -> Yield x (C1 s') +{-# INLINE [0] tail #-} + +data Init s = Init0 !s + | Init1 {-# UNPACK #-} !Char !s + +-- | /O(1)/ Returns all but the last character of a Stream Char, which +-- must be non-empty. +init :: Stream Char -> Stream Char +init (Stream next0 s0) = Stream next (Init0 s0) + where + next (Init0 s) = case next0 s of + Done -> emptyError "init" + Skip s' -> Skip (Init0 s') + Yield x s' -> Skip (Init1 x s') + next (Init1 x s) = case next0 s of + Done -> Done + Skip s' -> Skip (Init1 x s') + Yield x' s' -> Yield x (Init1 x' s') +{-# INLINE [0] init #-} + +-- | /O(1)/ Tests whether a Stream Char is empty or not. +null :: Stream Char -> Bool +null (Stream next s0) = loop_null s0 + where + loop_null !s = case next s of + Done -> True + Yield _ _ -> False + Skip s' -> loop_null s' +{-# INLINE[0] null #-} + +-- | /O(n)/ Returns the number of characters in a string. +lengthI :: Integral a => Stream Char -> a +lengthI (Stream next s0) = loop_length 0 s0 + where + loop_length !z s = case next s of + Done -> z + Skip s' -> loop_length z s' + Yield _ s' -> loop_length (z + 1) s' +{-# INLINE[0] lengthI #-} + +-- | /O(n)/ Compares the count of characters in a string to a number. +-- Subject to fusion. +-- +-- This function gives the same answer as comparing against the result +-- of 'lengthI', but can short circuit if the count of characters is +-- greater than the number or if the stream can't possibly be as long +-- as the number supplied, and hence be more efficient. +compareLengthI :: Integral a => Stream Char -> a -> Ordering +compareLengthI (Stream next s0) n = loop_cmp 0 s0 + {- case compareSize len (fromIntegral n) of + Just o -> o + Nothing -> loop_cmp 0 s0 -} + where + loop_cmp !z s = case next s of + Done -> compare z n + Skip s' -> loop_cmp z s' + Yield _ s' | z > n -> GT + | otherwise -> loop_cmp (z + 1) s' +{-# INLINE[0] compareLengthI #-} + +-- | /O(n)/ Indicate whether a string contains exactly one element. +isSingleton :: Stream Char -> Bool +isSingleton (Stream next s0) = loop 0 s0 + where + loop !z s = case next s of + Done -> z == (1::Int) + Skip s' -> loop z s' + Yield _ s' + | z >= 1 -> False + | otherwise -> loop (z+1) s' +{-# INLINE[0] isSingleton #-} + +-- ---------------------------------------------------------------------------- +-- * Stream transformations + +-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@ +-- to each element of @xs@. +map :: (Char -> Char) -> Stream Char -> Stream Char +map f (Stream next0 s0) = Stream next s0 + where + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' +{-# INLINE [0] map #-} + +{-# + RULES "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + +data I s = I1 !s + | I2 !s {-# UNPACK #-} !Char + | I3 !s + +-- | /O(n)/ Take a character and place it between each of the +-- characters of a 'Stream Char'. +intersperse :: Char -> Stream Char -> Stream Char +intersperse c (Stream next0 s0) = Stream next (I1 s0) -- len + where + next (I1 s) = case next0 s of + Done -> Done + Skip s' -> Skip (I1 s') + Yield x s' -> Skip (I2 s' x) + next (I2 s x) = Yield x (I3 s) + next (I3 s) = case next0 s of + Done -> Done + Skip s' -> Skip (I3 s') + Yield x s' -> Yield c (I2 s' x) +{-# INLINE [0] intersperse #-} + +-- ---------------------------------------------------------------------------- +-- ** Case conversions (folds) + +-- $case +-- +-- With Unicode text, it is incorrect to use combinators like @map +-- toUpper@ to case convert each character of a string individually. +-- Instead, use the whole-string case conversion functions from this +-- module. For correctness in different writing systems, these +-- functions may map one input character to two or three output +-- characters. + +caseConvert :: (forall s. Char -> s -> Step (CC s) Char) + -> Stream Char -> Stream Char +caseConvert remap (Stream next0 s0) = Stream next (CC s0 '\0' '\0') + where + next (CC s '\0' _) = + case next0 s of + Done -> Done + Skip s' -> Skip (CC s' '\0' '\0') + Yield c s' -> remap c s' + next (CC s a b) = Yield a (CC s b '\0') + +-- | /O(n)/ Convert a string to folded case. This function is mainly +-- useful for performing caseless (or case insensitive) string +-- comparisons. +-- +-- A string @x@ is a caseless match for a string @y@ if and only if: +-- +-- @toCaseFold x == toCaseFold y@ +-- +-- The result string may be longer than the input string, and may +-- differ from applying 'toLower' to the input string. For instance, +-- the Armenian small ligature men now (U+FB13) is case folded to the +-- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is +-- case folded to the Greek small letter letter mu (U+03BC) instead of +-- itself. +toCaseFold :: Stream Char -> Stream Char +toCaseFold = caseConvert foldMapping +{-# INLINE [0] toCaseFold #-} + +-- | /O(n)/ Convert a string to upper case, using simple case +-- conversion. The result string may be longer than the input string. +-- For instance, the German eszett (U+00DF) maps to the two-letter +-- sequence SS. +toUpper :: Stream Char -> Stream Char +toUpper = caseConvert upperMapping +{-# INLINE [0] toUpper #-} + +-- | /O(n)/ Convert a string to lower case, using simple case +-- conversion. The result string may be longer than the input string. +-- For instance, the Latin capital letter I with dot above (U+0130) +-- maps to the sequence Latin small letter i (U+0069) followed by +-- combining dot above (U+0307). +toLower :: Stream Char -> Stream Char +toLower = caseConvert lowerMapping +{-# INLINE [0] toLower #-} + +-- | /O(n)/ Convert a string to title case, using simple case +-- conversion. +-- +-- The first letter of the input is converted to title case, as is +-- every subsequent letter that immediately follows a non-letter. +-- Every letter that immediately follows another letter is converted +-- to lower case. +-- +-- The result string may be longer than the input string. For example, +-- the Latin small ligature fl (U+FB02) is converted to the +-- sequence Latin capital letter F (U+0046) followed by Latin small +-- letter l (U+006C). +-- +-- /Note/: this function does not take language or culture specific +-- rules into account. For instance, in English, different style +-- guides disagree on whether the book name \"The Hill of the Red +-- Fox\" is correctly title cased—but this function will +-- capitalize /every/ word. +toTitle :: Stream Char -> Stream Char +toTitle (Stream next0 s0) = Stream next (CC (False :*: s0) '\0' '\0') + where + next (CC (letter :*: s) '\0' _) = + case next0 s of + Done -> Done + Skip s' -> Skip (CC (letter :*: s') '\0' '\0') + Yield c s' + | nonSpace -> if letter + then lowerMapping c (nonSpace :*: s') + else titleMapping c (letter' :*: s') + | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0') + where nonSpace = P.not (isSpace c) + letter' = isLetter c + next (CC s a b) = Yield a (CC s b '\0') +{-# INLINE [0] toTitle #-} + +justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char +justifyLeftI k c (Stream next0 s0) = + Stream next (s0 :*: S1 :*: 0) + where + next (s :*: S1 :*: n) = + case next0 s of + Done -> next (s :*: S2 :*: n) + Skip s' -> Skip (s' :*: S1 :*: n) + Yield x s' -> Yield x (s' :*: S1 :*: n+1) + next (s :*: S2 :*: n) + | n < k = Yield c (s :*: S2 :*: n+1) + | otherwise = Done + {-# INLINE next #-} +{-# INLINE [0] justifyLeftI #-} + +-- ---------------------------------------------------------------------------- +-- * Reducing Streams (folds) + +-- | foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a Stream, reduces the Stream using the +-- binary operator, from left to right. +foldl :: (b -> Char -> b) -> b -> Stream Char -> b +foldl f z0 (Stream next s0) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> z + Skip s' -> loop_foldl z s' + Yield x s' -> loop_foldl (f z x) s' +{-# INLINE [0] foldl #-} + +-- | A strict version of foldl. +foldl' :: (b -> Char -> b) -> b -> Stream Char -> b +foldl' f z0 (Stream next s0) = loop_foldl' z0 s0 + where + loop_foldl' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl' z s' + Yield x s' -> loop_foldl' (f z x) s' +{-# INLINE [0] foldl' #-} + +-- | foldl1 is a variant of foldl that has no starting value argument, +-- and thus must be applied to non-empty Streams. +foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1 f (Stream next s0) = loop0_foldl1 s0 + where + loop0_foldl1 !s = case next s of + Skip s' -> loop0_foldl1 s' + Yield x s' -> loop_foldl1 x s' + Done -> emptyError "foldl1" + loop_foldl1 z !s = case next s of + Done -> z + Skip s' -> loop_foldl1 z s' + Yield x s' -> loop_foldl1 (f z x) s' +{-# INLINE [0] foldl1 #-} + +-- | A strict version of foldl1. +foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1' f (Stream next s0) = loop0_foldl1' s0 + where + loop0_foldl1' !s = case next s of + Skip s' -> loop0_foldl1' s' + Yield x s' -> loop_foldl1' x s' + Done -> emptyError "foldl1" + loop_foldl1' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl1' z s' + Yield x s' -> loop_foldl1' (f z x) s' +{-# INLINE [0] foldl1' #-} + +-- | 'foldr', applied to a binary operator, a starting value (typically the +-- right-identity of the operator), and a stream, reduces the stream using the +-- binary operator, from right to left. +foldr :: (Char -> b -> b) -> b -> Stream Char -> b +foldr f z (Stream next s0) = loop_foldr s0 + where + loop_foldr !s = case next s of + Done -> z + Skip s' -> loop_foldr s' + Yield x s' -> f x (loop_foldr s') +{-# INLINE [0] foldr #-} + +-- | foldr1 is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty streams. +-- Subject to array fusion. +foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldr1 f (Stream next s0) = loop0_foldr1 s0 + where + loop0_foldr1 !s = case next s of + Done -> emptyError "foldr1" + Skip s' -> loop0_foldr1 s' + Yield x s' -> loop_foldr1 x s' + + loop_foldr1 x !s = case next s of + Done -> x + Skip s' -> loop_foldr1 x s' + Yield x' s' -> f x (loop_foldr1 x' s') +{-# INLINE [0] foldr1 #-} + +intercalate :: Stream Char -> [Stream Char] -> Stream Char +intercalate s = concat . (L.intersperse s) +{-# INLINE [0] intercalate #-} + +-- ---------------------------------------------------------------------------- +-- ** Special folds + +-- | /O(n)/ Concatenate a list of streams. Subject to array fusion. +concat :: [Stream Char] -> Stream Char +concat = L.foldr append empty +{-# INLINE [0] concat #-} + +-- | Map a function over a stream that results in a stream and concatenate the +-- results. +concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char +concatMap f = foldr (append . f) empty +{-# INLINE [0] concatMap #-} + +-- | /O(n)/ any @p @xs determines if any character in the stream +-- @xs@ satisifes the predicate @p@. +any :: (Char -> Bool) -> Stream Char -> Bool +any p (Stream next0 s0) = loop_any s0 + where + loop_any !s = case next0 s of + Done -> False + Skip s' -> loop_any s' + Yield x s' | p x -> True + | otherwise -> loop_any s' +{-# INLINE [0] any #-} + +-- | /O(n)/ all @p @xs determines if all characters in the 'Text' +-- @xs@ satisify the predicate @p@. +all :: (Char -> Bool) -> Stream Char -> Bool +all p (Stream next0 s0) = loop_all s0 + where + loop_all !s = case next0 s of + Done -> True + Skip s' -> loop_all s' + Yield x s' | p x -> loop_all s' + | otherwise -> False +{-# INLINE [0] all #-} + +-- | /O(n)/ maximum returns the maximum value from a stream, which must be +-- non-empty. +maximum :: Stream Char -> Char +maximum (Stream next0 s0) = loop0_maximum s0 + where + loop0_maximum !s = case next0 s of + Done -> emptyError "maximum" + Skip s' -> loop0_maximum s' + Yield x s' -> loop_maximum x s' + loop_maximum !z !s = case next0 s of + Done -> z + Skip s' -> loop_maximum z s' + Yield x s' + | x > z -> loop_maximum x s' + | otherwise -> loop_maximum z s' +{-# INLINE [0] maximum #-} + +-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be +-- non-empty. +minimum :: Stream Char -> Char +minimum (Stream next0 s0) = loop0_minimum s0 + where + loop0_minimum !s = case next0 s of + Done -> emptyError "minimum" + Skip s' -> loop0_minimum s' + Yield x s' -> loop_minimum x s' + loop_minimum !z !s = case next0 s of + Done -> z + Skip s' -> loop_minimum z s' + Yield x s' + | x < z -> loop_minimum x s' + | otherwise -> loop_minimum z s' +{-# INLINE [0] minimum #-} + +-- ----------------------------------------------------------------------------- +-- * Building streams + +scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char +scanl f z0 (Stream next0 s0) = Stream next (S1 :*: z0 :*: s0) + where + {-# INLINE next #-} + next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) + next (S2 :*: z :*: s) = case next0 s of + Yield x s' -> let !x' = f z x + in Yield x' (S2 :*: x' :*: s') + Skip s' -> Skip (S2 :*: z :*: s') + Done -> Done +{-# INLINE [0] scanl #-} + +-- ----------------------------------------------------------------------------- +-- ** Accumulating maps + +{- +-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a +-- function to each element of a stream, passing an accumulating +-- parameter from left to right, and returns a final stream. +-- +-- /Note/: Unlike the version over lists, this function does not +-- return a final value for the accumulator, because the nature of +-- streams precludes it. +mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b +mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :*: z0) len -- HINT depends on f + where + {-# INLINE next #-} + next (s :*: z) = case next0 s of + Yield x s' -> let (z',y) = f z x + in Yield y (s' :*: z') + Skip s' -> Skip (s' :*: z) + Done -> Done +{-# INLINE [0] mapAccumL #-} +-} + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding streams + +replicateCharI :: Integral a => a -> Char -> Stream Char +replicateCharI n c + | n < 0 = empty + | otherwise = Stream next 0 -- HINT maybe too low + where + next i | i >= n = Done + | otherwise = Yield c (i + 1) +{-# INLINE [0] replicateCharI #-} + +data RI s = RI !s {-# UNPACK #-} !Int64 + +replicateI :: Int64 -> Stream Char -> Stream Char +replicateI n (Stream next0 s0) = + Stream next (RI s0 0) + where + next (RI s k) + | k >= n = Done + | otherwise = case next0 s of + Done -> Skip (RI s0 (k+1)) + Skip s' -> Skip (RI s' k) + Yield x s' -> Yield x (RI s' k) +{-# INLINE [0] replicateI #-} + +-- | /O(n)/, where @n@ is the length of the result. The unfoldr function +-- is analogous to the List 'unfoldr'. unfoldr builds a stream +-- from a seed value. The function takes the element and returns +-- Nothing if it is done producing the stream or returns Just +-- (a,b), in which case, a is the next Char in the string, and b is +-- the seed value for further production. +unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldr f s0 = Stream next s0 + where + {-# INLINE next #-} + next !s = case f s of + Nothing -> Done + Just (w, s') -> Yield w s' +{-# INLINE [0] unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed +-- value. However, the length of the result is limited by the +-- first argument to 'unfoldrNI'. This function is more efficient than +-- 'unfoldr' when the length of the result is known. +unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char +unfoldrNI n f s0 | n < 0 = empty + | otherwise = Stream next (0 :*: s0) + where + {-# INLINE next #-} + next (z :*: s) = case f s of + Nothing -> Done + Just (w, s') | z >= n -> Done + | otherwise -> Yield w ((z + 1) :*: s') +{-# INLINE unfoldrNI #-} + +------------------------------------------------------------------------------- +-- * Substreams + +-- | /O(n)/ take n, applied to a stream, returns the prefix of the +-- stream of length @n@, or the stream itself if @n@ is greater than the +-- length of the stream. +take :: Integral a => a -> Stream Char -> Stream Char +take n0 (Stream next0 s0) = + Stream next (n0 :*: s0) + where + {-# INLINE next #-} + next (n :*: s) | n <= 0 = Done + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (n :*: s') + Yield x s' -> Yield x ((n-1) :*: s') +{-# INLINE [0] take #-} + +-- | /O(n)/ drop n, applied to a stream, returns the suffix of the +-- stream after the first @n@ characters, or the empty stream if @n@ +-- is greater than the length of the stream. +drop :: Integral a => a -> Stream Char -> Stream Char +drop n0 (Stream next0 s0) = + Stream next (J n0 :*: s0) + where + {-# INLINE next #-} + next (J n :*: s) + | n <= 0 = Skip (N :*: s) + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (J n :*: s') + Yield _ s' -> Skip (J (n-1) :*: s') + next (N :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (N :*: s') + Yield x s' -> Yield x (N :*: s') +{-# INLINE [0] drop #-} + +-- | takeWhile, applied to a predicate @p@ and a stream, returns the +-- longest prefix (possibly empty) of elements that satisfy p. +takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char +takeWhile p (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done +{-# INLINE [0] takeWhile #-} + +-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs. +dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char +dropWhile p (Stream next0 s0) = Stream next (S1 :*: s0) + where + {-# INLINE next #-} + next (S1 :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :*: s') + Yield x s' | p x -> Skip (S1 :*: s') + | otherwise -> Yield x (S2 :*: s') + next (S2 :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :*: s') + Yield x s' -> Yield x (S2 :*: s') +{-# INLINE [0] dropWhile #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns +-- 'True' iff the first is a prefix of the second. +isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool +isPrefixOf (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2) + where + loop Done _ = True + loop _ Done = False + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] isPrefixOf #-} + +-- ---------------------------------------------------------------------------- +-- * Searching + +------------------------------------------------------------------------------- +-- ** Searching by equality + +-- | /O(n)/ elem is the stream membership predicate. +elem :: Char -> Stream Char -> Bool +elem w (Stream next s0) = loop_elem s0 + where + loop_elem !s = case next s of + Done -> False + Skip s' -> loop_elem s' + Yield x s' | x == w -> True + | otherwise -> loop_elem s' +{-# INLINE [0] elem #-} + +------------------------------------------------------------------------------- +-- ** Searching with a predicate + +-- | /O(n)/ The 'findBy' function takes a predicate and a stream, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. + +findBy :: (Char -> Bool) -> Stream Char -> Maybe Char +findBy p (Stream next s0) = loop_find s0 + where + loop_find !s = case next s of + Done -> Nothing + Skip s' -> loop_find s' + Yield x s' | p x -> Just x + | otherwise -> loop_find s' +{-# INLINE [0] findBy #-} + +-- | /O(n)/ Stream index (subscript) operator, starting from 0. +indexI :: Integral a => Stream Char -> a -> Char +indexI (Stream next s0) n0 + | n0 < 0 = streamError "index" "Negative index" + | otherwise = loop_index n0 s0 + where + loop_index !n !s = case next s of + Done -> streamError "index" "Index too large" + Skip s' -> loop_index n s' + Yield x s' | n == 0 -> x + | otherwise -> loop_index (n-1) s' +{-# INLINE [0] indexI #-} + +-- | /O(n)/ 'filter', applied to a predicate and a stream, +-- returns a stream containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> Stream Char -> Stream Char +filter p (Stream next0 s0) = Stream next s0 + where + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Skip s' +{-# INLINE [0] filter #-} + +{-# RULES + "STREAM filter/filter fusion" forall p q s. + filter p (filter q s) = filter (\x -> q x && p x) s + #-} + +-- | The 'findIndexI' function takes a predicate and a stream and +-- returns the index of the first element in the stream satisfying the +-- predicate. +findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a +findIndexI p s = case findIndicesI p s of + (i:_) -> Just i + _ -> Nothing +{-# INLINE [0] findIndexI #-} + +-- | The 'findIndicesI' function takes a predicate and a stream and +-- returns all indices of the elements in the stream satisfying the +-- predicate. +findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a] +findIndicesI p (Stream next s0) = loop_findIndex 0 s0 + where + loop_findIndex !i !s = case next s of + Done -> [] + Skip s' -> loop_findIndex i s' -- hmm. not caught by QC + Yield x s' | p x -> i : loop_findIndex (i+1) s' + | otherwise -> loop_findIndex (i+1) s' +{-# INLINE [0] findIndicesI #-} + +------------------------------------------------------------------------------- +-- * Zipping + +-- | zipWith generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. +zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b +zipWith f (Stream next0 sa0) (Stream next1 sb0) = + Stream next (sa0 :*: sb0 :*: N) + where + next (sa :*: sb :*: N) = case next0 sa of + Done -> Done + Skip sa' -> Skip (sa' :*: sb :*: N) + Yield a sa' -> Skip (sa' :*: sb :*: J a) + + next (sa' :*: sb :*: J a) = case next1 sb of + Done -> Done + Skip sb' -> Skip (sa' :*: sb' :*: J a) + Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N) +{-# INLINE [0] zipWith #-} + +-- | /O(n)/ The 'countCharI' function returns the number of times the +-- query element appears in the given stream. +countCharI :: Integral a => Char -> Stream Char -> a +countCharI a (Stream next s0) = loop 0 s0 + where + loop !i !s = case next s of + Done -> i + Skip s' -> loop i s' + Yield x s' | a == x -> loop (i+1) s' + | otherwise -> loop i s' +{-# INLINE [0] countCharI #-} + +streamError :: String -> String -> a +streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg + +emptyError :: String -> a +emptyError func = internalError func "Empty input" + +internalError :: String -> a +internalError func = streamError func "Internal error" diff --git a/src-wasm/Data/JSString/Internal/Fusion/Types.hs b/src-wasm/Data/JSString/Internal/Fusion/Types.hs new file mode 100644 index 0000000..b533d4e --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Fusion/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns, ExistentialQuantification #-} +-- | +-- Module : Data.Text.Internal.Fusion.Types +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009, +-- (c) Jasper Van der Jeugt 2011 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Core stream fusion functionality for text. + +module Data.JSString.Internal.Fusion.Types + ( + CC(..) + , M(..) + , M8 + , PairS(..) + , RS(..) + , Step(..) + , Stream(..) + , Switch(..) + , empty + ) where + +-- import Data.Text.Internal.Fusion.Size +import Data.Word (Word8) + +-- | Specialised tuple for case conversion. +data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char + +-- | Specialised, strict Maybe-like type. +data M a = N + | J !a + +type M8 = M Word8 + +-- Restreaming state. +data RS s + = RS0 !s + | RS1 !s {-# UNPACK #-} !Word8 + | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + +infixl 2 :*: +data PairS a b = !a :*: !b + -- deriving (Eq, Ord, Show) + +-- | Allow a function over a stream to switch between two states. +data Switch = S1 | S2 + +data Step s a = Done + | Skip !s + | Yield !a !s + +{- +instance (Show a) => Show (Step s a) + where show Done = "Done" + show (Skip _) = "Skip" + show (Yield x _) = "Yield " ++ show x +-} + +instance (Eq a) => Eq (Stream a) where + (==) = eq + +instance (Ord a) => Ord (Stream a) where + compare = cmp + +-- The length hint in a Stream has two roles. If its value is zero, +-- we trust it, and treat the stream as empty. Otherwise, we treat it +-- as a hint: it should usually be accurate, so we use it when +-- unstreaming to decide what size array to allocate. However, the +-- unstreaming functions must be able to cope with the hint being too +-- small or too large. + +data Stream a = + forall s. Stream + (s -> Step s a) -- stepper function + !s -- current state + +-- | /O(n)/ Determines if two streams are equal. +eq :: (Eq a) => Stream a -> Stream a -> Bool +eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2) + where + loop Done Done = True + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = False + loop _ Done = False + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] eq #-} + +cmp :: (Ord a) => Stream a -> Stream a -> Ordering +cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2) + where + loop Done Done = EQ + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = LT + loop _ Done = GT + loop (Yield x1 s1') (Yield x2 s2') = + case compare x1 x2 of + EQ -> loop (next1 s1') (next2 s2') + other -> other +{-# INLINE [0] cmp #-} + +-- | The empty stream. +empty :: Stream a +empty = Stream next () + where next _ = Done +{-# INLINE [0] empty #-} diff --git a/src-wasm/Data/JSString/Internal/Search.hs b/src-wasm/Data/JSString/Internal/Search.hs new file mode 100644 index 0000000..22c6165 --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Search.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies, + ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, + GHCForeignImportPrim + #-} + +module Data.JSString.Internal.Search ( indices + ) where + +import GHC.Exts (Int#, (+#), Int(..)) +import Data.JSString + +indices :: JSString -> JSString -> [Int] +indices needle haystack = go 0# 0# + where + go n i = case js_indexOf needle n i haystack of + (# -1#, _ #) -> [] + (# n' , i' #) -> I# n' : go (n' +# 1#) (i' +# 1#) + +foreign import javascript unsafe + "h$jsstringIndices" + js_indexOf :: JSString -> Int# -> Int# -> JSString -> (# Int#, Int# #) diff --git a/src-wasm/Data/JSString/Internal/Type.hs b/src-wasm/Data/JSString/Internal/Type.hs new file mode 100644 index 0000000..2466f46 --- /dev/null +++ b/src-wasm/Data/JSString/Internal/Type.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash, + BangPatterns, ForeignFunctionInterface, JavaScriptFFI #-} +{-# OPTIONS_HADDOCK not-home #-} +module Data.JSString.Internal.Type ( JSString(..) + , empty + , empty_ + , safe + , firstf + ) where + + {- + -- * Construction + , text + , textP + -- * Safety + , safe + -- * Code that must be here for accessibility + , empty + , empty_ + -- * Utilities + , firstf + -- * Checked multiplication + , mul + , mul32 + , mul64 + -- * Debugging + , showText + + ) where +-} +import Control.DeepSeq + +import Data.Bits +import Data.Int (Int32, Int64) +-- import Data.Text.Internal.Unsafe.Char (ord) +import Data.Typeable (Typeable) +import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) + +import GHC.Wasm.Prim (JSVal) + +import GHCJS.Internal.Types + +-- | A wrapper around a JavaScript string +newtype JSString = JSString JSVal +instance IsJSVal JSString + +instance NFData JSString where rnf !x = () + +foreign import javascript unsafe + "(() => { return ''; })" js_empty :: JSString + +-- | /O(1)/ The empty 'JSString'. +empty :: JSString +empty = js_empty +{-# INLINE [1] empty #-} + +-- | A non-inlined version of 'empty'. +empty_ :: JSString +empty_ = js_empty +{-# NOINLINE empty_ #-} + +safe :: Char -> Char +safe c@(C# cc) + | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c + | otherwise = '\xfffd' +{-# INLINE [0] safe #-} + + +-- | Apply a function to the first element of an optional pair. +firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b) +firstf f (Just (a, b)) = Just (f a, b) +firstf _ Nothing = Nothing + +{- +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul :: Int -> Int -> Int +#if WORD_SIZE_IN_BITS == 64 +mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b +#else +mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b +#endif +{-# INLINE mul #-} +infixl 7 `mul` + +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul64 :: Int64 -> Int64 -> Int64 +mul64 a b + | a >= 0 && b >= 0 = mul64_ a b + | a >= 0 = -mul64_ a (-b) + | b >= 0 = -mul64_ (-a) b + | otherwise = mul64_ (-a) (-b) +{-# INLINE mul64 #-} +infixl 7 `mul64` + +mul64_ :: Int64 -> Int64 -> Int64 +mul64_ a b + | ahi > 0 && bhi > 0 = error "overflow" + | top > 0x7fffffff = error "overflow" + | total < 0 = error "overflow" + | otherwise = total + where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #) + (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #) + top = ahi * blo + alo * bhi + total = (top `shiftL` 32) + alo * blo +{-# INLINE mul64_ #-} + +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul32 :: Int32 -> Int32 -> Int32 +mul32 a b = case fromIntegral a * fromIntegral b of + ab | ab < min32 || ab > max32 -> error "overflow" + | otherwise -> fromIntegral ab + where min32 = -0x80000000 :: Int64 + max32 = 0x7fffffff +{-# INLINE mul32 #-} +infixl 7 `mul32` +-} diff --git a/src-wasm/Data/JSString/Text.hs b/src-wasm/Data/JSString/Text.hs new file mode 100644 index 0000000..fbcc972 --- /dev/null +++ b/src-wasm/Data/JSString/Text.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI, + UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim, + MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-} + +{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' + + -} + +module Data.JSString.Text + ( textToJSString + , textFromJSString + , lazyTextToJSString + , lazyTextFromJSString + , textFromJSVal + , lazyTextFromJSVal + ) where + +import GHC.Wasm.Prim (JSVal) + +import GHC.Exts (ByteArray#, Int(..), Int#, Any) + +import Control.DeepSeq + +import qualified Data.Text.Array as A +import qualified Data.Text as T +import qualified Data.Text.Internal as T +import qualified Data.Text.Lazy as TL + +import Data.JSString.Internal.Type + +import Unsafe.Coerce + +textToJSString :: T.Text -> JSString +textToJSString (T.Text (A.ByteArray ba) (I# offset) (I# length)) = + js_toString ba offset length +{-# INLINE textToJSString #-} + +textFromJSString :: JSString -> T.Text +textFromJSString j = + case js_fromString j of + (# _ , 0# #) -> T.empty + (# ba, length #) -> T.Text (A.ByteArray ba) 0 (I# length) +{-# INLINE textFromJSString #-} + +lazyTextToJSString :: TL.Text -> JSString +lazyTextToJSString t = rnf t `seq` js_lazyTextToString (unsafeCoerce t) +{-# INLINE lazyTextToJSString #-} + +lazyTextFromJSString :: JSString -> TL.Text +lazyTextFromJSString = TL.fromStrict . textFromJSString +{-# INLINE lazyTextFromJSString #-} + +-- | returns the empty Text if not a string +textFromJSVal :: JSVal -> T.Text +textFromJSVal j = case js_fromString' j of + (# _, 0# #) -> T.empty + (# ba, length #) -> T.Text (A.ByteArray ba) 0 (I# length) +{-# INLINE textFromJSVal #-} + +-- | returns the empty Text if not a string +lazyTextFromJSVal :: JSVal -> TL.Text +lazyTextFromJSVal = TL.fromStrict . textFromJSVal +{-# INLINE lazyTextFromJSVal #-} + +-- ---------------------------------------------------------------------------- + +foreign import javascript unsafe + "h$textToString" + js_toString :: ByteArray# -> Int# -> Int# -> JSString +foreign import javascript unsafe + "h$textFromString" + js_fromString :: JSString -> (# ByteArray#, Int# #) +foreign import javascript unsafe + "h$textFromString" + js_fromString' :: JSVal -> (# ByteArray#, Int# #) +foreign import javascript unsafe + "h$lazyTextToString" + js_lazyTextToString :: Any -> JSString diff --git a/src-wasm/GHCJS/Buffer.hs b/src-wasm/GHCJS/Buffer.hs new file mode 100644 index 0000000..79692c8 --- /dev/null +++ b/src-wasm/GHCJS/Buffer.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, + MagicHash, PolyKinds, BangPatterns + #-} +{-| + GHCJS implements the ByteArray# primitive with a JavaScript object + containing an ArrayBuffer and various TypedArray views. This module + contains utilities for manipulating and converting the buffer as + a JavaScript object. + + None of the properties of a Buffer object should be written to in foreign + code. Changing the contents of a MutableBuffer in foreign code is allowed. + -} + +-- fixme alignment not done yet! +module GHCJS.Buffer + ( Buffer + , MutableBuffer + , create + , createFromArrayBuffer + , thaw, freeze, clone + -- * JavaScript properties + , byteLength + , getArrayBuffer + , getUint8Array + , getUint16Array + , getInt32Array + , getDataView + , getFloat32Array + , getFloat64Array + -- * primitive + , toByteArray, fromByteArray + , toByteArrayPrim, fromByteArrayPrim + , toMutableByteArray, fromMutableByteArray + , toMutableByteArrayPrim, fromMutableByteArrayPrim + -- * bytestring + , toByteString, fromByteString + -- * pointers + , toPtr, unsafeToPtr + ) where + +import GHC.Exts (ByteArray#, MutableByteArray#, Addr#, Ptr(..), Any) + +import GHCJS.Buffer.Types +import GHC.Wasm.Prim +import GHCJS.Internal.Types + +import Data.Int +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Internal as BS +import Data.Primitive.ByteArray + +import qualified JavaScript.TypedArray.Internal.Types as I +import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer) +import JavaScript.TypedArray.DataView.Internal (SomeDataView) +import qualified JavaScript.TypedArray.Internal as I + +import GHC.ForeignPtr + +create :: Int -> IO MutableBuffer +create n | n >= 0 = js_create n + | otherwise = error "create: negative size" +{-# INLINE create #-} + +createFromArrayBuffer :: SomeArrayBuffer any -> SomeBuffer any +createFromArrayBuffer buf = js_wrapBuffer buf +{-# INLINE createFromArrayBuffer #-} + +getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any +getArrayBuffer buf = js_getArrayBuffer buf +{-# INLINE getArrayBuffer #-} + +getInt32Array :: SomeBuffer any -> I.SomeInt32Array any +getInt32Array buf = js_getInt32Array buf +{-# INLINE getInt32Array #-} + +getUint8Array :: SomeBuffer any -> I.SomeUint8Array any +getUint8Array buf = js_getUint8Array buf +{-# INLINE getUint8Array #-} + +getUint16Array :: SomeBuffer any -> I.SomeUint16Array any +getUint16Array buf = js_getUint16Array buf +{-# INLINE getUint16Array #-} + +getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any +getFloat32Array buf = js_getFloat32Array buf +{-# INLINE getFloat32Array #-} + +getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any +getFloat64Array buf = js_getFloat64Array buf +{-# INLINE getFloat64Array #-} + +getDataView :: SomeBuffer any -> SomeDataView any +getDataView buf = js_getDataView buf +{-# INLINE getDataView #-} + +freeze :: MutableBuffer -> IO Buffer +freeze x = js_clone x +{-# INLINE freeze #-} + +thaw :: Buffer -> IO MutableBuffer +thaw buf = js_clone buf +{-# INLINE thaw #-} + +clone :: MutableBuffer -> IO (SomeBuffer any2) +clone buf = js_clone buf +{-# INLINE clone #-} + +fromByteArray :: ByteArray -> Buffer +fromByteArray (ByteArray ba) = fromByteArrayPrim ba +{-# INLINE fromByteArray #-} + +toByteArray :: Buffer -> ByteArray +toByteArray buf = ByteArray (toByteArrayPrim buf) +{-# INLINE toByteArray #-} + +fromMutableByteArray :: MutableByteArray s -> Buffer +fromMutableByteArray (MutableByteArray mba) = fromMutableByteArrayPrim mba +{-# INLINE fromMutableByteArray #-} + +fromByteArrayPrim :: ByteArray# -> Buffer +fromByteArrayPrim ba = SomeBuffer (js_fromByteArray ba) +{-# INLINE fromByteArrayPrim #-} + +toByteArrayPrim :: Buffer -> ByteArray# +toByteArrayPrim buf = js_toByteArray buf +{-# INLINE toByteArrayPrim #-} + +fromMutableByteArrayPrim :: MutableByteArray# s -> Buffer +fromMutableByteArrayPrim mba = SomeBuffer (js_fromMutableByteArray mba) +{-# INLINE fromMutableByteArrayPrim #-} + +toMutableByteArray :: Buffer -> MutableByteArray s +toMutableByteArray buf = MutableByteArray (toMutableByteArrayPrim buf) +{-# INLINE toMutableByteArray #-} + +toMutableByteArrayPrim :: Buffer -> MutableByteArray# s +toMutableByteArrayPrim (SomeBuffer buf) = js_toMutableByteArray buf +{-# INLINE toMutableByteArrayPrim #-} + +-- | Convert a 'ByteString' into a triple of (buffer, offset, length) +-- Warning: if the 'ByteString''s internal 'ForeignPtr' has a +-- finalizer associated with it, the returned 'Buffer' will not count +-- as a reference for the purpose of determining when that finalizer +-- should run. +fromByteString :: ByteString -> (Buffer, Int, Int) +fromByteString (BS.BS fp len) = + -- not super happy with this. What if the bytestring's foreign ptr + -- has a nontrivial finalizer attached to it? I don't think there's + -- a way to do that without someone else messing with the PS constructor + -- directly though. + let !(Ptr addr) = unsafeForeignPtrToPtr fp + (ptr, off) = js_fromAddr addr + in (ptr, off, len) +{-# INLINE fromByteString #-} + +-- | Wrap a 'Buffer' into a 'ByteString' using the given offset +-- and length. +toByteString :: Int -> Maybe Int -> Buffer -> ByteString +toByteString off _ buf + | off < 0 = error "toByteString: negative offset" + | off > byteLength buf = error "toByteString: offset past end of buffer" +toByteString off (Just len) buf + | len < 0 = error "toByteString: negative length" + | len > byteLength buf - off = error "toByteString: length past end of buffer" + | otherwise = unsafeToByteString off len buf +toByteString off Nothing buf = unsafeToByteString off (byteLength buf - off) buf + +unsafeToByteString :: Int -> Int -> Buffer -> ByteString +unsafeToByteString off len buf@(SomeBuffer bufRef) = + let fp = ForeignPtr (js_toAddr buf) (PlainPtr (js_toMutableByteArray bufRef)) + in BS.PS fp off len + +toPtr :: MutableBuffer -> Ptr a +toPtr buf = Ptr (js_toAddr buf) +{-# INLINE toPtr #-} + +unsafeToPtr :: Buffer -> Ptr a +unsafeToPtr buf = Ptr (js_toAddr buf) +{-# INLINE unsafeToPtr #-} + +byteLength :: SomeBuffer any -> Int +byteLength buf = js_byteLength buf +{-# INLINE byteLength #-} + +-- ---------------------------------------------------------------------------- + +foreign import javascript unsafe + "h$newByteArray" js_create :: Int -> IO MutableBuffer +foreign import javascript unsafe + "h$wrapBuffer" js_wrapBuffer :: SomeArrayBuffer any -> SomeBuffer any +foreign import javascript unsafe + "((x) => { return h$wrapBuffer(x.buf.slice(x.u8.byteOffset, x.len)); })" + js_clone :: SomeBuffer any1 -> IO (SomeBuffer any2) +foreign import javascript unsafe + "((x) => { return x.len; })" js_byteLength :: SomeBuffer any -> Int +foreign import javascript unsafe + "((x) => { return x.buf; })" js_getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any +foreign import javascript unsafe + "((x) => { return x.i3; })" js_getInt32Array :: SomeBuffer any -> I.SomeInt32Array any +foreign import javascript unsafe + "((x) => { return x.u8; })" js_getUint8Array :: SomeBuffer any -> I.SomeUint8Array any +foreign import javascript unsafe + "((x) => { return x.u1; })" js_getUint16Array :: SomeBuffer any -> I.SomeUint16Array any +foreign import javascript unsafe + "((x) => { return x.f3; })" js_getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any +foreign import javascript unsafe + "((x) => { return x.f6; })" js_getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any +foreign import javascript unsafe + "((x) => { return x.dv; })" js_getDataView :: SomeBuffer any -> SomeDataView any + +-- ---------------------------------------------------------------------------- +-- these things have the same representation (modulo boxing), +-- conversion is free + +foreign import javascript unsafe + "((x) => { return x; })" js_toByteArray :: SomeBuffer any -> ByteArray# +foreign import javascript unsafe + "((x) => { return x; })" js_fromByteArray :: ByteArray# -> JSVal +foreign import javascript unsafe + "((x) => { return x; })" js_fromMutableByteArray :: MutableByteArray# s -> JSVal +foreign import javascript unsafe + "((x) => { return x; })" js_toMutableByteArray :: JSVal -> MutableByteArray# s +foreign import javascript unsafe + "h$toAddr" js_toAddr :: SomeBuffer any -> Addr# +foreign import javascript unsafe + "h$fromAddr" js_fromAddr :: Addr# -> (SomeBuffer any, Int) diff --git a/src-wasm/GHCJS/Buffer/Types.hs b/src-wasm/GHCJS/Buffer/Types.hs new file mode 100644 index 0000000..5fbe687 --- /dev/null +++ b/src-wasm/GHCJS/Buffer/Types.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-} + +module GHCJS.Buffer.Types where + +import GHCJS.Types +import GHCJS.Internal.Types + +newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal + +type Buffer = SomeBuffer Immutable +type MutableBuffer = SomeBuffer Mutable diff --git a/src-wasm/GHCJS/Concurrent.hs b/src-wasm/GHCJS/Concurrent.hs new file mode 100644 index 0000000..4981c20 --- /dev/null +++ b/src-wasm/GHCJS/Concurrent.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, + UnliftedFFITypes, DeriveDataTypeable, MagicHash + #-} + +{- | GHCJS has two types of threads. Regular, asynchronous threads are + started with `h$run`, are managed by the scheduler and run in the + background. `h$run` returns immediately. + + Synchronous threads are started with `h$runSync`, which returns + when the thread has run to completion. When a synchronous thread + does an operation that would block, like accessing an MVar or + an asynchronous FFI call, it cannot continue synchronously. + + There are two ways this can be resolved, depending on the + second argument of the `h$runSync` call: + + * The action is aborted and the thread receives a 'WouldBlockException' + * The thread continues asynchronously, `h$runSync` returns + + Note: when a synchronous thread encounters a black hole from + another thread, it tries to steal the work from that thread + to avoid blocking. In some cases that might not be possible, + for example when the data accessed is produced by a lazy IO + operation. This is resolved the same way as blocking on an IO + action would be. + -} + +module GHCJS.Concurrent ( --isThreadSynchronous + , --isThreadContinueAsync +-- , OnBlocked(..) +-- , WouldBlockException(..) +-- , withoutPreemption +-- , synchronously + ) where + +import GHC.Wasm.Prim +-- import GHC.JS.Foreign.Callback (OnBlocked(..)) + +import Control.Applicative +import Control.Concurrent +import qualified Control.Exception as Ex + +import GHC.Exts (ThreadId#) +import GHC.Conc.Sync (ThreadId(..)) + +import Data.Bits (testBit) +import Data.Data +import Data.Typeable + +import Unsafe.Coerce + +{- | + Run the action without the scheduler preempting the thread. When a blocking + action is encountered, the thread is still suspended and will continue + without preemption when it's woken up again. + + When the thread encounters a black hole from another thread, the scheduler + will attempt to clear it by temporarily switching to that thread. + -} + +-- withoutPreemption :: IO a -> IO a +-- withoutPreemption x = Ex.mask $ \restore -> do +-- oldS <- js_setNoPreemption True +-- if oldS +-- then restore x +-- else restore x `Ex.finally` js_setNoPreemption False +-- {-# INLINE withoutPreemption #-} + + +{- | + Run the action synchronously, which means that the thread will not + be preempted by the scheduler. If the thread encounters a blocking + operation, the runtime throws a WouldBlock exception. + + When the thread encounters a black hole from another thread, the scheduler + will attempt to clear it by temporarily switching to that thread. + -} +-- synchronously :: IO a -> IO a +-- synchronously x = Ex.mask $ \restore -> do +-- oldS <- js_setSynchronous True +-- if oldS +-- then restore x +-- else restore x `Ex.finally` js_setSynchronous False +-- {-# INLINE synchronously #-} + +{- | Returns whether the 'ThreadId' is a synchronous thread + -} +-- isThreadSynchronous :: ThreadId -> IO Bool +-- isThreadSynchronous = fmap (`testBit` 0) . syncThreadState + +{- | + Returns whether the 'ThreadId' will continue running async. Always + returns 'True' when the thread is not synchronous. + -} +-- isThreadContinueAsync :: ThreadId -> IO Bool +-- isThreadContinueAsync = fmap (`testBit` 1) . syncThreadState + +{- | + Returns whether the 'ThreadId' is not preemptible. Always + returns 'True' when the thread is synchronous. + -} +-- isThreadNonPreemptible :: ThreadId -> IO Bool +-- isThreadNonPreemptible = fmap (`testBit` 2) . syncThreadState + +-- syncThreadState :: ThreadId-> IO Int +-- syncThreadState (ThreadId tid) = js_syncThreadState tid + +-- ---------------------------------------------------------------------------- + +-- foreign import javascript unsafe "h$syncThreadState" +-- js_syncThreadState :: ThreadId# -> IO Int + +-- foreign import javascript unsafe +-- "((x) => { var r = h$currentThread.noPreemption; h$currentThread.noPreemption = x; return r; })" +-- js_setNoPreemption :: Bool -> IO Bool; + +-- foreign import javascript unsafe +-- "((x) => { var r = h$currentThread.isSynchronous; h$currentThread.isSynchronous = x; return r; })" +-- js_setSynchronous :: Bool -> IO Bool diff --git a/src-wasm/GHCJS/Foreign.hs b/src-wasm/GHCJS/Foreign.hs new file mode 100644 index 0000000..5bbc5c5 --- /dev/null +++ b/src-wasm/GHCJS/Foreign.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{- | Basic interop between Haskell and JavaScript. + + The principal type here is 'JSVal', which is a lifted type that contains + a JavaScript reference. The 'JSVal' type is parameterized with one phantom + type, and GHCJS.Types defines several type synonyms for specific variants. + + The code in this module makes no assumptions about 'JSVal a' types. + Operations that can result in a JS exception that can kill a Haskell thread + are marked unsafe (for example if the 'JSVal' contains a null or undefined + value). There are safe variants where the JS exception is propagated as + a Haskell exception, so that it can be handled on the Haskell side. + + For more specific types, like 'JSArray' or 'JSBool', the code assumes that + the contents of the 'JSVal' actually is a JavaScript array or bool value. + If it contains an unexpected value, the code can result in exceptions that + kill the Haskell thread, even for functions not marked unsafe. + + The code makes use of `foreign import javascript', enabled with the + `JavaScriptFFI` extension, available since GHC 7.8. There are three different + safety levels: + + * unsafe: The imported code is run directly. returning an incorrectly typed + value leads to undefined behaviour. JavaScript exceptions in the foreign + code kill the Haskell thread. + * safe: Returned values are replaced with a default value if they have + the wrong type. JavaScript exceptions are caught and propagated as + Haskell exceptions ('JSException'), so they can be handled with the + standard "Control.Exception" machinery. + * interruptible: The import is asynchronous. The calling Haskell thread + sleeps until the foreign code calls the `$c` JavaScript function with + the result. The thread is in interruptible state while blocked, so it + can receive asynchronous exceptions. + + Unlike the FFI for native code, it's safe to call back into Haskell + (`h$run`, `h$runSync`) from foreign code in any of the safety levels. + Since JavaScript is single threaded, no Haskell threads can run while + the foreign code is running. + -} + +module GHCJS.Foreign ( jsTrue + , jsFalse + , jsNull + , toJSBool + , fromJSBool + , jsUndefined + , isTruthy + , isNull + , isUndefined + , isObject + , isFunction + , isString + , isBoolean + , isSymbol + , isNumber +{- + , toArray + , newArray + , fromArray + , pushArray + , indexArray + , lengthArray + , newObj + , getProp, unsafeGetProp + , getPropMaybe, unsafeGetPropMaybe + , setProp, unsafeSetProp + , listProps -} + , jsTypeOf, JSType(..) + , jsonTypeOf, JSONType(..) +{- , wrapBuffer, wrapMutableBuffer + , byteArrayJSVal, mutableByteArrayJSVal + , bufferByteString, byteArrayByteString + , unsafeMutableByteArrayByteString -} + ) where + +import GHCJS.Types +import GHCJS.Foreign.Internal +{- +import GHCJS.Marshal +import GHCJS.Marshal.Pure +-} +import Data.String (IsString(..)) +import qualified Data.Text as T + + +class ToJSString a where + toJSString :: a -> JSString + +-- toJSString = ptoJSVal + + +class FromJSString a where + fromJSString :: JSString -> a + +-- default PFromJSVal +-- fromJSString = pfromJSVal +-- {-# INLINE fromJSString #-} +{- +instance ToJSString [Char] +instance FromJSString [Char] +instance ToJSString T.Text +instance FromJSString T.Text +instance ToJSString JSString +instance FromJSString JSString +-} +-- instance IsString JSString where +-- fromString = toJSString +-- {-# INLINE fromString #-} +-- - +{- +{- | Read a property from a JS object. Throws a 'JSException' if + o is not a JS object or the property cannot be accessed + -} +getProp :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the object + -> IO (JSVal c) -- ^ the property value +getProp p o = js_getProp (toJSString p) o +{-# INLINE getProp #-} + +{- | Read a property from a JS object. Kills the Haskell thread + if o is not a JS object or the property cannot be accessed + -} +unsafeGetProp :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the object + -> IO (JSVal c) -- ^ the property value, Nothing if the object doesn't have a property with the given name +unsafeGetProp p o = js_unsafeGetProp (toJSString p) o +{-# INLINE unsafeGetProp #-} + +{- | Read a property from a JS object. Throws a JSException if + o is not a JS object or the property cannot be accessed + -} +getPropMaybe :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the object + -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name +getPropMaybe p o = do + p' <- js_getProp (toJSString p) o + if isUndefined p' then return Nothing else return (Just p') +{-# INLINE getPropMaybe #-} + +{- | Read a property from a JS object. Kills the Haskell thread + if o is not a JS object or the property cannot be accessed + -} +unsafeGetPropMaybe :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the object + -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name +unsafeGetPropMaybe p o = do + p' <- js_unsafeGetProp (toJSString p) o + if isUndefined p' then return Nothing else return (Just p') +{-# INLINE unsafeGetPropMaybe #-} + +{- | set a property in a JS object. Throws a 'JSException' if + o is not a reference to a JS object or the property cannot + be set + -} +setProp :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the value + -> JSVal c -- ^ the object + -> IO () +setProp p v o = js_setProp (toJSString p) v o +{-# INLINE setProp #-} + +{- | set a property in a JS object. Kills the Haskell thread + if the property cannot be set. +-} +unsafeSetProp :: ToJSString a => a -- ^ the property name + -> JSVal b -- ^ the value + -> JSVal c -- ^ the object + -> IO () +unsafeSetProp p v o = js_unsafeSetProp (toJSString p) v o + +-} diff --git a/src-wasm/GHCJS/Foreign/Internal.hs b/src-wasm/GHCJS/Foreign/Internal.hs new file mode 100644 index 0000000..ad04aee --- /dev/null +++ b/src-wasm/GHCJS/Foreign/Internal.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI, + UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim, + MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-} + +{- | Basic interop between Haskell and JavaScript. + + The principal type here is 'JSVal', which is a lifted type that contains + a JavaScript reference. The 'JSVal' type is parameterized with one phantom + type, and GHCJS.Types defines several type synonyms for specific variants. + + The code in this module makes no assumptions about 'JSVal a' types. + Operations that can result in a JS exception that can kill a Haskell thread + are marked unsafe (for example if the 'JSVal' contains a null or undefined + value). There are safe variants where the JS exception is propagated as + a Haskell exception, so that it can be handled on the Haskell side. + + For more specific types, like 'JSArray' or 'JSBool', the code assumes that + the contents of the 'JSVal' actually is a JavaScript array or bool value. + If it contains an unexpected value, the code can result in exceptions that + kill the Haskell thread, even for functions not marked unsafe. + + The code makes use of `foreign import javascript', enabled with the + `JavaScriptFFI` extension, available since GHC 7.8. There are three different + safety levels: + + * unsafe: The imported code is run directly. returning an incorrectly typed + value leads to undefined behaviour. JavaScript exceptions in the foreign + code kill the Haskell thread. + * safe: Returned values are replaced with a default value if they have + the wrong type. JavaScript exceptions are caught and propagated as + Haskell exceptions ('JSException'), so they can be handled with the + standard "Control.Exception" machinery. + * interruptible: The import is asynchronous. The calling Haskell thread + sleeps until the foreign code calls the `$c` JavaScript function with + the result. The thread is in interruptible state while blocked, so it + can receive asynchronous exceptions. + + Unlike the FFI for native code, it's safe to call back into Haskell + (`h$run`, `h$runSync`) from foreign code in any of the safety levels. + Since JavaScript is single threaded, no Haskell threads can run while + the foreign code is running. + -} + +module GHCJS.Foreign.Internal ( JSType(..) + , jsTypeOf + , JSONType(..) + , jsonTypeOf + -- , mvarRef + , isTruthy + , fromJSBool + -- , toJSBool + -- , jsTrue + -- , jsFalse + -- , jsNull + -- , jsUndefined + -- , isNull + -- type predicates + -- , isUndefined + , isNumber + , isObject + , isBoolean + , isString + , isSymbol + , isFunction + -- internal use, fixme remove +{- , toArray + , newArray + , fromArray + , pushArray + , indexArray + , lengthArray -} +-- , newObj +-- , js_getProp, js_unsafeGetProp +-- , js_setProp, js_unsafeSetProp +-- , listProps +{- , wrapBuffer, wrapMutableBuffer + , byteArrayJSVal, mutableByteArrayJSVal + , bufferByteString, byteArrayByteString + , unsafeMutableByteArrayByteString -} + ) where + +import GHCJS.Types +import qualified GHC.Wasm.Prim as Prim + +import GHC.Prim +import GHC.Exts + +import Control.Applicative +import Control.Concurrent.MVar +import Control.DeepSeq (force) +import Control.Exception (evaluate, Exception) + +import Foreign.ForeignPtr +import Foreign.Ptr + +import Data.Primitive.ByteArray +import Data.Typeable (Typeable) + +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafePackAddressLen) + +import qualified Data.Text.Array as A +import qualified Data.Text as T +import qualified Data.Text.Internal as T +import qualified Data.Text.Lazy as TL (Text, toStrict, fromStrict) + +import Unsafe.Coerce + +-- types returned by JS typeof operator +data JSType = Undefined + | Object + | Boolean + | Number + | String + | Symbol + | Function + | Other -- ^ implementation dependent + deriving (Show, Eq, Ord, Enum, Typeable) + +-- JSON value type +data JSONType = JSONNull + | JSONInteger + | JSONFloat + | JSONBool + | JSONString + | JSONArray + | JSONObject + deriving (Show, Eq, Ord, Enum, Typeable) + +fromJSBool :: JSVal -> Bool +fromJSBool b = js_fromBool b +{-# INLINE fromJSBool #-} + +-- toJSBool :: Bool -> JSVal +-- toJSBool True = jsTrue +-- toJSBool _ = jsFalse +-- {-# INLINE toJSBool #-} + +-- jsTrue :: JSVal +-- jsTrue = mkRef (js_true 0#) +-- {-# INLINE jsTrue #-} + +-- jsFalse :: JSVal +-- jsFalse = mkRef (js_false 0#) +-- {-# INLINE jsFalse #-} + +-- jsNull :: JSVal +-- jsNull = mkRef (js_null 0#) +-- {-# INLINE jsNull #-} + +-- jsUndefined :: JSVal +-- jsUndefined = mkRef (js_undefined 0#) +-- {-# INLINE jsUndefined #-} + +-- check whether a reference is `truthy' in the JavaScript sense +isTruthy :: JSVal -> Bool +isTruthy b = js_isTruthy b +{-# INLINE isTruthy #-} + +-- isUndefined :: JSVal -> Bool +-- isUndefined o = js_isUndefined o +-- {-# INLINE isUndefined #-} + +-- isNull :: JSVal -> Bool +-- isNull o = js_isNull o +-- {-# INLINE isNull #-} + +isObject :: JSVal -> Bool +isObject o = js_isObject o +{-# INLINE isObject #-} + +isNumber :: JSVal -> Bool +isNumber o = js_isNumber o +{-# INLINE isNumber #-} + +isString :: JSVal -> Bool +isString o = js_isString o +{-# INLINE isString #-} + +isBoolean :: JSVal -> Bool +isBoolean o = js_isBoolean o +{-# INLINE isBoolean #-} + +isFunction :: JSVal -> Bool +isFunction o = js_isFunction o +{-# INLINE isFunction #-} + +isSymbol :: JSVal -> Bool +isSymbol o = js_isSymbol o +{-# INLINE isSymbol #-} + + +{- +-- something that we can unsafeCoerce Text from +data Text' = Text' + {-# UNPACK #-} !Array' -- payload + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + +data Array' = Array' { + aBA :: ByteArray# + } + +data Text'' = Text'' + {-# UNPACK #-} !Array'' -- payload + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + +data Array'' = Array'' { + aRef :: Ref# + } + +-- same rep as Ptr Addr#, use this to get just the first field out +data Ptr' a = Ptr' ByteArray# Int# + +ptrToPtr' :: Ptr a -> Ptr' b +ptrToPtr' = unsafeCoerce + +ptr'ToPtr :: Ptr' a -> Ptr b +ptr'ToPtr = unsafeCoerce +-} +{- +toArray :: [JSVal a] -> IO (JSArray a) +toArray xs = Prim.toJSArray xs +{-# INLINE toArray #-} + +pushArray :: JSVal a -> JSArray a -> IO () +pushArray r arr = js_push r arr +{-# INLINE pushArray #-} + +fromArray :: JSArray (JSVal a) -> IO [JSVal a] +fromArray a = Prim.fromJSArray a +{-# INLINE fromArray #-} + +lengthArray :: JSArray a -> IO Int +lengthArray a = js_length a +{-# INLINE lengthArray #-} + +indexArray :: Int -> JSArray a -> IO (JSVal a) +indexArray = js_index +{-# INLINE indexArray #-} + +unsafeIndexArray :: Int -> JSArray a -> IO (JSVal a) +unsafeIndexArray = js_unsafeIndex +{-# INLINE unsafeIndexArray #-} + +newArray :: IO (JSArray a) +newArray = js_emptyArray +{-# INLINE newArray #-} + +newObj :: IO (JSVal a) +newObj = js_emptyObj +{-# INLINE newObj #-} + +listProps :: JSVal a -> IO [JSString] +listProps o = fmap unsafeCoerce . Prim.fromJSArray =<< js_listProps o +{-# INLINE listProps #-} +-} +jsTypeOf :: JSVal -> JSType +jsTypeOf r = tagToEnum# (js_jsTypeOf r) +{-# INLINE jsTypeOf #-} + +jsonTypeOf :: JSVal -> JSONType +jsonTypeOf r = tagToEnum# (js_jsonTypeOf r) +{-# INLINE jsonTypeOf #-} + +{- +{- | Convert a JavaScript ArrayBuffer to a 'ByteArray' without copying. Throws + a 'JSException' if the 'JSVal' is not an ArrayBuffer. + -} +wrapBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8, + -- not all types can be read from the ByteArray# + -> Int -- ^ length in bytes (use zero or a negative number to use the whole ArrayBuffer) + -> JSVal a -- ^ JavaScript ArrayBuffer object + -> IO ByteArray -- ^ result +wrapBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf +{-# INLINE wrapBuffer #-} + +{- | Convert a JavaScript ArrayBuffer to a 'MutableByteArray' without copying. Throws + a 'JSException' if the 'JSVal' is not an ArrayBuffer. + -} +wrapMutableBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8, + -- not all types can be read from / written to the ByteArray# + -> Int -- ^ the length in bytes (use zero or a negative number to use the whole ArrayBuffer) + -> JSVal a -- ^ JavaScript ArrayBuffer object + -> IO (MutableByteArray s) +wrapMutableBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf +{-# INLINE wrapMutableBuffer #-} + +{- | Get the underlying JS object from a 'ByteArray#'. The object o + contains an ArrayBuffer (o.buf) and several typed array views on it (which + can have an offset from the start of the buffer and/or a reduced length): + * o.i3 : 32 bit signed + * o.u8 : 8 bit unsigned + * o.u1 : 16 bit unsigned + * o.f3 : 32 bit single precision float + * o.f6 : 64 bit double precision float + * o.dv : a DataView + Some of the views will be null if the offset is not a multiple of 8. + -} +byteArrayJSVal :: ByteArray# -> JSVal a +byteArrayJSVal a = unsafeCoerce (ByteArray a) +{-# INLINE byteArrayJSVal #-} + +{- | Get the underlying JS object from a 'MutableByteArray#'. The object o + contains an ArrayBuffer (o.buf) and several typed array views on it (which + can have an offset from the start of the buffer and/or a reduced length): + * o.i3 : 32 bit signed + * o.u8 : 8 bit unsigned + * o.u1 : 16 bit unsigned + * o.f3 : 32 bit single precision float + * o.f6 : 64 bit double precision float + * o.dv : a DataView + Some of the views will be null if the offset is not a multiple of 8. + -} +mutableByteArrayJSVal :: MutableByteArray# s -> JSVal a +mutableByteArrayJSVal a = unsafeCoerce (MutableByteArray a) +{-# INLINE mutableByteArrayJSVal #-} + +foreign import javascript safe "((x,y,z) => { return h$wrapBuffer(z, true, x, y); })" + js_wrapBuffer :: Int -> Int -> JSVal a -> IO (JSVal ()) + +{- | Convert an ArrayBuffer to a strict 'ByteString' + this wraps the original buffer, without copying. + Use 'byteArrayByteString' if you already have a wrapped buffer + -} +bufferByteString :: Int -- ^ offset from the start in bytes + -> Int -- ^ length in bytes (use zero or a negative number to get the whole ArrayBuffer) + -> JSVal a + -> IO ByteString +bufferByteString offset length buf = do + (ByteArray ba) <- wrapBuffer offset length buf + byteArrayByteString ba + +{- | Pack a ByteArray# primitive into a ByteString + without copying the buffer. + + This is unsafe in native code + -} +byteArrayByteString :: ByteArray# + -> IO ByteString +byteArrayByteString arr = +#ifdef ghcjs_HOST_OS + let ba = ByteArray arr + !(Addr a) = byteArrayContents ba + in unsafePackAddressLen (sizeofByteArray ba) a +#else + error "GHCJS.Foreign.byteArrayToByteString: not JS" +#endif + +{- | Pack a MutableByteArray# primitive into a 'ByteString' without + copying. The byte array shouldn't be modified after converting. + + This is unsafe in native code + -} +unsafeMutableByteArrayByteString :: MutableByteArray# s + -> IO ByteString +unsafeMutableByteArrayByteString arr = +#ifdef ghcjs_HOST_OS + let ba = MutableByteArray arr + !(Addr a) = mutableByteArrayContents ba + in unsafePackAddressLen (sizeofMutableByteArray ba) a +#else + error "GHCJS.Foreign.unsafeMutableByteArrayToByteString: no JS" +#endif +-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe + "((x) => { return x===true; })" + js_fromBool :: JSVal -> Bool +foreign import javascript unsafe + "((x) => { return x ? true : false; })" + js_isTruthy :: JSVal -> Bool +-- foreign import javascript unsafe "((x) => { return true; })" js_true :: Int# -> Ref# +-- foreign import javascript unsafe "((x) => { return false; })" js_false :: Int# -> Ref# +-- foreign import javascript unsafe "((x) => { return null; })" js_null :: Int# -> Ref# +-- foreign import javascript unsafe "((x) => { return undefined; })" js_undefined :: Int# -> Ref# +-- foreign import javascript unsafe "$r = [];" js_emptyArray :: IO (JSArray a) +-- foreign import javascript unsafe "$r = {};" js_emptyObj :: IO (JSVal a) +--foreign import javascript unsafe "$3[$1] = $2;" +-- js_unsafeWriteArray :: Int# -> JSVal a -> JSArray b -> IO () +-- foreign import javascript unsafe "h$fromArray" +-- js_fromArray :: JSArray a -> IO Ref# -- [a] +--foreign import javascript safe "$2.push($1)" +-- js_push :: JSVal a -> JSArray a -> IO () +--foreign import javascript safe "$1.length" js_length :: JSArray a -> IO Int +--foreign import javascript safe "$2[$1]" +-- js_index :: Int -> JSArray a -> IO (JSVal a) +--foreign import javascript unsafe "$2[$1]" +-- js_unsafeIndex :: Int -> JSArray a -> IO (JSVal a) +foreign import javascript unsafe "((x,y) => { return y[x]; })" + js_unsafeGetProp :: JSString -> JSVal -> IO JSVal +foreign import javascript unsafe "((x,y,z) => { return z[x] = y; })" + js_unsafeSetProp :: JSString -> JSVal -> JSVal -> IO () +{- +foreign import javascript safe "h$listProps($1)" + js_listProps :: JSVal a -> IO (JSArray JSString) +-} +foreign import javascript unsafe "h$jsTypeOf" + js_jsTypeOf :: JSVal -> Int# +foreign import javascript unsafe "h$jsonTypeOf" + js_jsonTypeOf :: JSVal -> Int# +-- foreign import javascript unsafe "h$listToArray" +-- js_toArray :: Any -> IO (JSArray a) +-- foreign import javascript unsafe "$1 === null" +-- js_isNull :: JSVal a -> Bool + +-- foreign import javascript unsafe "h$isUndefined" js_isUndefined :: JSVal a -> Bool +foreign import javascript unsafe "h$isObject" js_isObject :: JSVal -> Bool +foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSVal -> Bool +foreign import javascript unsafe "h$isNumber" js_isNumber :: JSVal -> Bool +foreign import javascript unsafe "h$isString" js_isString :: JSVal -> Bool +foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSVal -> Bool +foreign import javascript unsafe "h$isFunction" js_isFunction :: JSVal -> Bool diff --git a/src-wasm/GHCJS/Internal/Types.hs b/src-wasm/GHCJS/Internal/Types.hs new file mode 100644 index 0000000..00174e8 --- /dev/null +++ b/src-wasm/GHCJS/Internal/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHCJS.Internal.Types where + +import Data.Coerce +import Unsafe.Coerce + +import Control.DeepSeq + +import GHC.Wasm.Prim (JSVal) +-- import GHC.JS.Foreign.Callback (Callback) + +instance NFData JSVal where + rnf x = x `seq` () + +class IsJSVal a where + jsval_ :: a -> JSVal + + default jsval_ :: Coercible a JSVal => a -> JSVal + jsval_ = coerce + {-# INLINE jsval_ #-} + +-- instance IsJSVal (Callback a) where +-- jsval_ = unsafeCoerce + +jsval :: IsJSVal a => a -> JSVal +jsval = jsval_ +{-# INLINE jsval #-} + +data MutabilityType s = Mutable_ s + | Immutable_ s + | STMutable s + +type Mutable = Mutable_ () +type Immutable = Immutable_ () + +data IsItMutable = IsImmutable + | IsMutable + +type family Mutability (a :: MutabilityType s) :: IsItMutable where + Mutability Immutable = IsImmutable + Mutability Mutable = IsMutable + Mutability (STMutable s) = IsMutable + + diff --git a/src-wasm/GHCJS/Marshal.hs b/src-wasm/GHCJS/Marshal.hs new file mode 100644 index 0000000..c850d60 --- /dev/null +++ b/src-wasm/GHCJS/Marshal.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DefaultSignatures, + TypeOperators, + ScopedTypeVariables, + DefaultSignatures, + FlexibleContexts, + FlexibleInstances, + OverloadedStrings, + TupleSections, + MagicHash, + CPP, + JavaScriptFFI, + ForeignFunctionInterface, + UnliftedFFITypes, + BangPatterns + #-} + +module GHCJS.Marshal ( FromJSVal(..) + , ToJSVal(..) + , toJSVal_aeson + , toJSVal_pure + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) + +import qualified Data.Aeson as AE +import Data.Bits ((.&.)) +import Data.Char (chr, ord) +#if MIN_VERSION_aeson (2,0,0) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +#else +import qualified Data.HashMap.Strict as H +#endif +import Data.Int (Int8, Int16, Int32) +import qualified Data.JSString as JSS +import qualified Data.JSString.Text as JSS +import Data.Maybe +import Data.Scientific (Scientific, scientific, fromFloatDigits) +import Data.Text (Text) +import qualified Data.Vector as V +import Data.Word (Word8, Word16, Word32, Word) +import Data.Primitive.ByteArray + +import Unsafe.Coerce (unsafeCoerce) + +import GHC.Int +import GHC.Word +import GHC.Types +import GHC.Float +import GHC.Prim +import GHC.Generics + +import GHCJS.Types +import GHCJS.Foreign.Internal +import GHCJS.Marshal.Pure + + +import qualified JavaScript.Array as A +import qualified JavaScript.Array.Internal as AI +import qualified JavaScript.Object as O +import qualified JavaScript.Object.Internal as OI + +import GHCJS.Marshal.Internal + +instance FromJSVal JSVal where + fromJSValUnchecked x = return x + {-# INLINE fromJSValUnchecked #-} + fromJSVal = return . Just + {-# INLINE fromJSVal #-} +instance FromJSVal () where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure +-- {-# INLINE fromJSVal #-} +instance FromJSVal a => FromJSVal [a] where + fromJSVal = fromJSValListOf + {-# INLINE fromJSVal #-} +instance FromJSVal a => FromJSVal (Maybe a) where + fromJSValUnchecked x | isUndefined x || isNull x = return Nothing + | otherwise = fromJSVal x + {-# INLINE fromJSValUnchecked #-} + fromJSVal x | isUndefined x || isNull x = return (Just Nothing) + | otherwise = fmap (fmap Just) fromJSVal x + {-# INLINE fromJSVal #-} +instance FromJSVal JSString where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Text where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Char where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} + fromJSValUncheckedListOf = fromJSValUnchecked_pure + {-# INLINE fromJSValListOf #-} + fromJSValListOf = fromJSVal_pure + {-# INLINE fromJSValUncheckedListOf #-} +instance FromJSVal Bool where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int8 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int16 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int32 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word8 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word16 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word32 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Float where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Double where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal AE.Value where + fromJSVal r = case jsonTypeOf r of + JSONNull -> return (Just AE.Null) + JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer)) + <$> fromJSVal r + JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific)) + <$> fromJSVal r + JSONBool -> liftM AE.Bool <$> fromJSVal r + JSONString -> liftM AE.String <$> fromJSVal r + JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSVal r + JSONObject -> do + props <- OI.listProps (OI.Object r) + runMaybeT $ do + propVals <- forM props $ \p -> do + v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r)) + return (JSS.textFromJSString p, v) +#if MIN_VERSION_aeson (2,0,0) + return (AE.Object (KM.fromList (map (\(k, v) -> (K.fromText k, v)) propVals))) +#else + return (AE.Object (H.fromList propVals)) +#endif + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where + fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a,b,c) where + fromJSVal r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d) => FromJSVal (a,b,c,d) where + fromJSVal r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e) => FromJSVal (a,b,c,d,e) where + fromJSVal r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f) => FromJSVal (a,b,c,d,e,f) where + fromJSVal r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g) => FromJSVal (a,b,c,d,e,f,g) where + fromJSVal r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g, FromJSVal h) => FromJSVal (a,b,c,d,e,f,g,h) where + fromJSVal r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7 + {-# INLINE fromJSVal #-} + +jf :: FromJSVal a => JSVal -> Int -> MaybeT IO a +jf r n = MaybeT $ do + r' <- AI.read n (AI.SomeJSArray r) + if isUndefined r + then return Nothing + else fromJSVal r' + +instance ToJSVal JSVal where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal AE.Value where + toJSVal = toJSVal_aeson + {-# INLINE toJSVal #-} +instance ToJSVal JSString where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Text where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Char where + toJSVal = return . pToJSVal + {-# INLINE toJSVal #-} + toJSValListOf = return . pToJSVal + {-# INLINE toJSValListOf #-} +instance ToJSVal Bool where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int8 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int16 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int32 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word8 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word16 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word32 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Float where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Double where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal a => ToJSVal [a] where + toJSVal = toJSValListOf + {-# INLINE toJSVal #-} +instance ToJSVal a => ToJSVal (Maybe a) where + toJSVal Nothing = return jsNull + toJSVal (Just a) = toJSVal a + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b) => ToJSVal (a,b) where + toJSVal (a,b) = join $ arr2 <$> toJSVal a <*> toJSVal b + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a,b,c) where + toJSVal (a,b,c) = join $ arr3 <$> toJSVal a <*> toJSVal b <*> toJSVal c + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d) => ToJSVal (a,b,c,d) where + toJSVal (a,b,c,d) = join $ arr4 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e) => ToJSVal (a,b,c,d,e) where + toJSVal (a,b,c,d,e) = join $ arr5 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f) => ToJSVal (a,b,c,d,e,f) where + toJSVal (a,b,c,d,e,f) = join $ arr6 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f, ToJSVal g) => ToJSVal (a,b,c,d,e,f,g) where + toJSVal (a,b,c,d,e,f,g) = join $ arr7 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f <*> toJSVal g + {-# INLINE toJSVal #-} + +foreign import javascript unsafe "(($1) => { return [$1]; })" + arr1 :: JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2) => { return [$1,$2]; })" + arr2 :: JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3) => { return [$1,$2,$3]; })" + arr3 :: JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4) => { return [$1,$2,$3,$4]; })" + arr4 :: JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { return [$1,$2,$3,$4,$5]; })" + arr5 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6) => { return [$1,$2,$3,$4,$5,$6]; })" + arr6 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { return [$1,$2,$3,$4,$5,$6,$7]; })" + arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal + +toJSVal_aeson :: AE.ToJSON a => a -> IO JSVal +toJSVal_aeson x = cv (AE.toJSON x) + where + cv = convertValue + + convertValue :: AE.Value -> IO JSVal + convertValue AE.Null = return jsNull + convertValue (AE.String t) = return (pToJSVal t) + convertValue (AE.Array a) = (\(AI.SomeJSArray x) -> x) <$> + (AI.fromListIO =<< mapM convertValue (V.toList a)) + convertValue (AE.Number n) = toJSVal (realToFrac n :: Double) + convertValue (AE.Bool b) = return (toJSBool b) + convertValue (AE.Object o) = do + obj@(OI.Object obj') <- OI.create + mapM_ (\(k,v) -> convertValue v >>= \v' -> OI.setProp (JSS.textToJSString k) v' obj) +#if MIN_VERSION_aeson (2,0,0) + (map (\(k, v) -> (K.toText k, v)) (KM.toList o)) +#else + (H.toList o) +#endif + return obj' + + diff --git a/src-wasm/GHCJS/Marshal/Internal.hs b/src-wasm/GHCJS/Marshal/Internal.hs new file mode 100644 index 0000000..6f7b64d --- /dev/null +++ b/src-wasm/GHCJS/Marshal/Internal.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures, + TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances + #-} + +module GHCJS.Marshal.Internal ( FromJSVal(..) + , ToJSVal(..) + , PToJSVal(..) + , PFromJSVal(..) + , Purity(..) + , toJSVal_generic + , fromJSVal_generic + , toJSVal_pure + , fromJSVal_pure + , fromJSValUnchecked_pure + ) where + +import Control.Applicative +import Control.Monad + +import Data.Data +import Data.Maybe +import Data.Typeable + +import GHC.Generics + +import qualified GHC.Wasm.Prim as Prim +import qualified GHCJS.Foreign as F +import GHCJS.Types + +import qualified Data.JSString.Internal.Type as JSS + +import JavaScript.Array (MutableJSArray) +import qualified JavaScript.Array.Internal as AI +import JavaScript.Object (Object) +import qualified JavaScript.Object.Internal as OI + +data Purity = PureShared -- ^ conversion is pure even if the original value is shared + | PureExclusive -- ^ conversion is pure if the we only convert once + deriving (Eq, Ord, Typeable, Data) + +class PToJSVal a where +-- type PureOut a :: Purity + pToJSVal :: a -> JSVal + +class PFromJSVal a where +-- type PureIn a :: Purity + pFromJSVal :: JSVal -> a + +class ToJSVal a where + toJSVal :: a -> IO JSVal + + toJSValListOf :: [a] -> IO JSVal + toJSValListOf = Prim.toJSArray <=< mapM toJSVal + + -- default toJSVal :: PToJSVal a => a -> IO (JSVal a) + -- toJSVal x = return (pToJSVal x) + + default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> IO JSVal + toJSVal = toJSVal_generic id + +class FromJSVal a where + fromJSVal :: JSVal -> IO (Maybe a) + + fromJSValUnchecked :: JSVal -> IO a + fromJSValUnchecked = fmap fromJust . fromJSVal + {-# INLINE fromJSValUnchecked #-} + + fromJSValListOf :: JSVal -> IO (Maybe [a]) + fromJSValListOf = fmap sequence . (mapM fromJSVal <=< Prim.fromJSArray) -- fixme should check that it's an array + + fromJSValUncheckedListOf :: JSVal -> IO [a] + fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< Prim.fromJSArray + + -- default fromJSVal :: PFromJSVal a => JSVal a -> IO (Maybe a) + -- fromJSVal x = return (Just (pFromJSVal x)) + + default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> IO (Maybe a) + fromJSVal = fromJSVal_generic id + + -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a + -- fromJSValUnchecked x = return (pFromJSVal x) + +-- ----------------------------------------------------------------------------- + +class GToJSVal a where + gToJSVal :: (String -> String) -> Bool -> a -> IO JSVal + +class GToJSProp a where + gToJSProp :: (String -> String) -> JSVal -> a -> IO () + +class GToJSArr a where + gToJSArr :: (String -> String) -> MutableJSArray -> a -> IO () + +instance (ToJSVal b) => GToJSVal (K1 a b c) where + gToJSVal _ _ (K1 x) = toJSVal x + +instance GToJSVal p => GToJSVal (Par1 p) where + gToJSVal f b (Par1 p) = gToJSVal f b p + +instance GToJSVal (f p) => GToJSVal (Rec1 f p) where + gToJSVal f b (Rec1 x) = gToJSVal f b x + +instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where + gToJSVal f _ (L1 x) = gToJSVal f True x + gToJSVal f _ (R1 x) = gToJSVal f True x + +instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where + gToJSVal f b m@(M1 x) = gToJSVal f b x + +instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where + gToJSVal f True m@(M1 x) = do + obj@(OI.Object obj') <- OI.create + v <- gToJSVal f (conIsRecord m) x + OI.setProp (packJSS . f $ conName m) v obj + return obj' + gToJSVal f _ m@(M1 x) = gToJSVal f (conIsRecord m) x + +instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSVal ((a :*: b) p) where + gToJSVal f True xy = do + (OI.Object obj') <- OI.create + gToJSProp f obj' xy + return obj' + gToJSVal f False xy = do + arr@(AI.SomeJSArray arr') <- AI.create + gToJSArr f arr xy + return arr' + +instance GToJSVal (a p) => GToJSVal (M1 S c a p) where + gToJSVal f b (M1 x) = gToJSVal f b x + +instance (GToJSProp (a p), GToJSProp (b p)) => GToJSProp ((a :*: b) p) where + gToJSProp f o (x :*: y) = gToJSProp f o x >> gToJSProp f o y + +instance (Selector c, GToJSVal (a p)) => GToJSProp (M1 S c a p) where + gToJSProp f o m@(M1 x) = do + r <- gToJSVal f False x + OI.setProp (packJSS . f $ selName m) r (OI.Object o) + +instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where + gToJSArr f a (x :*: y) = gToJSArr f a x >> gToJSArr f a y + +instance GToJSVal (a p) => GToJSArr (M1 S c a p) where + gToJSArr f a (M1 x) = do + r <- gToJSVal f False x + AI.push r a + +instance GToJSVal (V1 p) where + gToJSVal _ _ _ = return Prim.jsNull + +instance GToJSVal (U1 p) where + gToJSVal _ _ _ = return F.jsTrue + +toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ())) + => (String -> String) -> a -> IO JSVal +toJSVal_generic f x = gToJSVal f False (from x :: Rep a ()) + +-- ----------------------------------------------------------------------------- + +class GFromJSVal a where + gFromJSVal :: (String -> String) -> Bool -> JSVal -> IO (Maybe a) + +class GFromJSProp a where + gFromJSProp :: (String -> String) -> JSVal -> IO (Maybe a) + +class GFromJSArr a where + gFromJSArr :: (String -> String) -> MutableJSArray -> Int -> IO (Maybe (a,Int)) + +instance FromJSVal b => GFromJSVal (K1 a b c) where + gFromJSVal _ _ r = fmap K1 <$> fromJSVal r + +instance GFromJSVal p => GFromJSVal (Par1 p) where + gFromJSVal f b r = gFromJSVal f b r + +instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where + gFromJSVal f b r = gFromJSVal f b r + +instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where + gFromJSVal f b r = do + l <- gFromJSVal f True r + case l of + Just x -> return (L1 <$> Just x) + Nothing -> fmap R1 <$> gFromJSVal f True r + +instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where + gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r + +instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where + gFromJSVal f True r = do + r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r) + if isUndefined r' + then return Nothing + else fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r' + gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r + +instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where + gFromJSVal f True r = gFromJSProp f r + gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0 + +instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where + gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r + +instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) where + gFromJSProp f r = do + a <- gFromJSProp f r + case a of + Nothing -> return Nothing + Just a' -> fmap (a':*:) <$> gFromJSProp f r + +instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where + gFromJSProp f o = do + p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o) + if isUndefined p + then return Nothing + else fmap M1 <$> gFromJSVal f False p + +instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where + gFromJSArr f r n = do + a <- gFromJSArr f r 0 + case a of + Just (a',an) -> do + b <- gFromJSArr f r an + case b of + Just (b',bn) -> return (Just (a' :*: b',bn)) + _ -> return Nothing + +instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where + gFromJSArr f o n = do + r <- AI.read n o + if isUndefined r + then return Nothing + else fmap ((,n+1) . M1) <$> gFromJSVal f False r + +instance GFromJSVal (V1 p) where + gFromJSVal _ _ _ = return Nothing + +instance GFromJSVal (U1 p) where + gFromJSVal _ _ _ = return (Just U1) + +fromJSVal_generic :: forall a . (Generic a, GFromJSVal (Rep a ())) + => (String -> String) -> JSVal -> IO (Maybe a) +fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: IO (Maybe (Rep a ()))) + +-- ----------------------------------------------------------------------------- + +fromJSVal_pure :: PFromJSVal a => JSVal -> IO (Maybe a) +fromJSVal_pure x = return (Just (pFromJSVal x)) +{-# INLINE fromJSVal_pure #-} + +fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> IO a +fromJSValUnchecked_pure x = return (pFromJSVal x) +{-# INLINE fromJSValUnchecked_pure #-} + +toJSVal_pure :: PToJSVal a => a -> IO JSVal +toJSVal_pure x = return (pToJSVal x) +{-# INLINE toJSVal_pure #-} + +-- ----------------------------------------------------------------------------- + +packJSS :: String -> JSString +packJSS = JSS.JSString . Prim.toJSString diff --git a/src-wasm/GHCJS/Marshal/Pure.hs b/src-wasm/GHCJS/Marshal/Pure.hs new file mode 100644 index 0000000..6e79ad1 --- /dev/null +++ b/src-wasm/GHCJS/Marshal/Pure.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{- + experimental pure marshalling for lighter weight interaction in the quasiquoter + -} +module GHCJS.Marshal.Pure ( PFromJSVal(..) + , PToJSVal(..) + , jsvalToChar + , charToJSVal + ) where + +import Data.Char (chr, ord) +import Data.Data +import Data.Int (Int8, Int16, Int32) +import Data.JSString.Internal.Type +import Data.Maybe +import Data.Text (Text) +import Data.Typeable +import Data.Word (Word8, Word16, Word32, Word) +import Data.JSString +import Data.JSString.Text +import Data.Bits ((.&.)) +import Unsafe.Coerce (unsafeCoerce) +import GHC.Int +import GHC.Word +import GHC.Types +import GHC.Float +import GHC.Prim + +import GHCJS.Types +import qualified GHC.Wasm.Prim as Prim +import GHCJS.Foreign.Internal +import GHCJS.Marshal.Internal + +{- +type family IsPureShared a where + IsPureShared PureExclusive = False + IsPureShared PureShared = True + +type family IsPureExclusive a where + IsPureExclusive PureExclusive = True + IsPureExclusive PureShared = True + -} + +instance PFromJSVal JSVal where pFromJSVal = id + {-# INLINE pFromJSVal #-} +instance PFromJSVal () where pFromJSVal _ = () + {-# INLINE pFromJSVal #-} + +instance PFromJSVal JSString where pFromJSVal = JSString + {-# INLINE pFromJSVal #-} +instance PFromJSVal [Char] where pFromJSVal = Prim.fromJSString + {-# INLINE pFromJSVal #-} +instance PFromJSVal Text where pFromJSVal = textFromJSVal + {-# INLINE pFromJSVal #-} +instance PFromJSVal Char where pFromJSVal x = C# (jsvalToChar x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Bool where pFromJSVal = isTruthy + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int where pFromJSVal x = I# (jsvalToInt x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int8 where pFromJSVal x = I8# (jsvalToInt8 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int16 where pFromJSVal x = I16# (jsvalToInt16 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int32 where pFromJSVal x = I32# (jsvalToInt32 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word where pFromJSVal x = W# (jsvalToWord x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word8 where pFromJSVal x = W8# (jsvalToWord8 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word16 where pFromJSVal x = W16# (jsvalToWord16 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word32 where pFromJSVal x = (jsvalToWord32 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Double where pFromJSVal x = D# (jsvalToDouble x) + {-# INLINE pFromJSVal #-} + +instance PFromJSVal a => PFromJSVal (Maybe a) where + pFromJSVal x | isUndefined x || isNull x = Nothing + pFromJSVal x = Just (pFromJSVal x) + {-# INLINE pFromJSVal #-} + +instance PToJSVal JSVal where pToJSVal = id + {-# INLINE pToJSVal #-} +instance PToJSVal JSString where pToJSVal = jsval + {-# INLINE pToJSVal #-} +instance PToJSVal [Char] where pToJSVal = Prim.toJSString + {-# INLINE pToJSVal #-} +instance PToJSVal Text where pToJSVal = jsval . textToJSString + {-# INLINE pToJSVal #-} +instance PToJSVal Char where pToJSVal (C# c) = charToJSVal c + {-# INLINE pToJSVal #-} +instance PToJSVal Bool where pToJSVal True = jsTrue + pToJSVal False = jsFalse + {-# INLINE pToJSVal #-} +instance PToJSVal Int where pToJSVal (I# x) = intToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Int8 where pToJSVal (I8# x) = intToJSVal (int8ToInt# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Int16 where pToJSVal (I16# x) = intToJSVal (int16ToInt# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Int32 where pToJSVal (I32# x) = intToJSVal (int32ToInt# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Word where pToJSVal (W# x) = wordToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Word8 where pToJSVal (W8# x) = wordToJSVal (word8ToWord# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Word16 where pToJSVal (W16# x) = wordToJSVal (word16ToWord# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Word32 where pToJSVal (W32# x) = wordToJSVal (word32ToWord# x) + {-# INLINE pToJSVal #-} +instance PToJSVal Float where pToJSVal (F# x) = floatToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Double where pToJSVal (D# x) = doubleToJSVal x + {-# INLINE pToJSVal #-} + +instance PToJSVal a => PToJSVal (Maybe a) where + pToJSVal Nothing = jsNull + pToJSVal (Just a) = pToJSVal a + {-# INLINE pToJSVal #-} + +foreign import javascript unsafe "((x) => { return x>>>0; })" jsvalToWord :: JSVal -> Word# +foreign import javascript unsafe "((x) => { return x&0xff; })" jsvalToWord8 :: JSVal -> Word8# +foreign import javascript unsafe "((x) => { return x&0xffff; })" jsvalToWord16 :: JSVal -> Word16# +foreign import javascript unsafe "((x) => { return x>>>0; })" jsvalToWord32 :: JSVal -> Word32 +foreign import javascript unsafe "((x) => { return x|0; })" jsvalToInt :: JSVal -> Int# +foreign import javascript unsafe "((x) => { return x<<24>>24; })" jsvalToInt8 :: JSVal -> Int8# +foreign import javascript unsafe "((x) => { return x<<16>>16; })" jsvalToInt16 :: JSVal -> Int16# +foreign import javascript unsafe "((x) => { return x|0; })" jsvalToInt32 :: JSVal -> Int32# +foreign import javascript unsafe "((x) => { return +x; })" jsvalToFloat :: JSVal -> Float# +foreign import javascript unsafe "((x) => { return +x; })" jsvalToDouble :: JSVal -> Double# +foreign import javascript unsafe "((x) => { return x&0x7fffffff; })" jsvalToChar :: JSVal -> Char# + +foreign import javascript unsafe "((x) => { return x; })" wordToJSVal :: Word# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" intToJSVal :: Int# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" doubleToJSVal :: Double# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" floatToJSVal :: Float# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" charToJSVal :: Char# -> JSVal + diff --git a/src-wasm/GHCJS/Types.hs b/src-wasm/GHCJS/Types.hs new file mode 100644 index 0000000..8be3699 --- /dev/null +++ b/src-wasm/GHCJS/Types.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} + +module GHCJS.Types ( JSVal + , WouldBlockException(..) + , JSException(..) + , IsJSVal + , jsval + -- , isNull + -- , isUndefined + , nullRef + , JSString + , toPtr + , fromPtr + -- , JSRef + ) where + +-- import Data.JSString.Internal.Type (JSString) +import GHCJS.Internal.Types + +import GHC.Wasm.Prim + +import GHC.Int +import GHC.Types +import GHC.Prim +import GHC.Ptr + +import Control.DeepSeq + +-- type Ref# = ByteArray# + +-- mkRef :: ByteArray# -> JSVal +-- mkRef x = JSVal x + +nullRef :: JSVal +nullRef = js_nullRef +{-# INLINE nullRef #-} + +toPtr :: JSVal -> Ptr a +toPtr j = js_mkPtr j +{-# INLINE toPtr #-} + +fromPtr :: Ptr a -> JSVal +fromPtr p = js_ptrVal p +{-# INLINE fromPtr #-} + +foreign import javascript unsafe "((x) => { return null; })" + js_nullRef :: JSVal + +foreign import javascript unsafe "((x,y) => { return x; })" + js_ptrVal :: Ptr a -> JSVal + +foreign import javascript unsafe "((x) => { h$ret1 = 0; return x; })" + js_mkPtr :: JSVal -> Ptr a + +-- | This is a deprecated copmatibility wrapper for the old JSRef type. +-- +-- See https://github.com/ghcjs/ghcjs/issues/421 +-- type JSRef a = JSVal +-- {-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-} diff --git a/src-wasm/JavaScript/Array.hs b/src-wasm/JavaScript/Array.hs new file mode 100644 index 0000000..47171da --- /dev/null +++ b/src-wasm/JavaScript/Array.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} +module JavaScript.Array + ( JSArray + , MutableJSArray + , create + , length + , lengthIO + , null + , fromList + , fromListIO + , toList + , toListIO + , index, (!) + , read + , write + , append + , push + , pop + , unshift + , shift + , reverse + , take + , takeIO + , drop + , dropIO + , slice + , sliceIO + , freeze + , unsafeFreeze + , thaw + , unsafeThaw + ) where + +import Prelude hiding (length, drop, read, take, reverse, null) + +import qualified GHC.Wasm.Prim as Prim +import GHCJS.Types + +import JavaScript.Array.Internal (JSArray(..)) +import JavaScript.Array.Internal + +-- import qualified JavaScript.Array.Internal as I +{- +fromList :: [JSVal] -> IO (JSArray a) +fromList xs = fmap JSArray (I.fromList xs) +{-# INLINE fromList #-} + +toList :: JSArray a -> IO [JSVal] +toList (JSArray x) = I.toList x +{-# INLINE toList #-} + +create :: IO (JSArray a) +create = fmap JSArray I.create +{-# INLINE create #-} + +length :: JSArray a -> IO Int +length (JSArray x) = I.length x +{-# INLINE length #-} + +append :: JSArray a -> JSArray a -> IO (JSArray a) +append (JSArray x) (JSArray y) = fmap JSArray (I.append x y) +{-# INLINE append #-} +-} + +(!) :: JSArray -> Int -> JSVal +x ! n = index n x +{-# INLINE (!) #-} + +{- + +index :: Int -> JSArray a -> IO JSVal +index n (JSArray x) = I.index n x +{-# INLINE index #-} + +write :: Int -> JSVal -> JSArray a -> IO () +write n e (JSArray x) = I.write n e x +{-# INLINE write #-} + +drop :: Int -> JSArray a -> IO (JSArray a) +drop n (JSArray x) = fmap JSArray (I.drop n x) +{-# INLINE drop #-} + +take :: Int -> JSArray a -> IO (JSArray a) +take n (JSArray x) = fmap JSArray (I.take n x) +{-# INLINE take #-} + +slice :: Int -> Int -> JSArray a -> IO (JSArray a) +slice s n (JSArray x) = fmap JSArray (I.slice s n x) +{-# INLINE slice #-} + +push :: JSVal -> JSArray a -> IO () +push e (JSArray x) = I.push e x +{-# INLINE push #-} + +pop :: JSArray a -> IO JSVal +pop (JSArray x) = I.pop x +{-# INLINE pop #-} + +unshift :: JSVal -> JSArray a -> IO () +unshift e (JSArray x) = I.unshift e x +{-# INLINE unshift #-} + +shift :: JSArray a -> IO JSVal +shift (JSArray x) = I.shift x +{-# INLINE shift #-} + +reverse :: JSArray a -> IO () +reverse (JSArray x) = I.reverse x +{-# INLINE reverse #-} +-} + diff --git a/src-wasm/JavaScript/Array/Internal.hs b/src-wasm/JavaScript/Array/Internal.hs new file mode 100644 index 0000000..15e7fc9 --- /dev/null +++ b/src-wasm/JavaScript/Array/Internal.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DataKinds, KindSignatures, + PolyKinds, UnboxedTuples, GHCForeignImportPrim, DeriveDataTypeable, + UnliftedFFITypes, MagicHash + #-} +module JavaScript.Array.Internal where + +import Prelude hiding (length, reverse, drop, take) + +import Control.DeepSeq +import Data.Typeable +import Unsafe.Coerce (unsafeCoerce) + +import GHC.Types +import GHC.IO +import qualified GHC.Exts as Exts +import GHC.Exts (State#) + +import GHCJS.Internal.Types +import qualified GHC.Wasm.Prim as Prim +import GHCJS.Types + +newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal + deriving (Typeable) +instance IsJSVal (SomeJSArray m) + +type JSArray = SomeJSArray Immutable +type MutableJSArray = SomeJSArray Mutable + +type STJSArray s = SomeJSArray (STMutable s) + +create :: IO MutableJSArray +create = IO js_create +{-# INLINE create #-} + +length :: JSArray -> Int +length x = js_lengthPure x +{-# INLINE length #-} + +lengthIO :: SomeJSArray m -> IO Int +lengthIO x = IO (js_length x) +{-# INLINE lengthIO #-} + +null :: JSArray -> Bool +null x = length x == 0 +{-# INLINE null #-} + +append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1) +append x y = IO (js_append x y) +{-# INLINE append #-} + +fromList :: [JSVal] -> JSArray +fromList xs = rnf xs `seq` js_toJSArrayPure (unsafeCoerce xs) +{-# INLINE fromList #-} + +fromListIO :: [JSVal] -> IO (SomeJSArray m) +fromListIO xs = IO (\s -> rnf xs `seq` js_toJSArray (unsafeCoerce xs) s) +{-# INLINE fromListIO #-} + +toList :: JSArray -> [JSVal] +toList x = unsafeCoerce (js_fromJSArrayPure x) +{-# INLINE toList #-} + +toListIO :: SomeJSArray m -> IO [JSVal] +toListIO x = IO $ \s -> case js_fromJSArray x s of + (# s', xs #) -> (# s', unsafeCoerce xs #) +{-# INLINE toListIO #-} + +index :: Int -> JSArray -> JSVal +index n x = js_indexPure n x +{-# INLINE index #-} + +read :: Int -> SomeJSArray m -> IO JSVal +read n x = IO (js_index n x) +{-# INLINE read #-} + +write :: Int -> JSVal -> MutableJSArray -> IO () +write n e x = IO (js_setIndex n e x) +{-# INLINE write #-} + +push :: JSVal -> MutableJSArray -> IO () +push e x = IO (js_push e x) +{-# INLINE push #-} + +pop :: MutableJSArray -> IO JSVal +pop x = IO (js_pop x) +{-# INLINE pop #-} + +unshift :: JSVal -> MutableJSArray -> IO () +unshift e x = IO (js_unshift e x) +{-# INLINE unshift #-} + +shift :: MutableJSArray -> IO JSVal +shift x = IO (js_shift x) +{-# INLINE shift #-} + +reverse :: MutableJSArray -> IO () +reverse x = IO (js_reverse x) +{-# INLINE reverse #-} + +take :: Int -> JSArray -> JSArray +take n x = js_slicePure 0 n x +{-# INLINE take #-} + +takeIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1) +takeIO n x = IO (js_slice 0 n x) +{-# INLINE takeIO #-} + +drop :: Int -> JSArray -> JSArray +drop n x = js_slice1Pure n x +{-# INLINE drop #-} + +dropIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1) +dropIO n x = IO (js_slice1 n x) +{-# INLINE dropIO #-} + +sliceIO :: Int -> Int -> JSArray -> IO (SomeJSArray m1) +sliceIO s n x = IO (js_slice s n x) +{-# INLINE sliceIO #-} + +slice :: Int -> Int -> JSArray -> JSArray +slice s n x = js_slicePure s n x +{-# INLINE slice #-} + +freeze :: MutableJSArray -> IO JSArray +freeze x = IO (js_slice1 0 x) +{-# INLINE freeze #-} + +unsafeFreeze :: MutableJSArray -> IO JSArray +unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x) +{-# INLINE unsafeFreeze #-} + +thaw :: JSArray -> IO MutableJSArray +thaw x = IO (js_slice1 0 x) +{-# INLINE thaw #-} + +unsafeThaw :: JSArray -> IO MutableJSArray +unsafeThaw (SomeJSArray x) = pure (SomeJSArray x) +{-# INLINE unsafeThaw #-} + + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe "((x) => { return []; })" + js_create :: State# s -> (# State# s, SomeJSArray m #) + +foreign import javascript unsafe "((x) => { return x.length; })" + js_length :: SomeJSArray m -> State# s -> (# State# s, Int #) +foreign import javascript unsafe "((x,y) => { return y[x]; })" + js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSVal #) + +foreign import javascript unsafe "((x,y) => { return y[x]; })" + js_indexPure :: Int -> JSArray -> JSVal +foreign import javascript unsafe "((x) => { return x.length; })" + js_lengthPure :: JSArray -> Int + +foreign import javascript unsafe "((x,y,z) => { z[x] = y; })" + js_setIndex :: Int -> JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) + +foreign import javascript unsafe "((x,y,z) => { return z.slice(x,y); })" + js_slice :: Int -> Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #) +foreign import javascript unsafe "((x,y) => { return y.slice(x); })" + js_slice1 :: Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #) + +foreign import javascript unsafe "((x,y,z) => { return z.slice(x,y); })" + js_slicePure :: Int -> Int -> JSArray -> JSArray +foreign import javascript unsafe "((x,y) => { return y.slice(x); })" + js_slice1Pure :: Int -> JSArray -> JSArray + +foreign import javascript unsafe "((x,y) => { return x.concat(y); })" + js_append :: SomeJSArray m0 -> SomeJSArray m1 -> State# s -> (# State# s, SomeJSArray m2 #) + +foreign import javascript unsafe "((x,y) => { y.push(x); })" + js_push :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) +foreign import javascript unsafe "((x) => { return x.pop(); })" + js_pop :: SomeJSArray m -> State# s -> (# State# s, JSVal #) +foreign import javascript unsafe "((x,y) => { y.unshift(x); })" + js_unshift :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) +foreign import javascript unsafe "((x) => { return x.shift(); })" + js_shift :: SomeJSArray m -> State# s -> (# State# s, JSVal #) + +foreign import javascript unsafe "((x) => { return x.reverse(); })" + js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #) + +foreign import javascript unsafe "h$toHsListJSVal" + js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #) +foreign import javascript unsafe "h$toHsListJSVal" + js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSVal] + +foreign import javascript unsafe "h$fromHsListJSVal" + js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #) +foreign import javascript unsafe "h$fromHsListJSVal" + js_toJSArrayPure :: Exts.Any -> JSArray + diff --git a/src-wasm/JavaScript/Object.hs b/src-wasm/JavaScript/Object.hs new file mode 100644 index 0000000..f3c59ec --- /dev/null +++ b/src-wasm/JavaScript/Object.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE UnboxedTuples #-} + +module JavaScript.Object ( Object + , create + , getProp, unsafeGetProp + , setProp, unsafeSetProp + , allProps, listProps + , isInstanceOf + ) where + + + +import Data.JSString + +import qualified JavaScript.Array as A + +import qualified JavaScript.Array.Internal as AI +import JavaScript.Object.Internal (Object(..)) + +import JavaScript.Object.Internal -- as I + +import GHCJS.Types + +{- +-- | create an empty object +create :: IO Object +create = fmap Object I.create +{-# INLINE create #-} + +allProps :: Object -> IO (JSArray JSString) +allProps (Object o) = fmap AI.JSArray (I.allProps o) +{-# INLINE allProps #-} + +listProps :: Object -> IO [JSString] +listProps (Object o) = I.listProps o +{-# INLINE listProps #-} + +{- | get a property from an object. If accessing the property results in + an exception, the exception is converted to a JSException. Since exception + handling code prevents some optimizations in some JS engines, you may want + to use unsafeGetProp instead + -} +getProp :: JSString -> Object -> IO (JSVal a) +getProp p (Object o) = I.getProp p o +{-# INLINE getProp #-} + +unsafeGetProp :: JSString -> Object -> IO (JSVal a) +unsafeGetProp p (Object o) = I.unsafeGetProp p o +{-# INLINE unsafeGetProp #-} + +setProp :: JSString -> JSVal a -> Object -> IO () +setProp p v (Object o) = I.setProp p v o +{-# INLINE setProp #-} + +unsafeSetProp :: JSString -> JSVal a -> Object -> IO () +unsafeSetProp p v (Object o) = I.unsafeSetProp p v o +{-# INLINE unsafeSetProp #-} + +isInstanceOf :: Object -> JSVal a -> Bool +isInstanceOf (Object o) s = I.isInstanceOf o s +{-# INLINE isInstanceOf #-} +-} + +-- ----------------------------------------------------------------------------- +{- +foreign import javascript safe "$2[$1]" + js_getProp :: JSString -> JSVal a -> IO (JSVal b) +foreign import javascript unsafe "$2[$1]" + js_unsafeGetProp :: JSString -> JSVal a -> IO (JSVal b) +foreign import javascript safe "$3[$1] = $2" + js_setProp :: JSString -> JSVal a -> JSVal b -> IO () +foreign import javascript unsafe "$3[$1] = $2" + js_unsafeSetProp :: JSString -> JSVal a -> JSVal b -> IO () +foreign import javascript unsafe "$1 instanceof $2" + js_isInstanceOf :: Object -> JSVal a -> Bool +foreign import javascript unsafe "h$allProps" + js_allProps :: Object -> IO (JSArray JSString) +foreign import javascript unsafe "h$listProps" + js_listProps :: Object -> (# [JSString] #) +-} diff --git a/src-wasm/JavaScript/Object/Internal.hs b/src-wasm/JavaScript/Object/Internal.hs new file mode 100644 index 0000000..d919c1c --- /dev/null +++ b/src-wasm/JavaScript/Object/Internal.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module JavaScript.Object.Internal + ( Object(..) + , create + , allProps + , listProps + , getProp + , unsafeGetProp + , setProp + , unsafeSetProp + , isInstanceOf + ) where + +import Data.JSString +import Data.Typeable + +import qualified GHC.Wasm.Prim as Prim +import GHCJS.Types + +import qualified JavaScript.Array as JA +import JavaScript.Array.Internal (JSArray, SomeJSArray(..)) + +import Unsafe.Coerce +import qualified GHC.Exts as Exts + +newtype Object = Object JSVal deriving (Typeable) +instance IsJSVal Object + +-- | create an empty object +create :: IO Object +create = js_create +{-# INLINE create #-} + +allProps :: Object -> IO JSArray +allProps o = js_allProps o +{-# INLINE allProps #-} + +listProps :: Object -> IO [JSString] +listProps o = unsafeCoerce (js_listProps o) +{-# INLINE listProps #-} + +{- | get a property from an object. If accessing the property results in + an exception, the exception is converted to a JSException. Since exception + handling code prevents some optimizations in some JS engines, you may want + to use unsafeGetProp instead + -} +getProp :: JSString -> Object -> IO JSVal +getProp p o = js_getProp p o +{-# INLINE getProp #-} + +unsafeGetProp :: JSString -> Object -> IO JSVal +unsafeGetProp p o = js_unsafeGetProp p o +{-# INLINE unsafeGetProp #-} + +setProp :: JSString -> JSVal -> Object -> IO () +setProp p v o = js_setProp p v o +{-# INLINE setProp #-} + +unsafeSetProp :: JSString -> JSVal -> Object -> IO () +unsafeSetProp p v o = js_unsafeSetProp p v o +{-# INLINE unsafeSetProp #-} + +isInstanceOf :: Object -> JSVal -> Bool +isInstanceOf o s = js_isInstanceOf o s +{-# INLINE isInstanceOf #-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe "(() => { return {}; })" + js_create :: IO Object +foreign import javascript safe "((x,y) => { return y[x]; })" + js_getProp :: JSString -> Object -> IO JSVal +foreign import javascript unsafe "((x,y) => { return y[x]; })" + js_unsafeGetProp :: JSString -> Object -> IO JSVal +foreign import javascript safe "((x,y,z) => { z[x] = y; })" + js_setProp :: JSString -> JSVal -> Object -> IO () +foreign import javascript unsafe "((x,y,z) => { z[x] = y; })" + js_unsafeSetProp :: JSString -> JSVal -> Object -> IO () +foreign import javascript unsafe "((x,y) => { return x instanceof y; })" + js_isInstanceOf :: Object -> JSVal -> Bool +foreign import javascript unsafe "h$allProps" + js_allProps :: Object -> IO JSArray +foreign import javascript unsafe "h$listProps" + js_listProps :: Object -> IO Exts.Any -- [JSString] diff --git a/src-wasm/JavaScript/TypedArray.hs b/src-wasm/JavaScript/TypedArray.hs new file mode 100644 index 0000000..c250bd7 --- /dev/null +++ b/src-wasm/JavaScript/TypedArray.hs @@ -0,0 +1,19 @@ +module JavaScript.TypedArray + ( TypedArray(..) + , Int8Array, Int16Array, Int32Array + , Uint8Array, Uint16Array, Uint32Array + , Uint8ClampedArray, Float32Array, Float64Array + , length + , byteLength + , byteOffset + , buffer + , subarray + , set + , unsafeSet + ) where + +import Prelude () + +import JavaScript.TypedArray.Internal +import JavaScript.TypedArray.Internal.Types + diff --git a/src-wasm/JavaScript/TypedArray/ArrayBuffer.hs b/src-wasm/JavaScript/TypedArray/ArrayBuffer.hs new file mode 100644 index 0000000..4af6b10 --- /dev/null +++ b/src-wasm/JavaScript/TypedArray/ArrayBuffer.hs @@ -0,0 +1,48 @@ +module JavaScript.TypedArray.ArrayBuffer + ( ArrayBuffer + , MutableArrayBuffer + , freeze, unsafeFreeze + , thaw, unsafeThaw + , byteLength + ) where + +import JavaScript.TypedArray.ArrayBuffer.Internal + +import GHC.Exts +import GHC.Types + +create :: Int -> IO MutableArrayBuffer +create n = fmap SomeArrayBuffer (IO (js_create n)) +{-# INLINE create #-} + +{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -} +freeze :: MutableArrayBuffer -> IO ArrayBuffer +freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b)) +{-# INLINE freeze #-} + +{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without + copying. The result shares the buffer with the argument, not modify + the data in the 'MutableArrayBuffer' after freezing + -} +unsafeFreeze :: MutableArrayBuffer -> IO ArrayBuffer +unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) +{-# INLINE unsafeFreeze #-} + +{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -} +thaw :: ArrayBuffer -> IO MutableArrayBuffer +thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b)) +{-# INLINE thaw #-} + +unsafeThaw :: ArrayBuffer -> IO MutableArrayBuffer +unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) +{-# INLINE unsafeThaw #-} + +slice :: Int -> Maybe Int -> SomeArrayBuffer any -> SomeArrayBuffer any +slice begin (Just end) b = js_slice_imm begin end b +slice begin _ b = js_slice1_imm begin b +{-# INLINE slice #-} + +byteLength :: SomeArrayBuffer any -> Int +byteLength b = js_byteLength b +{-# INLINE byteLength #-} + diff --git a/src-wasm/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/src-wasm/JavaScript/TypedArray/ArrayBuffer/Internal.hs new file mode 100644 index 0000000..f11dfc7 --- /dev/null +++ b/src-wasm/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module JavaScript.TypedArray.ArrayBuffer.Internal where + +import GHCJS.Types + +import GHCJS.Internal.Types +import GHCJS.Marshal.Pure + +import GHC.Exts (State#) + +import Data.Typeable + +newtype SomeArrayBuffer (a :: MutabilityType s) = + SomeArrayBuffer JSVal deriving Typeable +instance IsJSVal (SomeArrayBuffer m) + +type ArrayBuffer = SomeArrayBuffer Immutable +type MutableArrayBuffer = SomeArrayBuffer Mutable +type STArrayBuffer s = SomeArrayBuffer (STMutable s) + +instance PToJSVal MutableArrayBuffer where + pToJSVal (SomeArrayBuffer b) = b +instance PFromJSVal MutableArrayBuffer where + pFromJSVal = SomeArrayBuffer + +-- ---------------------------------------------------------------------------- + +foreign import javascript unsafe + "((x) => { return x.byteLength; })" js_byteLength :: SomeArrayBuffer any -> Int +foreign import javascript unsafe + "((x) => { return new ArrayBuffer(x); })" js_create :: Int -> State# s -> (# State# s, JSVal #) +foreign import javascript unsafe + "((x,y) => { return y.slice(x); })" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) + +-- ---------------------------------------------------------------------------- +-- immutable non-IO slice + +foreign import javascript unsafe + "((x,y) => { return y.slice(x); })" js_slice1_imm :: Int -> SomeArrayBuffer any -> SomeArrayBuffer any +foreign import javascript unsafe + "((x,y,z) => { return z.slice(x,y); })" js_slice_imm :: Int -> Int -> SomeArrayBuffer any -> SomeArrayBuffer any diff --git a/src-wasm/JavaScript/TypedArray/Internal.hs b/src-wasm/JavaScript/TypedArray/Internal.hs new file mode 100644 index 0000000..dbbe379 --- /dev/null +++ b/src-wasm/JavaScript/TypedArray/Internal.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} + +module JavaScript.TypedArray.Internal where + +import Data.Typeable + +import GHC.Types +import GHC.Exts +import GHC.ST + +import GHC.Int +import GHC.Word + +import GHCJS.Internal.Types +import GHCJS.Buffer.Types +import GHCJS.Types + +import JavaScript.Array.Internal (SomeJSArray(..), JSArray) +import JavaScript.TypedArray.ArrayBuffer +import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..)) +import JavaScript.TypedArray.Internal.Types + +elemSize :: SomeTypedArray e m -> Int +elemSize a = js_elemSize a +{-# INLINE [1] elemSize #-} +{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = 1 #-} +{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = 1 #-} +{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = 2 #-} +{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = 4 #-} +{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = 1 #-} +{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = 2 #-} +{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = 4 #-} +{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = 4 #-} +{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = 8 #-} + +instance TypedArray IOInt8Array where + index i a = IO (indexI8 i a) + unsafeIndex i a = IO (unsafeIndexI8 i a) + setIndex i (I8# x) a = IO (setIndexI i (int8ToInt# x) a) + unsafeSetIndex i (I8# x) a = IO (unsafeSetIndexI i (int8ToInt# x) a) + indexOf s (I8# x) a = IO (indexOfI s (int8ToInt# x) a) + lastIndexOf s (I8# x) a = IO (lastIndexOfI s (int8ToInt# x) a) + create l = IO (js_createInt8Array l) + fromArray a = int8ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOInt16Array where + index i a = IO (indexI16 i a) + unsafeIndex i a = IO (unsafeIndexI16 i a) + setIndex i (I16# x) a = IO (setIndexI i (int16ToInt# x) a) + unsafeSetIndex i (I16# x) a = IO (unsafeSetIndexI i (int16ToInt# x) a) + indexOf s (I16# x) a = IO (indexOfI s (int16ToInt# x) a) + lastIndexOf s (I16# x) a = IO (lastIndexOfI s (int16ToInt# x) a) + create l = IO (js_createInt16Array l) + fromArray a = int16ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOInt32Array where + index i a = IO (indexI i a) + unsafeIndex i a = IO (unsafeIndexI i a) + setIndex i (I# x) a = IO (setIndexI i x a) + unsafeSetIndex i (I# x) a = IO (unsafeSetIndexI i x a) + indexOf s (I# x) a = IO (indexOfI s x a) + lastIndexOf s (I# x) a = IO (lastIndexOfI s x a) + create l = IO (js_createInt32Array l) + fromArray a = int32ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOUint8ClampedArray where + index i a = IO (indexW8 i a) + unsafeIndex i a = IO (unsafeIndexW8 i a) + setIndex i (W8# x) a = IO (setIndexW i (word8ToWord# x) a) + unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i (word8ToWord# x) a) + indexOf s (W8# x) a = IO (indexOfW s (word8ToWord# x) a) + lastIndexOf s (W8# x) a = IO (lastIndexOfW s (word8ToWord# x) a) + create l = IO (js_createUint8ClampedArray l) + fromArray a = uint8ClampedArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOUint8Array where + index i a = IO (indexW8 i a) + unsafeIndex i a = IO (unsafeIndexW8 i a) + setIndex i (W8# x) a = IO (setIndexW i (word8ToWord# x) a) + unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i (word8ToWord# x) a) + indexOf s (W8# x) a = IO (indexOfW s (word8ToWord# x) a) + lastIndexOf s (W8# x) a = IO (lastIndexOfW s (word8ToWord# x) a) + create l = IO (js_createUint8Array l) + fromArray a = uint8ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOUint16Array where + index i a = IO (indexW16 i a) + unsafeIndex i a = IO (unsafeIndexW16 i a) + setIndex i (W16# x) a = IO (setIndexW i (word16ToWord# x) a) + unsafeSetIndex i (W16# x) a = IO (unsafeSetIndexW i (word16ToWord# x) a) + indexOf s (W16# x) a = IO (indexOfW s (word16ToWord# x) a) + lastIndexOf s (W16# x) a = IO (lastIndexOfW s (word16ToWord# x) a) + create l = IO (js_createUint16Array l) + fromArray a = uint16ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOUint32Array where + index i a = IO (indexW i a) + unsafeIndex i a = IO (unsafeIndexW i a) + setIndex i (W# x) a = IO (setIndexW i x a) + unsafeSetIndex i (W# x) a = IO (unsafeSetIndexW i x a) + indexOf s (W# x) a = IO (indexOfW s x a) + lastIndexOf s (W# x) a = IO (lastIndexOfW s x a) + create l = IO (js_createUint32Array l) + fromArray a = uint32ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOFloat32Array where + index i a = IO (indexD i a) + unsafeIndex i a = IO (unsafeIndexD i a) + setIndex i x a = IO (setIndexD i x a) + unsafeSetIndex i x a = IO (unsafeSetIndexD i x a) + indexOf s x a = IO (indexOfD s x a) + lastIndexOf s x a = IO (lastIndexOfD s x a) + create l = IO (js_createFloat32Array l) + fromArray a = float32ArrayFrom a + fromArrayBuffer b = undefined + +instance TypedArray IOFloat64Array where + index i a = IO (indexD i a) + unsafeIndex i a = IO (unsafeIndexD i a) + setIndex i x a = IO (setIndexD i x a) + unsafeSetIndex i x a = IO (unsafeSetIndexD i x a) + indexOf s x a = IO (indexOfD s x a) + lastIndexOf s x a = IO (lastIndexOfD s x a) + create l = IO (js_createFloat64Array l) + fromArray a = float64ArrayFrom a + fromArrayBuffer b = undefined + + +class TypedArray a where + unsafeIndex :: Int -> a -> IO (Elem a) + index :: Int -> a -> IO (Elem a) + unsafeSetIndex :: Int -> Elem a -> a -> IO () + setIndex :: Int -> Elem a -> a -> IO () + create :: Int -> IO a + fromArray :: SomeJSArray m -> IO a + fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> IO a + indexOf :: Int -> Elem a -> a -> IO Int + lastIndexOf :: Int -> Elem a -> a -> IO Int + +-- ----------------------------------------------------------------------------- + +indexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +indexI a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I# v #) +{-# INLINE indexI #-} + +indexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #) +indexI16 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I16# (intToInt16# v) #) +{-# INLINE indexI16 #-} + +indexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #) +indexI8 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I8# (intToInt8# v) #) +{-# INLINE indexI8 #-} + +indexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) +indexW a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W# v #) +{-# INLINE indexW #-} + +indexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #) +indexW16 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W16# (wordToWord16# v) #) +{-# INLINE indexW16 #-} + +indexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #) +indexW8 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W8# (wordToWord8# v) #) +{-# INLINE indexW8 #-} + +indexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) +indexD a i = \s -> js_indexD a i s +{-# INLINE indexD #-} + +-- ----------------------------------------------------------------------------- + +unsafeIndexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +unsafeIndexI a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I# v #) +{-# INLINE unsafeIndexI #-} + +unsafeIndexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #) +unsafeIndexI16 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I16# (intToInt16# v) #) +{-# INLINE unsafeIndexI16 #-} + +unsafeIndexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #) +unsafeIndexI8 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I8# (intToInt8# v) #) +{-# INLINE unsafeIndexI8 #-} + +unsafeIndexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) +unsafeIndexW a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W# v #) +{-# INLINE unsafeIndexW #-} + +unsafeIndexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #) +unsafeIndexW16 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W16# (wordToWord16# v) #) +{-# INLINE unsafeIndexW16 #-} + +unsafeIndexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #) +unsafeIndexW8 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W8# (wordToWord8# v) #) +{-# INLINE unsafeIndexW8 #-} + +unsafeIndexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) +unsafeIndexD a i = \s -> js_unsafeIndexD a i s +{-# INLINE unsafeIndexD #-} + +-- ----------------------------------------------------------------------------- + +int8ArrayFrom :: SomeJSArray m0 -> IO (SomeInt8Array m1) +int8ArrayFrom a = js_int8ArrayFromArray a +{-# INLINE int8ArrayFrom #-} + +int16ArrayFrom :: SomeJSArray m0 -> IO (SomeInt16Array m1) +int16ArrayFrom a = js_int16ArrayFromArray a +{-# INLINE int16ArrayFrom #-} + +int32ArrayFrom :: SomeJSArray m0 -> IO (SomeInt32Array m1) +int32ArrayFrom a = js_int32ArrayFromArray a +{-# INLINE int32ArrayFrom #-} + +uint8ArrayFrom :: SomeJSArray m0 -> IO (SomeUint8Array m1) +uint8ArrayFrom a = js_uint8ArrayFromArray a +{-# INLINE uint8ArrayFrom #-} + +uint8ClampedArrayFrom :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1) +uint8ClampedArrayFrom a = js_uint8ClampedArrayFromArray a +{-# INLINE uint8ClampedArrayFrom #-} + +uint16ArrayFrom :: SomeJSArray m0 -> IO (SomeUint16Array m1) +uint16ArrayFrom a = js_uint16ArrayFromArray a +{-# INLINE uint16ArrayFrom #-} + +uint32ArrayFrom :: SomeJSArray m0 -> IO (SomeUint32Array m1) +uint32ArrayFrom a = js_uint32ArrayFromArray a +{-# INLINE uint32ArrayFrom #-} + +float32ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat32Array m1) +float32ArrayFrom a = js_float32ArrayFromArray a +{-# INLINE float32ArrayFrom #-} + +float64ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat64Array m1) +float64ArrayFrom a = js_float64ArrayFromArray a +{-# INLINE float64ArrayFrom #-} + +-- ----------------------------------------------------------------------------- + +setIndexI :: Mutability m ~ IsMutable + => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +setIndexI i x a = js_setIndexI i x a +{-# INLINE setIndexI #-} + +unsafeSetIndexI :: Mutability m ~ IsMutable + => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +unsafeSetIndexI i x a = js_unsafeSetIndexI i x a +{-# INLINE unsafeSetIndexI #-} + +setIndexW :: Mutability m ~ IsMutable + => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +setIndexW i x a = js_setIndexW i x a +{-# INLINE setIndexW #-} + +unsafeSetIndexW :: Mutability m ~ IsMutable + => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +unsafeSetIndexW i x a = js_unsafeSetIndexW i x a +{-# INLINE unsafeSetIndexW #-} + +setIndexD :: Mutability m ~ IsMutable + => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) +setIndexD i x a = js_setIndexD i x a +{-# INLINE setIndexD #-} + +unsafeSetIndexD :: Mutability m ~ IsMutable + => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) +unsafeSetIndexD i x a = js_unsafeSetIndexD i x a +{-# INLINE unsafeSetIndexD #-} + +indexOfI :: Mutability m ~ IsMutable + => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +indexOfI s x a = js_indexOfI s x a +{-# INLINE indexOfI #-} + +indexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +indexOfW s x a = js_indexOfW s x a +{-# INLINE indexOfW #-} + +indexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +indexOfD s x a = js_indexOfD s x a +{-# INLINE indexOfD #-} + +lastIndexOfI :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +lastIndexOfI s x a = js_lastIndexOfI s x a +{-# INLINE lastIndexOfI #-} + +lastIndexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +lastIndexOfW s x a = js_lastIndexOfW s x a +{-# INLINE lastIndexOfW #-} + +lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +lastIndexOfD s x a = js_lastIndexOfD s x a +{-# INLINE lastIndexOfD #-} + +-- ----------------------------------------------------------------------------- +-- non-class operations usable for all typed array +{-| length of the typed array in elements -} +length :: SomeTypedArray e m -> Int +length x = js_length x +{-# INLINE length #-} + +{-| length of the array in bytes -} +byteLength :: SomeTypedArray e m -> Int +byteLength x = js_byteLength x +{-# INLINE byteLength #-} + +{-| offset of the array in the buffer -} +byteOffset :: SomeTypedArray e m -> Int +byteOffset x = js_byteOffset x +{-# INLINE byteOffset #-} + +{-| the underlying buffer of the array #-} +buffer :: SomeTypedArray e m -> SomeArrayBuffer m +buffer x = js_buffer x +{-# INLINE buffer #-} + +{-| create a view of the existing array -} +subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m +subarray begin end x = js_subarray begin end x +{-# INLINE subarray #-} + +-- fixme convert JSException to Haskell exception +{-| copy the elements of one typed array to another -} +set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO () +set offset src dest = IO (js_set offset src dest) +{-# INLINE set #-} + +unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO () +unsafeSet offset src dest = IO (js_unsafeSet offset src dest) +{-# INLINE unsafeSet #-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe + "((x) => { return x.length; })" js_length :: SomeTypedArray e m -> Int +foreign import javascript unsafe + "((x) => { return x.byteLength; })" js_byteLength :: SomeTypedArray e m -> Int +foreign import javascript unsafe + "((x) => { return x.byteOffset; })" js_byteOffset :: SomeTypedArray e m -> Int +foreign import javascript unsafe + "((x) => { return x.buffer; })" js_buffer :: SomeTypedArray e m -> SomeArrayBuffer m +foreign import javascript unsafe + "((x,y,z) => { return z.subarray(x,y); })" + js_subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m +foreign import javascript safe + "((x,y,z) => { z.set(x,y); })" + js_set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) +foreign import javascript unsafe + "((x,y,z) => { z.set(x,y); })" + js_unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) +foreign import javascript unsafe + "((x) => { return x.BYTES_PER_ELEMENT; })" + js_elemSize :: SomeTypedArray e m -> Int + +-- ----------------------------------------------------------------------------- +-- index + +foreign import javascript safe + "((x,y) => { return y[x]; })" js_indexI + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) +foreign import javascript safe + "((x,y) => { return y[x]; })" js_indexW + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) +foreign import javascript safe + "((x,y) => { return y[x]; })" js_indexD + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) + +foreign import javascript unsafe + "((x,y) => { return y[x]; })" js_unsafeIndexI + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) +foreign import javascript unsafe + "((x,y) => { return y[x]; })" js_unsafeIndexW + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) +foreign import javascript unsafe + "((x,y) => { return y[x]; })" js_unsafeIndexD + :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) + +-- ----------------------------------------------------------------------------- +-- setIndex + +foreign import javascript safe + "((x,y,z) => { z[x] = y; })" js_setIndexI + :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +foreign import javascript safe + "((x,y,z) => { z[x] = y; })" js_setIndexW + :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +foreign import javascript safe + "((x,y,z) => { z[x] = y; })" js_setIndexD + :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) + +foreign import javascript unsafe + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexI + :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +foreign import javascript unsafe + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexW + :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) +foreign import javascript unsafe + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexD + :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) + +-- ------------------------------------------------------------------------------ + +foreign import javascript unsafe + "$3.indexOf($2,$1)" js_indexOfI + :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +foreign import javascript unsafe + "$3.indexOf($2,$1)" js_indexOfW + :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +foreign import javascript unsafe + "$3.indexOf($2,$1)" js_indexOfD + :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) + +foreign import javascript unsafe + "$3.lastIndexOf($2,$1)" js_lastIndexOfI + :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +foreign import javascript unsafe + "$3.lastIndexOf($2,$1)" js_lastIndexOfW + :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +foreign import javascript unsafe + "$3.lastIndexOf($2,$1)" js_lastIndexOfD + :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) + +-- ------------------------------------------------------------------------------ +-- create + +foreign import javascript unsafe + "((x) => { return new Int8Array(x); })" + js_createInt8Array :: Int -> State# s -> (# State# s, SomeInt8Array m #) +foreign import javascript unsafe + "((x) => { return new Int16Array(x); })" + js_createInt16Array :: Int -> State# s -> (# State# s, SomeInt16Array m #) +foreign import javascript unsafe + "((x) => { return new Int32Array(x); })" + js_createInt32Array :: Int -> State# s -> (# State# s, SomeInt32Array m #) + +foreign import javascript unsafe + "((x) => { return new Uint8ClampedArray(x); })" + js_createUint8ClampedArray :: Int -> State# s -> (# State# s, SomeUint8ClampedArray m #) +foreign import javascript unsafe + "((x) => { return new Uint8Array(x); })" + js_createUint8Array :: Int -> State# s -> (# State# s, SomeUint8Array m #) +foreign import javascript unsafe + "((x) => { return new Uint16Array(x); })" + js_createUint16Array :: Int -> State# s -> (# State# s, SomeUint16Array m #) +foreign import javascript unsafe + "((x) => { return new Uint32Array(x); })" + js_createUint32Array :: Int -> State# s -> (# State# s, SomeUint32Array m #) + +foreign import javascript unsafe + "((x) => { return new Float32Array(x); })" + js_createFloat32Array :: Int -> State# s -> (# State# s, SomeFloat32Array m #) +foreign import javascript unsafe + "((x) => { return new Float64Array(x); })" + js_createFloat64Array :: Int -> State# s -> (# State# s, SomeFloat64Array m #) + +-- ------------------------------------------------------------------------------ +-- from array + +foreign import javascript unsafe + "((x) => { return Int8Array.from(x); })" + js_int8ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt8Array m1) +foreign import javascript unsafe + "((x) => { return Int16Array.from(x); })" + js_int16ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt16Array m1) +foreign import javascript unsafe + "((x) => { return Int32Array.from(x); })" + js_int32ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt32Array m1) +foreign import javascript unsafe + "((x) => { return Uint8ClampedArray.from(x); })" + js_uint8ClampedArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1) +foreign import javascript unsafe + "((x) => { return Uint8Array.from(x); })" + js_uint8ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8Array m1) +foreign import javascript unsafe + "((x) => { return Uint16Array.from(x); })" + js_uint16ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint16Array m1) +foreign import javascript unsafe + "((x) => { return Uint32Array.from(x); })" + js_uint32ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint32Array m1) +foreign import javascript unsafe + "((x) => { return Float32Array.from(x); })" + js_float32ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat32Array m1) +foreign import javascript unsafe + "((x) => { return Float64Array.from(x); })" + js_float64ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat64Array m1) + +-- ------------------------------------------------------------------------------ +-- from ArrayBuffer + +foreign import javascript unsafe + "((x) => { return new Int8Array(x); })" + js_int8ArrayFromJSVal :: JSVal -> SomeInt8Array m +foreign import javascript unsafe + "((x) => { return new Int16Array(x); })" + js_int16ArrayFromJSVal :: JSVal -> SomeInt16Array m +foreign import javascript unsafe + "((x) => { return new Int32Array(x); })" + js_int32ArrayFromJSVal :: JSVal -> SomeInt32Array m +foreign import javascript unsafe + "((x) => { return new Uint8ClampedArray(x); })" + js_uint8ClampedArrayFromJSVal :: JSVal -> SomeUint8ClampedArray m +foreign import javascript unsafe + "((x) => { return new Uint8Array(x); })" + js_uint8ArrayFromJSVal :: JSVal -> SomeUint8Array m +foreign import javascript unsafe + "((x) => { return new Uint16Array(x); })" + js_uint16ArrayFromJSVal :: JSVal -> SomeUint16Array m +foreign import javascript unsafe + "((x) => { return new Uint32Array(x); })" + js_uint32ArrayFromJSVal :: JSVal -> SomeUint32Array m +foreign import javascript unsafe + "((x) => { return new Float32Array(x); })" + js_float32ArrayFromJSVal :: JSVal -> SomeFloat32Array m +foreign import javascript unsafe + "((x) => { return new Float64Array(x); })" + js_float64ArrayFromJSVal :: JSVal -> SomeFloat64Array m + diff --git a/src-wasm/JavaScript/TypedArray/Internal/Types.hs b/src-wasm/JavaScript/TypedArray/Internal/Types.hs new file mode 100644 index 0000000..407333f --- /dev/null +++ b/src-wasm/JavaScript/TypedArray/Internal/Types.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} + +module JavaScript.TypedArray.Internal.Types where + +import GHCJS.Types +import GHCJS.Internal.Types + +import Data.Int +import Data.Typeable +import Data.Word + +newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) = + SomeTypedArray JSVal deriving Typeable +instance IsJSVal (SomeTypedArray e m) + +{- +newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal + deriving (Typeable) +-} + +type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s) + +-- ----------------------------------------------------------------------------- + +data TypedArrayElem = Int8Elem + | Int16Elem + | Int32Elem + | Uint8Elem + | Uint16Elem + | Uint32Elem + | Uint8ClampedElem + | Float32Elem + | Float64Elem + +-- ----------------------------------------------------------------------------- + +type SomeInt8Array = SomeTypedArray Int8Elem +type SomeInt16Array = SomeTypedArray Int16Elem +type SomeInt32Array = SomeTypedArray Int32Elem + +type SomeUint8Array = SomeTypedArray Uint8Elem +type SomeUint16Array = SomeTypedArray Uint16Elem +type SomeUint32Array = SomeTypedArray Uint32Elem + +type SomeFloat32Array = SomeTypedArray Float32Elem +type SomeFloat64Array = SomeTypedArray Float64Elem + +type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem + +-- ----------------------------------------------------------------------------- + +type Int8Array = SomeInt8Array Immutable +type Int16Array = SomeInt16Array Immutable +type Int32Array = SomeInt32Array Immutable + +type Uint8Array = SomeUint8Array Immutable +type Uint16Array = SomeUint16Array Immutable +type Uint32Array = SomeUint32Array Immutable + +type Uint8ClampedArray = SomeUint8ClampedArray Immutable + +type Float32Array = SomeFloat32Array Immutable +type Float64Array = SomeFloat64Array Immutable + +-- ----------------------------------------------------------------------------- + +type IOInt8Array = SomeInt8Array Mutable +type IOInt16Array = SomeInt16Array Mutable +type IOInt32Array = SomeInt32Array Mutable + +type IOUint8Array = SomeUint8Array Mutable +type IOUint16Array = SomeUint16Array Mutable +type IOUint32Array = SomeUint32Array Mutable + +type IOUint8ClampedArray = SomeUint8ClampedArray Mutable + +type IOFloat32Array = SomeFloat32Array Mutable +type IOFloat64Array = SomeFloat64Array Mutable + +-- ----------------------------------------------------------------------------- + +type STInt8Array s = SomeSTTypedArray s Int8Elem +type STInt16Array s = SomeSTTypedArray s Int16Elem +type STInt32Array s = SomeSTTypedArray s Int32Elem + +type STUint8Array s = SomeSTTypedArray s Uint8Elem +type STUint16Array s = SomeSTTypedArray s Uint16Elem +type STUint32Array s = SomeSTTypedArray s Uint32Elem + +type STFloat32Array s = SomeSTTypedArray s Float32Elem +type STFloat64Array s = SomeSTTypedArray s Float64Elem + +type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem + +-- ----------------------------------------------------------------------------- + +type family Elem x where + Elem (SomeUint8Array m) = Word8 -- SomeTypedArray Uint8Elem + Elem (SomeUint8ClampedArray m) = Word8 + Elem (SomeUint16Array m) = Word16 + Elem (SomeUint32Array m) = Word + Elem (SomeInt8Array m) = Int8 + Elem (SomeInt16Array m) = Int16 + Elem (SomeInt32Array m) = Int + Elem (SomeFloat32Array m) = Double + Elem (SomeFloat64Array m) = Double +